source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe,ethetacnstr)
 194       else
 195         ebe=0
 196         ethetacnstr=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 #ifdef TIMING
 265       time_enecalc=time_enecalc+MPI_Wtime()-time00
 266 #endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 #ifdef TIMING
 269       time00=MPI_Wtime()
 270 #endif
 271 c
 272 C Sum the energies
 273 C
 274       energia(1)=evdw
 275 #ifdef SCP14
 276       energia(2)=evdw2-evdw2_14
 277       energia(18)=evdw2_14
 278 #else
 279       energia(2)=evdw2
 280       energia(18)=0.0d0
 281 #endif
 282 #ifdef SPLITELE
 283       energia(3)=ees
 284       energia(16)=evdw1
 285 #else
 286       energia(3)=ees+evdw1
 287       energia(16)=0.0d0
 288 #endif
 289       energia(4)=ecorr
 290       energia(5)=ecorr5
 291       energia(6)=ecorr6
 292       energia(7)=eel_loc
 293       energia(8)=eello_turn3
 294       energia(9)=eello_turn4
 295       energia(10)=eturn6
 296       energia(11)=ebe
 297       energia(12)=escloc
 298       energia(13)=etors
 299       energia(14)=etors_d
 300       energia(15)=ehpb
 301       energia(19)=edihcnstr
 302       energia(17)=estr
 303       energia(20)=Uconst+Uconst_back
 304       energia(21)=esccor
 305 C      energia(22)=eliptrans (the energy for lipid transfere implemented in lipid branch)
 306 C      energia(23)= ... (energy for AFM, steered molecular dynamics)
 307       energia(24)=ethetacnstr
 308 c    Here are the energies showed per procesor if the are more processors
 309 c    per molecule then we sum it up in sum_energy subroutine
 310 c      print *," Processor",myrank," calls SUM_ENERGY"
 311       call sum_energy(energia,.true.)
 312       if (dyn_ss) call dyn_set_nss
 313 c      print *," Processor",myrank," left SUM_ENERGY"
 314 #ifdef TIMING
 315       time_sumene=time_sumene+MPI_Wtime()-time00
 316 #endif
 317       return
 318       end
 319 c-------------------------------------------------------------------------------
 320       subroutine sum_energy(energia,reduce)
 321       implicit real*8 (a-h,o-z)
 322       include 'DIMENSIONS'
 323 #ifndef ISNAN
 324       external proc_proc
 325 #ifdef WINPGI
 326 cMS$ATTRIBUTES C ::  proc_proc
 327 #endif
 328 #endif
 329 #ifdef MPI
 330       include "mpif.h"
 331 #endif
 332       include 'COMMON.SETUP'
 333       include 'COMMON.IOUNITS'
 334       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 335       include 'COMMON.FFIELD'
 336       include 'COMMON.DERIV'
 337       include 'COMMON.INTERACT'
 338       include 'COMMON.SBRIDGE'
 339       include 'COMMON.CHAIN'
 340       include 'COMMON.VAR'
 341       include 'COMMON.CONTROL'
 342       include 'COMMON.TIME1'
 343       logical reduce
 344 #ifdef MPI
 345       if (nfgtasks.gt.1 .and. reduce) then
 346 #ifdef DEBUG
 347         write (iout,*) "energies before REDUCE"
 348         call enerprint(energia)
 349         call flush(iout)
 350 #endif
 351         do i=0,n_ene
 352           enebuff(i)=energia(i)
 353         enddo
 354         time00=MPI_Wtime()
 355         call MPI_Barrier(FG_COMM,IERR)
 356         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 357         time00=MPI_Wtime()
 358         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 359      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 360 #ifdef DEBUG
 361         write (iout,*) "energies after REDUCE"
 362         call enerprint(energia)
 363         call flush(iout)
 364 #endif
 365         time_Reduce=time_Reduce+MPI_Wtime()-time00
 366       endif
 367       if (fg_rank.eq.0) then
 368 #endif
 369       evdw=energia(1)
 370 #ifdef SCP14
 371       evdw2=energia(2)+energia(18)
 372       evdw2_14=energia(18)
 373 #else
 374       evdw2=energia(2)
 375 #endif
 376 #ifdef SPLITELE
 377       ees=energia(3)
 378       evdw1=energia(16)
 379 #else
 380       ees=energia(3)
 381       evdw1=0.0d0
 382 #endif
 383       ecorr=energia(4)
 384       ecorr5=energia(5)
 385       ecorr6=energia(6)
 386       eel_loc=energia(7)
 387       eello_turn3=energia(8)
 388       eello_turn4=energia(9)
 389       eturn6=energia(10)
 390       ebe=energia(11)
 391       escloc=energia(12)
 392       etors=energia(13)
 393       etors_d=energia(14)
 394       ehpb=energia(15)
 395       edihcnstr=energia(19)
 396       estr=energia(17)
 397       Uconst=energia(20)
 398       esccor=energia(21)
 399       ethetacnstr=energia(24)
 400
 401 #ifdef SPLITELE
 402       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 403      & +wang*ebe+wtor*etors+wscloc*escloc
 404      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 405      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 406      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 407      & +wbond*estr+Uconst+wsccor*esccor+ethetacnstr
 408 #else
 409       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 410      & +wang*ebe+wtor*etors+wscloc*escloc
 411      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 412      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 413      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 414      & +wbond*estr+Uconst+wsccor*esccor+ethetacnstr
 415 #endif
 416       energia(0)=etot
 417 c detecting NaNQ
 418 #ifdef ISNAN
 419 #ifdef AIX
 420       if (isnan(etot).ne.0) energia(0)=1.0d+99
 421 #else
 422       if (isnan(etot)) energia(0)=1.0d+99
 423 #endif
 424 #else
 425       i=0
 426 #ifdef WINPGI
 427       idumm=proc_proc(etot,i)
 428 #else
 429       call proc_proc(etot,i)
 430 #endif
 431       if(i.eq.1)energia(0)=1.0d+99
 432 #endif
 433 #ifdef MPI
 434       endif
 435 #endif
 436       return
 437       end
 438 c-------------------------------------------------------------------------------
 439       subroutine sum_gradient
 440       implicit real*8 (a-h,o-z)
 441       include 'DIMENSIONS'
 442 #ifndef ISNAN
 443       external proc_proc
 444 #ifdef WINPGI
 445 cMS$ATTRIBUTES C ::  proc_proc
 446 #endif
 447 #endif
 448 #ifdef MPI
 449       include 'mpif.h'
 450       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 451      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 452 #endif
 453       include 'COMMON.SETUP'
 454       include 'COMMON.IOUNITS'
 455       include 'COMMON.FFIELD'
 456       include 'COMMON.DERIV'
 457       include 'COMMON.INTERACT'
 458       include 'COMMON.SBRIDGE'
 459       include 'COMMON.CHAIN'
 460       include 'COMMON.VAR'
 461       include 'COMMON.CONTROL'
 462       include 'COMMON.TIME1'
 463       include 'COMMON.MAXGRAD'
 464       include 'COMMON.SCCOR'
 465 #ifdef TIMING
 466       time01=MPI_Wtime()
 467 #endif
 468 #ifdef DEBUG
 469       write (iout,*) "sum_gradient gvdwc, gvdwx"
 470       do i=1,nres
 471         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 472      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 473       enddo
 474       call flush(iout)
 475 #endif
 476 #ifdef MPI
 477 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 478         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 479      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 480 #endif
 481 C
 482 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 483 C            in virtual-bond-vector coordinates
 484 C
 485 #ifdef DEBUG
 486 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 489 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 490 c      enddo
 491 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 492 c      do i=1,nres-1
 493 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 494 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 495 c      enddo
 496       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 497       do i=1,nres
 498         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 499      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 500      &   g_corr5_loc(i)
 501       enddo
 502       call flush(iout)
 503 #endif
 504 #ifdef SPLITELE
 505       do i=1,nct
 506         do j=1,3
 507           gradbufc(j,i)=wsc*gvdwc(j,i)+
 508      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 509      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 510      &                wel_loc*gel_loc_long(j,i)+
 511      &                wcorr*gradcorr_long(j,i)+
 512      &                wcorr5*gradcorr5_long(j,i)+
 513      &                wcorr6*gradcorr6_long(j,i)+
 514      &                wturn6*gcorr6_turn_long(j,i)+
 515      &                wstrain*ghpbc(j,i)
 516         enddo
 517       enddo
 518 #else
 519       do i=1,nct
 520         do j=1,3
 521           gradbufc(j,i)=wsc*gvdwc(j,i)+
 522      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 523      &                welec*gelc_long(j,i)+
 524      &                wbond*gradb(j,i)+
 525      &                wel_loc*gel_loc_long(j,i)+
 526      &                wcorr*gradcorr_long(j,i)+
 527      &                wcorr5*gradcorr5_long(j,i)+
 528      &                wcorr6*gradcorr6_long(j,i)+
 529      &                wturn6*gcorr6_turn_long(j,i)+
 530      &                wstrain*ghpbc(j,i)
 531         enddo
 532       enddo
 533 #endif
 534 #ifdef MPI
 535       if (nfgtasks.gt.1) then
 536       time00=MPI_Wtime()
 537 #ifdef DEBUG
 538       write (iout,*) "gradbufc before allreduce"
 539       do i=1,nres
 540         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 541       enddo
 542       call flush(iout)
 543 #endif
 544       do i=1,nres
 545         do j=1,3
 546           gradbufc_sum(j,i)=gradbufc(j,i)
 547         enddo
 548       enddo
 549 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 550 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 551 c      time_reduce=time_reduce+MPI_Wtime()-time00
 552 #ifdef DEBUG
 553 c      write (iout,*) "gradbufc_sum after allreduce"
 554 c      do i=1,nres
 555 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 556 c      enddo
 557 c      call flush(iout)
 558 #endif
 559 #ifdef TIMING
 560 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 561 #endif
 562       do i=nnt,nres
 563         do k=1,3
 564           gradbufc(k,i)=0.0d0
 565         enddo
 566       enddo
 567 #ifdef DEBUG
 568       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 569       write (iout,*) (i," jgrad_start",jgrad_start(i),
 570      &                  " jgrad_end  ",jgrad_end(i),
 571      &                  i=igrad_start,igrad_end)
 572 #endif
 573 c
 574 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 575 c do not parallelize this part.
 576 c
 577 c      do i=igrad_start,igrad_end
 578 c        do j=jgrad_start(i),jgrad_end(i)
 579 c          do k=1,3
 580 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 581 c          enddo
 582 c        enddo
 583 c      enddo
 584       do j=1,3
 585         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 586       enddo
 587       do i=nres-2,nnt,-1
 588         do j=1,3
 589           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 590         enddo
 591       enddo
 592 #ifdef DEBUG
 593       write (iout,*) "gradbufc after summing"
 594       do i=1,nres
 595         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 596       enddo
 597       call flush(iout)
 598 #endif
 599       else
 600 #endif
 601 #ifdef DEBUG
 602       write (iout,*) "gradbufc"
 603       do i=1,nres
 604         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 605       enddo
 606       call flush(iout)
 607 #endif
 608       do i=1,nres
 609         do j=1,3
 610           gradbufc_sum(j,i)=gradbufc(j,i)
 611           gradbufc(j,i)=0.0d0
 612         enddo
 613       enddo
 614       do j=1,3
 615         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 616       enddo
 617       do i=nres-2,nnt,-1
 618         do j=1,3
 619           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 620         enddo
 621       enddo
 622 c      do i=nnt,nres-1
 623 c        do k=1,3
 624 c          gradbufc(k,i)=0.0d0
 625 c        enddo
 626 c        do j=i+1,nres
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632 #ifdef DEBUG
 633       write (iout,*) "gradbufc after summing"
 634       do i=1,nres
 635         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 636       enddo
 637       call flush(iout)
 638 #endif
 639 #ifdef MPI
 640       endif
 641 #endif
 642       do k=1,3
 643         gradbufc(k,nres)=0.0d0
 644       enddo
 645       do i=1,nct
 646         do j=1,3
 647 #ifdef SPLITELE
 648           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 649      &                wel_loc*gel_loc(j,i)+
 650      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 651      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 652      &                wel_loc*gel_loc_long(j,i)+
 653      &                wcorr*gradcorr_long(j,i)+
 654      &                wcorr5*gradcorr5_long(j,i)+
 655      &                wcorr6*gradcorr6_long(j,i)+
 656      &                wturn6*gcorr6_turn_long(j,i))+
 657      &                wbond*gradb(j,i)+
 658      &                wcorr*gradcorr(j,i)+
 659      &                wturn3*gcorr3_turn(j,i)+
 660      &                wturn4*gcorr4_turn(j,i)+
 661      &                wcorr5*gradcorr5(j,i)+
 662      &                wcorr6*gradcorr6(j,i)+
 663      &                wturn6*gcorr6_turn(j,i)+
 664      &                wsccor*gsccorc(j,i)
 665      &               +wscloc*gscloc(j,i)
 666 #else
 667           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 668      &                wel_loc*gel_loc(j,i)+
 669      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 670      &                welec*gelc_long(j,i)
 671      &                wel_loc*gel_loc_long(j,i)+
 672      &                wcorr*gcorr_long(j,i)+
 673      &                wcorr5*gradcorr5_long(j,i)+
 674      &                wcorr6*gradcorr6_long(j,i)+
 675      &                wturn6*gcorr6_turn_long(j,i))+
 676      &                wbond*gradb(j,i)+
 677      &                wcorr*gradcorr(j,i)+
 678      &                wturn3*gcorr3_turn(j,i)+
 679      &                wturn4*gcorr4_turn(j,i)+
 680      &                wcorr5*gradcorr5(j,i)+
 681      &                wcorr6*gradcorr6(j,i)+
 682      &                wturn6*gcorr6_turn(j,i)+
 683      &                wsccor*gsccorc(j,i)
 684      &               +wscloc*gscloc(j,i)
 685 #endif
 686           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 687      &                  wbond*gradbx(j,i)+
 688      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 689      &                  wsccor*gsccorx(j,i)
 690      &                 +wscloc*gsclocx(j,i)
 691         enddo
 692       enddo
 693 #ifdef DEBUG
 694       write (iout,*) "gloc before adding corr"
 695       do i=1,4*nres
 696         write (iout,*) i,gloc(i,icg)
 697       enddo
 698 #endif
 699       do i=1,nres-3
 700         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 701      &   +wcorr5*g_corr5_loc(i)
 702      &   +wcorr6*g_corr6_loc(i)
 703      &   +wturn4*gel_loc_turn4(i)
 704      &   +wturn3*gel_loc_turn3(i)
 705      &   +wturn6*gel_loc_turn6(i)
 706      &   +wel_loc*gel_loc_loc(i)
 707       enddo
 708 #ifdef DEBUG
 709       write (iout,*) "gloc after adding corr"
 710       do i=1,4*nres
 711         write (iout,*) i,gloc(i,icg)
 712       enddo
 713 #endif
 714 #ifdef MPI
 715       if (nfgtasks.gt.1) then
 716         do j=1,3
 717           do i=1,nres
 718             gradbufc(j,i)=gradc(j,i,icg)
 719             gradbufx(j,i)=gradx(j,i,icg)
 720           enddo
 721         enddo
 722         do i=1,4*nres
 723           glocbuf(i)=gloc(i,icg)
 724         enddo
 725 c#define DEBUG
 726 #ifdef DEBUG
 727       write (iout,*) "gloc_sc before reduce"
 728       do i=1,nres
 729        do j=1,1
 730         write (iout,*) i,j,gloc_sc(j,i,icg)
 731        enddo
 732       enddo
 733 #endif
 734 c#undef DEBUG
 735         do i=1,nres
 736          do j=1,3
 737           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 738          enddo
 739         enddo
 740         time00=MPI_Wtime()
 741         call MPI_Barrier(FG_COMM,IERR)
 742         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 743         time00=MPI_Wtime()
 744         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 749      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 750         time_reduce=time_reduce+MPI_Wtime()-time00
 751         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 752      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 753         time_reduce=time_reduce+MPI_Wtime()-time00
 754 c#define DEBUG
 755 #ifdef DEBUG
 756       write (iout,*) "gloc_sc after reduce"
 757       do i=1,nres
 758        do j=1,1
 759         write (iout,*) i,j,gloc_sc(j,i,icg)
 760        enddo
 761       enddo
 762 #endif
 763 c#undef DEBUG
 764 #ifdef DEBUG
 765       write (iout,*) "gloc after reduce"
 766       do i=1,4*nres
 767         write (iout,*) i,gloc(i,icg)
 768       enddo
 769 #endif
 770       endif
 771 #endif
 772       if (gnorm_check) then
 773 c
 774 c Compute the maximum elements of the gradient
 775 c
 776       gvdwc_max=0.0d0
 777       gvdwc_scp_max=0.0d0
 778       gelc_max=0.0d0
 779       gvdwpp_max=0.0d0
 780       gradb_max=0.0d0
 781       ghpbc_max=0.0d0
 782       gradcorr_max=0.0d0
 783       gel_loc_max=0.0d0
 784       gcorr3_turn_max=0.0d0
 785       gcorr4_turn_max=0.0d0
 786       gradcorr5_max=0.0d0
 787       gradcorr6_max=0.0d0
 788       gcorr6_turn_max=0.0d0
 789       gsccorc_max=0.0d0
 790       gscloc_max=0.0d0
 791       gvdwx_max=0.0d0
 792       gradx_scp_max=0.0d0
 793       ghpbx_max=0.0d0
 794       gradxorr_max=0.0d0
 795       gsccorx_max=0.0d0
 796       gsclocx_max=0.0d0
 797       do i=1,nct
 798         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 799         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 800         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 801         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 802      &   gvdwc_scp_max=gvdwc_scp_norm
 803         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 804         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 805         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 806         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 807         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 808         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 809         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 810         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 811         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 812         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 813         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 814         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 815         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 816      &    gcorr3_turn(1,i)))
 817         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 818      &    gcorr3_turn_max=gcorr3_turn_norm
 819         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 820      &    gcorr4_turn(1,i)))
 821         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 822      &    gcorr4_turn_max=gcorr4_turn_norm
 823         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 824         if (gradcorr5_norm.gt.gradcorr5_max)
 825      &    gradcorr5_max=gradcorr5_norm
 826         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 827         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 828         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 829      &    gcorr6_turn(1,i)))
 830         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 831      &    gcorr6_turn_max=gcorr6_turn_norm
 832         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 833         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 834         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 835         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 836         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 837         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 838         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 839         if (gradx_scp_norm.gt.gradx_scp_max)
 840      &    gradx_scp_max=gradx_scp_norm
 841         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 842         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 843         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 844         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 845         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 846         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 847         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 848         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 849       enddo
 850       if (gradout) then
 851 #ifdef AIX
 852         open(istat,file=statname,position="append")
 853 #else
 854         open(istat,file=statname,access="append")
 855 #endif
 856         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 857      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 858      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 859      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 860      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 861      &     gsccorx_max,gsclocx_max
 862         close(istat)
 863         if (gvdwc_max.gt.1.0d4) then
 864           write (iout,*) "gvdwc gvdwx gradb gradbx"
 865           do i=nnt,nct
 866             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 867      &        gradb(j,i),gradbx(j,i),j=1,3)
 868           enddo
 869           call pdbout(0.0d0,'cipiszcze',iout)
 870           call flush(iout)
 871         endif
 872       endif
 873       endif
 874 #ifdef DEBUG
 875       write (iout,*) "gradc gradx gloc"
 876       do i=1,nres
 877         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 878      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 879       enddo
 880 #endif
 881 #ifdef TIMING
 882       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 883 #endif
 884       return
 885       end
 886 c-------------------------------------------------------------------------------
 887       subroutine rescale_weights(t_bath)
 888       implicit real*8 (a-h,o-z)
 889       include 'DIMENSIONS'
 890       include 'COMMON.IOUNITS'
 891       include 'COMMON.FFIELD'
 892       include 'COMMON.SBRIDGE'
 893       double precision kfac /2.4d0/
 894       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 895 c      facT=temp0/t_bath
 896 c      facT=2*temp0/(t_bath+temp0)
 897       if (rescale_mode.eq.0) then
 898         facT=1.0d0
 899         facT2=1.0d0
 900         facT3=1.0d0
 901         facT4=1.0d0
 902         facT5=1.0d0
 903       else if (rescale_mode.eq.1) then
 904         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 905         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 906         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 907         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 908         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 909       else if (rescale_mode.eq.2) then
 910         x=t_bath/temp0
 911         x2=x*x
 912         x3=x2*x
 913         x4=x3*x
 914         x5=x4*x
 915         facT=licznik/dlog(dexp(x)+dexp(-x))
 916         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 917         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 918         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 919         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 920       else
 921         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 922         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 923 #ifdef MPI
 924        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 925 #endif
 926        stop 555
 927       endif
 928       welec=weights(3)*fact
 929       wcorr=weights(4)*fact3
 930       wcorr5=weights(5)*fact4
 931       wcorr6=weights(6)*fact5
 932       wel_loc=weights(7)*fact2
 933       wturn3=weights(8)*fact2
 934       wturn4=weights(9)*fact3
 935       wturn6=weights(10)*fact5
 936       wtor=weights(13)*fact
 937       wtor_d=weights(14)*fact2
 938       wsccor=weights(21)*fact
 939
 940       return
 941       end
 942 C------------------------------------------------------------------------
 943       subroutine enerprint(energia)
 944       implicit real*8 (a-h,o-z)
 945       include 'DIMENSIONS'
 946       include 'COMMON.IOUNITS'
 947       include 'COMMON.FFIELD'
 948       include 'COMMON.SBRIDGE'
 949       include 'COMMON.MD'
 950       double precision energia(0:n_ene)
 951       etot=energia(0)
 952       evdw=energia(1)
 953       evdw2=energia(2)
 954 #ifdef SCP14
 955       evdw2=energia(2)+energia(18)
 956 #else
 957       evdw2=energia(2)
 958 #endif
 959       ees=energia(3)
 960 #ifdef SPLITELE
 961       evdw1=energia(16)
 962 #endif
 963       ecorr=energia(4)
 964       ecorr5=energia(5)
 965       ecorr6=energia(6)
 966       eel_loc=energia(7)
 967       eello_turn3=energia(8)
 968       eello_turn4=energia(9)
 969       eello_turn6=energia(10)
 970       ebe=energia(11)
 971       escloc=energia(12)
 972       etors=energia(13)
 973       etors_d=energia(14)
 974       ehpb=energia(15)
 975       edihcnstr=energia(19)
 976       estr=energia(17)
 977       Uconst=energia(20)
 978       esccor=energia(21)
 979       ethetacnstr=energia(24)
 980 #ifdef SPLITELE
 981       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 982      &  estr,wbond,ebe,wang,
 983      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 984      &  ecorr,wcorr,
 985      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 986      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 987      &  edihcnstr,
 988      &  ethetacnstr,ebr*nss,
 989      &  Uconst,etot
 990    10 format (/'Virtual-chain energies:'//
 991      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 992      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 993      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 994      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 995      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 996      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 997      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 998      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 999      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1000      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1001      & ' (SS bridges & dist. cnstr.)'/
1002      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1003      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1004      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1005      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1006      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1007      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1008      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1009      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1010      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1011      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1012      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1013      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1014      & 'ETOT=  ',1pE16.6,' (total)')
1015 #else
1016       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1017      &  estr,wbond,ebe,wang,
1018      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1019      &  ecorr,wcorr,
1020      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1021      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1022      &  ethetacnstr,
1023      &  ebr*nss,Uconst,etot
1024    10 format (/'Virtual-chain energies:'//
1025      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1026      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1027      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1028      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1029      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1030      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1031      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1032      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1033      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1034      & ' (SS bridges & dist. cnstr.)'/
1035      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1036      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1037      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1038      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1039      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1040      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1041      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1042      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1043      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1044      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1045      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1046      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1047      & 'ETOT=  ',1pE16.6,' (total)')
1048 #endif
1049       return
1050       end
1051 C-----------------------------------------------------------------------
1052       subroutine elj(evdw)
1053 C
1054 C This subroutine calculates the interaction energy of nonbonded side chains
1055 C assuming the LJ potential of interaction.
1056 C
1057       implicit real*8 (a-h,o-z)
1058       include 'DIMENSIONS'
1059       parameter (accur=1.0d-10)
1060       include 'COMMON.GEO'
1061       include 'COMMON.VAR'
1062       include 'COMMON.LOCAL'
1063       include 'COMMON.CHAIN'
1064       include 'COMMON.DERIV'
1065       include 'COMMON.INTERACT'
1066       include 'COMMON.TORSION'
1067       include 'COMMON.SBRIDGE'
1068       include 'COMMON.NAMES'
1069       include 'COMMON.IOUNITS'
1070       include 'COMMON.CONTACTS'
1071       dimension gg(3)
1072 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1073       evdw=0.0D0
1074       do i=iatsc_s,iatsc_e
1075         itypi=iabs(itype(i))
1076         if (itypi.eq.ntyp1) cycle
1077         itypi1=iabs(itype(i+1))
1078         xi=c(1,nres+i)
1079         yi=c(2,nres+i)
1080         zi=c(3,nres+i)
1081 C Change 12/1/95
1082         num_conti=0
1083 C
1084 C Calculate SC interaction energy.
1085 C
1086         do iint=1,nint_gr(i)
1087 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1088 cd   &                  'iend=',iend(i,iint)
1089           do j=istart(i,iint),iend(i,iint)
1090             itypj=iabs(itype(j))
1091             if (itypj.eq.ntyp1) cycle
1092             xj=c(1,nres+j)-xi
1093             yj=c(2,nres+j)-yi
1094             zj=c(3,nres+j)-zi
1095 C Change 12/1/95 to calculate four-body interactions
1096             rij=xj*xj+yj*yj+zj*zj
1097             rrij=1.0D0/rij
1098 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1099             eps0ij=eps(itypi,itypj)
1100             fac=rrij**expon2
1101             e1=fac*fac*aa(itypi,itypj)
1102             e2=fac*bb(itypi,itypj)
1103             evdwij=e1+e2
1104 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1105 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1106 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1107 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1108 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1109 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1110             evdw=evdw+evdwij
1111 C
1112 C Calculate the components of the gradient in DC and X
1113 C
1114             fac=-rrij*(e1+evdwij)
1115             gg(1)=xj*fac
1116             gg(2)=yj*fac
1117             gg(3)=zj*fac
1118             do k=1,3
1119               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1120               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1121               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1122               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1123             enddo
1124 cgrad            do k=i,j-1
1125 cgrad              do l=1,3
1126 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1127 cgrad              enddo
1128 cgrad            enddo
1129 C
1130 C 12/1/95, revised on 5/20/97
1131 C
1132 C Calculate the contact function. The ith column of the array JCONT will
1133 C contain the numbers of atoms that make contacts with the atom I (of numbers
1134 C greater than I). The arrays FACONT and GACONT will contain the values of
1135 C the contact function and its derivative.
1136 C
1137 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1138 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1139 C Uncomment next line, if the correlation interactions are contact function only
1140             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1141               rij=dsqrt(rij)
1142               sigij=sigma(itypi,itypj)
1143               r0ij=rs0(itypi,itypj)
1144 C
1145 C Check whether the SC's are not too far to make a contact.
1146 C
1147               rcut=1.5d0*r0ij
1148               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1149 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1150 C
1151               if (fcont.gt.0.0D0) then
1152 C If the SC-SC distance if close to sigma, apply spline.
1153 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1154 cAdam &             fcont1,fprimcont1)
1155 cAdam           fcont1=1.0d0-fcont1
1156 cAdam           if (fcont1.gt.0.0d0) then
1157 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1158 cAdam             fcont=fcont*fcont1
1159 cAdam           endif
1160 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1161 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1162 cga             do k=1,3
1163 cga               gg(k)=gg(k)*eps0ij
1164 cga             enddo
1165 cga             eps0ij=-evdwij*eps0ij
1166 C Uncomment for AL's type of SC correlation interactions.
1167 cadam           eps0ij=-evdwij
1168                 num_conti=num_conti+1
1169                 jcont(num_conti,i)=j
1170                 facont(num_conti,i)=fcont*eps0ij
1171                 fprimcont=eps0ij*fprimcont/rij
1172                 fcont=expon*fcont
1173 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1174 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1175 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1176 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1177                 gacont(1,num_conti,i)=-fprimcont*xj
1178                 gacont(2,num_conti,i)=-fprimcont*yj
1179                 gacont(3,num_conti,i)=-fprimcont*zj
1180 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1181 cd              write (iout,'(2i3,3f10.5)')
1182 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1183               endif
1184             endif
1185           enddo      ! j
1186         enddo        ! iint
1187 C Change 12/1/95
1188         num_cont(i)=num_conti
1189       enddo          ! i
1190       do i=1,nct
1191         do j=1,3
1192           gvdwc(j,i)=expon*gvdwc(j,i)
1193           gvdwx(j,i)=expon*gvdwx(j,i)
1194         enddo
1195       enddo
1196 C******************************************************************************
1197 C
1198 C                              N O T E !!!
1199 C
1200 C To save time, the factor of EXPON has been extracted from ALL components
1201 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1202 C use!
1203 C
1204 C******************************************************************************
1205       return
1206       end
1207 C-----------------------------------------------------------------------------
1208       subroutine eljk(evdw)
1209 C
1210 C This subroutine calculates the interaction energy of nonbonded side chains
1211 C assuming the LJK potential of interaction.
1212 C
1213       implicit real*8 (a-h,o-z)
1214       include 'DIMENSIONS'
1215       include 'COMMON.GEO'
1216       include 'COMMON.VAR'
1217       include 'COMMON.LOCAL'
1218       include 'COMMON.CHAIN'
1219       include 'COMMON.DERIV'
1220       include 'COMMON.INTERACT'
1221       include 'COMMON.IOUNITS'
1222       include 'COMMON.NAMES'
1223       dimension gg(3)
1224       logical scheck
1225 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1226       evdw=0.0D0
1227       do i=iatsc_s,iatsc_e
1228         itypi=iabs(itype(i))
1229         if (itypi.eq.ntyp1) cycle
1230         itypi1=iabs(itype(i+1))
1231         xi=c(1,nres+i)
1232         yi=c(2,nres+i)
1233         zi=c(3,nres+i)
1234 C
1235 C Calculate SC interaction energy.
1236 C
1237         do iint=1,nint_gr(i)
1238           do j=istart(i,iint),iend(i,iint)
1239             itypj=iabs(itype(j))
1240             if (itypj.eq.ntyp1) cycle
1241             xj=c(1,nres+j)-xi
1242             yj=c(2,nres+j)-yi
1243             zj=c(3,nres+j)-zi
1244             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1245             fac_augm=rrij**expon
1246             e_augm=augm(itypi,itypj)*fac_augm
1247             r_inv_ij=dsqrt(rrij)
1248             rij=1.0D0/r_inv_ij
1249             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1250             fac=r_shift_inv**expon
1251             e1=fac*fac*aa(itypi,itypj)
1252             e2=fac*bb(itypi,itypj)
1253             evdwij=e_augm+e1+e2
1254 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1255 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1256 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1257 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1258 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1259 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1260 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1261             evdw=evdw+evdwij
1262 C
1263 C Calculate the components of the gradient in DC and X
1264 C
1265             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1266             gg(1)=xj*fac
1267             gg(2)=yj*fac
1268             gg(3)=zj*fac
1269             do k=1,3
1270               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1271               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1272               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1273               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1274             enddo
1275 cgrad            do k=i,j-1
1276 cgrad              do l=1,3
1277 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1278 cgrad              enddo
1279 cgrad            enddo
1280           enddo      ! j
1281         enddo        ! iint
1282       enddo          ! i
1283       do i=1,nct
1284         do j=1,3
1285           gvdwc(j,i)=expon*gvdwc(j,i)
1286           gvdwx(j,i)=expon*gvdwx(j,i)
1287         enddo
1288       enddo
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine ebp(evdw)
1293 C
1294 C This subroutine calculates the interaction energy of nonbonded side chains
1295 C assuming the Berne-Pechukas potential of interaction.
1296 C
1297       implicit real*8 (a-h,o-z)
1298       include 'DIMENSIONS'
1299       include 'COMMON.GEO'
1300       include 'COMMON.VAR'
1301       include 'COMMON.LOCAL'
1302       include 'COMMON.CHAIN'
1303       include 'COMMON.DERIV'
1304       include 'COMMON.NAMES'
1305       include 'COMMON.INTERACT'
1306       include 'COMMON.IOUNITS'
1307       include 'COMMON.CALC'
1308       common /srutu/ icall
1309 c     double precision rrsave(maxdim)
1310       logical lprn
1311       evdw=0.0D0
1312 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1313       evdw=0.0D0
1314 c     if (icall.eq.0) then
1315 c       lprn=.true.
1316 c     else
1317         lprn=.false.
1318 c     endif
1319       ind=0
1320       do i=iatsc_s,iatsc_e
1321         itypi=iabs(itype(i))
1322         if (itypi.eq.ntyp1) cycle
1323         itypi1=iabs(itype(i+1))
1324         xi=c(1,nres+i)
1325         yi=c(2,nres+i)
1326         zi=c(3,nres+i)
1327         dxi=dc_norm(1,nres+i)
1328         dyi=dc_norm(2,nres+i)
1329         dzi=dc_norm(3,nres+i)
1330 c        dsci_inv=dsc_inv(itypi)
1331         dsci_inv=vbld_inv(i+nres)
1332 C
1333 C Calculate SC interaction energy.
1334 C
1335         do iint=1,nint_gr(i)
1336           do j=istart(i,iint),iend(i,iint)
1337             ind=ind+1
1338             itypj=iabs(itype(j))
1339             if (itypj.eq.ntyp1) cycle
1340 c            dscj_inv=dsc_inv(itypj)
1341             dscj_inv=vbld_inv(j+nres)
1342             chi1=chi(itypi,itypj)
1343             chi2=chi(itypj,itypi)
1344             chi12=chi1*chi2
1345             chip1=chip(itypi)
1346             chip2=chip(itypj)
1347             chip12=chip1*chip2
1348             alf1=alp(itypi)
1349             alf2=alp(itypj)
1350             alf12=0.5D0*(alf1+alf2)
1351 C For diagnostics only!!!
1352 c           chi1=0.0D0
1353 c           chi2=0.0D0
1354 c           chi12=0.0D0
1355 c           chip1=0.0D0
1356 c           chip2=0.0D0
1357 c           chip12=0.0D0
1358 c           alf1=0.0D0
1359 c           alf2=0.0D0
1360 c           alf12=0.0D0
1361             xj=c(1,nres+j)-xi
1362             yj=c(2,nres+j)-yi
1363             zj=c(3,nres+j)-zi
1364             dxj=dc_norm(1,nres+j)
1365             dyj=dc_norm(2,nres+j)
1366             dzj=dc_norm(3,nres+j)
1367             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1368 cd          if (icall.eq.0) then
1369 cd            rrsave(ind)=rrij
1370 cd          else
1371 cd            rrij=rrsave(ind)
1372 cd          endif
1373             rij=dsqrt(rrij)
1374 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1375             call sc_angular
1376 C Calculate whole angle-dependent part of epsilon and contributions
1377 C to its derivatives
1378             fac=(rrij*sigsq)**expon2
1379             e1=fac*fac*aa(itypi,itypj)
1380             e2=fac*bb(itypi,itypj)
1381             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1382             eps2der=evdwij*eps3rt
1383             eps3der=evdwij*eps2rt
1384             evdwij=evdwij*eps2rt*eps3rt
1385             evdw=evdw+evdwij
1386             if (lprn) then
1387             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1388             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1389 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1390 cd     &        restyp(itypi),i,restyp(itypj),j,
1391 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1392 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1393 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1394 cd     &        evdwij
1395             endif
1396 C Calculate gradient components.
1397             e1=e1*eps1*eps2rt**2*eps3rt**2
1398             fac=-expon*(e1+evdwij)
1399             sigder=fac/sigsq
1400             fac=rrij*fac
1401 C Calculate radial part of the gradient
1402             gg(1)=xj*fac
1403             gg(2)=yj*fac
1404             gg(3)=zj*fac
1405 C Calculate the angular part of the gradient and sum add the contributions
1406 C to the appropriate components of the Cartesian gradient.
1407             call sc_grad
1408           enddo      ! j
1409         enddo        ! iint
1410       enddo          ! i
1411 c     stop
1412       return
1413       end
1414 C-----------------------------------------------------------------------------
1415       subroutine egb(evdw)
1416 C
1417 C This subroutine calculates the interaction energy of nonbonded side chains
1418 C assuming the Gay-Berne potential of interaction.
1419 C
1420       implicit real*8 (a-h,o-z)
1421       include 'DIMENSIONS'
1422       include 'COMMON.GEO'
1423       include 'COMMON.VAR'
1424       include 'COMMON.LOCAL'
1425       include 'COMMON.CHAIN'
1426       include 'COMMON.DERIV'
1427       include 'COMMON.NAMES'
1428       include 'COMMON.INTERACT'
1429       include 'COMMON.IOUNITS'
1430       include 'COMMON.CALC'
1431       include 'COMMON.CONTROL'
1432       include 'COMMON.SBRIDGE'
1433       logical lprn
1434
1435 c      write(iout,*) "Jestem w egb(evdw)"
1436
1437       evdw=0.0D0
1438 ccccc      energy_dec=.false.
1439 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1440       evdw=0.0D0
1441       lprn=.false.
1442 c     if (icall.eq.0) lprn=.false.
1443       ind=0
1444       do i=iatsc_s,iatsc_e
1445         itypi=iabs(itype(i))
1446         if (itypi.eq.ntyp1) cycle
1447         itypi1=iabs(itype(i+1))
1448         xi=c(1,nres+i)
1449         yi=c(2,nres+i)
1450         zi=c(3,nres+i)
1451         dxi=dc_norm(1,nres+i)
1452         dyi=dc_norm(2,nres+i)
1453         dzi=dc_norm(3,nres+i)
1454 c        dsci_inv=dsc_inv(itypi)
1455         dsci_inv=vbld_inv(i+nres)
1456 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1457 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1458 C
1459 C Calculate SC interaction energy.
1460 C
1461         do iint=1,nint_gr(i)
1462           do j=istart(i,iint),iend(i,iint)
1463             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1464
1465 c              write(iout,*) "PRZED ZWYKLE", evdwij
1466               call dyn_ssbond_ene(i,j,evdwij)
1467 c              write(iout,*) "PO ZWYKLE", evdwij
1468
1469               evdw=evdw+evdwij
1470               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1471      &                        'evdw',i,j,evdwij,' ss'
1472 C triple bond artifac removal
1473              do k=j+1,iend(i,iint)
1474 C search over all next residues
1475               if (dyn_ss_mask(k)) then
1476 C check if they are cysteins
1477 C              write(iout,*) 'k=',k
1478
1479 c              write(iout,*) "PRZED TRI", evdwij
1480                evdwij_przed_tri=evdwij
1481               call triple_ssbond_ene(i,j,k,evdwij)
1482 c               if(evdwij_przed_tri.ne.evdwij) then
1483 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1484 c               endif
1485
1486 c              write(iout,*) "PO TRI", evdwij
1487 C call the energy function that removes the artifical triple disulfide
1488 C bond the soubroutine is located in ssMD.F
1489               evdw=evdw+evdwij
1490               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1491      &                        'evdw',i,j,evdwij,'tss'
1492               endif!dyn_ss_mask(k)
1493              enddo! k
1494             ELSE
1495             ind=ind+1
1496             itypj=iabs(itype(j))
1497             if (itypj.eq.ntyp1) cycle
1498 c            dscj_inv=dsc_inv(itypj)
1499             dscj_inv=vbld_inv(j+nres)
1500 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1501 c     &       1.0d0/vbld(j+nres)
1502 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1503             sig0ij=sigma(itypi,itypj)
1504             chi1=chi(itypi,itypj)
1505             chi2=chi(itypj,itypi)
1506             chi12=chi1*chi2
1507             chip1=chip(itypi)
1508             chip2=chip(itypj)
1509             chip12=chip1*chip2
1510             alf1=alp(itypi)
1511             alf2=alp(itypj)
1512             alf12=0.5D0*(alf1+alf2)
1513 C For diagnostics only!!!
1514 c           chi1=0.0D0
1515 c           chi2=0.0D0
1516 c           chi12=0.0D0
1517 c           chip1=0.0D0
1518 c           chip2=0.0D0
1519 c           chip12=0.0D0
1520 c           alf1=0.0D0
1521 c           alf2=0.0D0
1522 c           alf12=0.0D0
1523             xj=c(1,nres+j)-xi
1524             yj=c(2,nres+j)-yi
1525             zj=c(3,nres+j)-zi
1526             dxj=dc_norm(1,nres+j)
1527             dyj=dc_norm(2,nres+j)
1528             dzj=dc_norm(3,nres+j)
1529 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1530 c            write (iout,*) "j",j," dc_norm",
1531 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1532             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1533             rij=dsqrt(rrij)
1534 C Calculate angle-dependent terms of energy and contributions to their
1535 C derivatives.
1536             call sc_angular
1537             sigsq=1.0D0/sigsq
1538             sig=sig0ij*dsqrt(sigsq)
1539             rij_shift=1.0D0/rij-sig+sig0ij
1540 c for diagnostics; uncomment
1541 c            rij_shift=1.2*sig0ij
1542 C I hate to put IF's in the loops, but here don't have another choice!!!!
1543             if (rij_shift.le.0.0D0) then
1544               evdw=1.0D20
1545 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1546 cd     &        restyp(itypi),i,restyp(itypj),j,
1547 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1548               return
1549             endif
1550             sigder=-sig*sigsq
1551 c---------------------------------------------------------------
1552             rij_shift=1.0D0/rij_shift
1553             fac=rij_shift**expon
1554             e1=fac*fac*aa(itypi,itypj)
1555             e2=fac*bb(itypi,itypj)
1556             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1557             eps2der=evdwij*eps3rt
1558             eps3der=evdwij*eps2rt
1559 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1560 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1561             evdwij=evdwij*eps2rt*eps3rt
1562             evdw=evdw+evdwij
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             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1567      &        restyp(itypi),i,restyp(itypj),j,
1568      &        epsi,sigm,chi1,chi2,chip1,chip2,
1569      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1570      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1571      &        evdwij
1572             endif
1573
1574             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1575      &                        'evdw',i,j,evdwij
1576
1577 C Calculate gradient components.
1578             e1=e1*eps1*eps2rt**2*eps3rt**2
1579             fac=-expon*(e1+evdwij)*rij_shift
1580             sigder=fac*sigder
1581             fac=rij*fac
1582 c            fac=0.0d0
1583 C Calculate the radial part of the gradient
1584             gg(1)=xj*fac
1585             gg(2)=yj*fac
1586             gg(3)=zj*fac
1587 C Calculate angular part of the gradient.
1588             call sc_grad
1589             ENDIF    ! dyn_ss
1590           enddo      ! j
1591         enddo        ! iint
1592       enddo          ! i
1593 c      write (iout,*) "Number of loop steps in EGB:",ind
1594 cccc      energy_dec=.false.
1595       return
1596       end
1597 C-----------------------------------------------------------------------------
1598       subroutine egbv(evdw)
1599 C
1600 C This subroutine calculates the interaction energy of nonbonded side chains
1601 C assuming the Gay-Berne-Vorobjev potential of interaction.
1602 C
1603       implicit real*8 (a-h,o-z)
1604       include 'DIMENSIONS'
1605       include 'COMMON.GEO'
1606       include 'COMMON.VAR'
1607       include 'COMMON.LOCAL'
1608       include 'COMMON.CHAIN'
1609       include 'COMMON.DERIV'
1610       include 'COMMON.NAMES'
1611       include 'COMMON.INTERACT'
1612       include 'COMMON.IOUNITS'
1613       include 'COMMON.CALC'
1614       common /srutu/ icall
1615       logical lprn
1616       evdw=0.0D0
1617 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1618       evdw=0.0D0
1619       lprn=.false.
1620 c     if (icall.eq.0) lprn=.true.
1621       ind=0
1622       do i=iatsc_s,iatsc_e
1623         itypi=iabs(itype(i))
1624         if (itypi.eq.ntyp1) cycle
1625         itypi1=iabs(itype(i+1))
1626         xi=c(1,nres+i)
1627         yi=c(2,nres+i)
1628         zi=c(3,nres+i)
1629         dxi=dc_norm(1,nres+i)
1630         dyi=dc_norm(2,nres+i)
1631         dzi=dc_norm(3,nres+i)
1632 c        dsci_inv=dsc_inv(itypi)
1633         dsci_inv=vbld_inv(i+nres)
1634 C
1635 C Calculate SC interaction energy.
1636 C
1637         do iint=1,nint_gr(i)
1638           do j=istart(i,iint),iend(i,iint)
1639             ind=ind+1
1640             itypj=iabs(itype(j))
1641             if (itypj.eq.ntyp1) cycle
1642 c            dscj_inv=dsc_inv(itypj)
1643             dscj_inv=vbld_inv(j+nres)
1644             sig0ij=sigma(itypi,itypj)
1645             r0ij=r0(itypi,itypj)
1646             chi1=chi(itypi,itypj)
1647             chi2=chi(itypj,itypi)
1648             chi12=chi1*chi2
1649             chip1=chip(itypi)
1650             chip2=chip(itypj)
1651             chip12=chip1*chip2
1652             alf1=alp(itypi)
1653             alf2=alp(itypj)
1654             alf12=0.5D0*(alf1+alf2)
1655 C For diagnostics only!!!
1656 c           chi1=0.0D0
1657 c           chi2=0.0D0
1658 c           chi12=0.0D0
1659 c           chip1=0.0D0
1660 c           chip2=0.0D0
1661 c           chip12=0.0D0
1662 c           alf1=0.0D0
1663 c           alf2=0.0D0
1664 c           alf12=0.0D0
1665             xj=c(1,nres+j)-xi
1666             yj=c(2,nres+j)-yi
1667             zj=c(3,nres+j)-zi
1668             dxj=dc_norm(1,nres+j)
1669             dyj=dc_norm(2,nres+j)
1670             dzj=dc_norm(3,nres+j)
1671             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1672             rij=dsqrt(rrij)
1673 C Calculate angle-dependent terms of energy and contributions to their
1674 C derivatives.
1675             call sc_angular
1676             sigsq=1.0D0/sigsq
1677             sig=sig0ij*dsqrt(sigsq)
1678             rij_shift=1.0D0/rij-sig+r0ij
1679 C I hate to put IF's in the loops, but here don't have another choice!!!!
1680             if (rij_shift.le.0.0D0) then
1681               evdw=1.0D20
1682               return
1683             endif
1684             sigder=-sig*sigsq
1685 c---------------------------------------------------------------
1686             rij_shift=1.0D0/rij_shift
1687             fac=rij_shift**expon
1688             e1=fac*fac*aa(itypi,itypj)
1689             e2=fac*bb(itypi,itypj)
1690             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1691             eps2der=evdwij*eps3rt
1692             eps3der=evdwij*eps2rt
1693             fac_augm=rrij**expon
1694             e_augm=augm(itypi,itypj)*fac_augm
1695             evdwij=evdwij*eps2rt*eps3rt
1696             evdw=evdw+evdwij+e_augm
1697             if (lprn) then
1698             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1699             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1700             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1701      &        restyp(itypi),i,restyp(itypj),j,
1702      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1703      &        chi1,chi2,chip1,chip2,
1704      &        eps1,eps2rt**2,eps3rt**2,
1705      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1706      &        evdwij+e_augm
1707             endif
1708 C Calculate gradient components.
1709             e1=e1*eps1*eps2rt**2*eps3rt**2
1710             fac=-expon*(e1+evdwij)*rij_shift
1711             sigder=fac*sigder
1712             fac=rij*fac-2*expon*rrij*e_augm
1713 C Calculate the radial part of the gradient
1714             gg(1)=xj*fac
1715             gg(2)=yj*fac
1716             gg(3)=zj*fac
1717 C Calculate angular part of the gradient.
1718             call sc_grad
1719           enddo      ! j
1720         enddo        ! iint
1721       enddo          ! i
1722       end
1723 C-----------------------------------------------------------------------------
1724       subroutine sc_angular
1725 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1726 C om12. Called by ebp, egb, and egbv.
1727       implicit none
1728       include 'COMMON.CALC'
1729       include 'COMMON.IOUNITS'
1730       erij(1)=xj*rij
1731       erij(2)=yj*rij
1732       erij(3)=zj*rij
1733       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1734       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1735       om12=dxi*dxj+dyi*dyj+dzi*dzj
1736       chiom12=chi12*om12
1737 C Calculate eps1(om12) and its derivative in om12
1738       faceps1=1.0D0-om12*chiom12
1739       faceps1_inv=1.0D0/faceps1
1740       eps1=dsqrt(faceps1_inv)
1741 C Following variable is eps1*deps1/dom12
1742       eps1_om12=faceps1_inv*chiom12
1743 c diagnostics only
1744 c      faceps1_inv=om12
1745 c      eps1=om12
1746 c      eps1_om12=1.0d0
1747 c      write (iout,*) "om12",om12," eps1",eps1
1748 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1749 C and om12.
1750       om1om2=om1*om2
1751       chiom1=chi1*om1
1752       chiom2=chi2*om2
1753       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1754       sigsq=1.0D0-facsig*faceps1_inv
1755       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1756       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1757       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1758 c diagnostics only
1759 c      sigsq=1.0d0
1760 c      sigsq_om1=0.0d0
1761 c      sigsq_om2=0.0d0
1762 c      sigsq_om12=0.0d0
1763 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1764 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1765 c     &    " eps1",eps1
1766 C Calculate eps2 and its derivatives in om1, om2, and om12.
1767       chipom1=chip1*om1
1768       chipom2=chip2*om2
1769       chipom12=chip12*om12
1770       facp=1.0D0-om12*chipom12
1771       facp_inv=1.0D0/facp
1772       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1773 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1774 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1775 C Following variable is the square root of eps2
1776       eps2rt=1.0D0-facp1*facp_inv
1777 C Following three variables are the derivatives of the square root of eps
1778 C in om1, om2, and om12.
1779       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1780       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1781       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1782 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1783       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1784 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1785 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1786 c     &  " eps2rt_om12",eps2rt_om12
1787 C Calculate whole angle-dependent part of epsilon and contributions
1788 C to its derivatives
1789       return
1790       end
1791 C----------------------------------------------------------------------------
1792       subroutine sc_grad
1793       implicit real*8 (a-h,o-z)
1794       include 'DIMENSIONS'
1795       include 'COMMON.CHAIN'
1796       include 'COMMON.DERIV'
1797       include 'COMMON.CALC'
1798       include 'COMMON.IOUNITS'
1799       double precision dcosom1(3),dcosom2(3)
1800       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1801       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1802       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1803      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1804 c diagnostics only
1805 c      eom1=0.0d0
1806 c      eom2=0.0d0
1807 c      eom12=evdwij*eps1_om12
1808 c end diagnostics
1809 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1810 c     &  " sigder",sigder
1811 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1812 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1813       do k=1,3
1814         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1815         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1816       enddo
1817       do k=1,3
1818         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1819       enddo
1820 c      write (iout,*) "gg",(gg(k),k=1,3)
1821       do k=1,3
1822         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1823      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1824      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1825         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1826      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1827      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1828 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1829 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1830 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1831 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1832       enddo
1833 C
1834 C Calculate the components of the gradient in DC and X
1835 C
1836 cgrad      do k=i,j-1
1837 cgrad        do l=1,3
1838 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1839 cgrad        enddo
1840 cgrad      enddo
1841       do l=1,3
1842         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1843         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1844       enddo
1845       return
1846       end
1847 C-----------------------------------------------------------------------
1848       subroutine e_softsphere(evdw)
1849 C
1850 C This subroutine calculates the interaction energy of nonbonded side chains
1851 C assuming the LJ potential of interaction.
1852 C
1853       implicit real*8 (a-h,o-z)
1854       include 'DIMENSIONS'
1855       parameter (accur=1.0d-10)
1856       include 'COMMON.GEO'
1857       include 'COMMON.VAR'
1858       include 'COMMON.LOCAL'
1859       include 'COMMON.CHAIN'
1860       include 'COMMON.DERIV'
1861       include 'COMMON.INTERACT'
1862       include 'COMMON.TORSION'
1863       include 'COMMON.SBRIDGE'
1864       include 'COMMON.NAMES'
1865       include 'COMMON.IOUNITS'
1866       include 'COMMON.CONTACTS'
1867       dimension gg(3)
1868 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1869       evdw=0.0D0
1870       do i=iatsc_s,iatsc_e
1871         itypi=iabs(itype(i))
1872         if (itypi.eq.ntyp1) cycle
1873         itypi1=iabs(itype(i+1))
1874         xi=c(1,nres+i)
1875         yi=c(2,nres+i)
1876         zi=c(3,nres+i)
1877 C
1878 C Calculate SC interaction energy.
1879 C
1880         do iint=1,nint_gr(i)
1881 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1882 cd   &                  'iend=',iend(i,iint)
1883           do j=istart(i,iint),iend(i,iint)
1884             itypj=iabs(itype(j))
1885             if (itypj.eq.ntyp1) cycle
1886             xj=c(1,nres+j)-xi
1887             yj=c(2,nres+j)-yi
1888             zj=c(3,nres+j)-zi
1889             rij=xj*xj+yj*yj+zj*zj
1890 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1891             r0ij=r0(itypi,itypj)
1892             r0ijsq=r0ij*r0ij
1893 c            print *,i,j,r0ij,dsqrt(rij)
1894             if (rij.lt.r0ijsq) then
1895               evdwij=0.25d0*(rij-r0ijsq)**2
1896               fac=rij-r0ijsq
1897             else
1898               evdwij=0.0d0
1899               fac=0.0d0
1900             endif
1901             evdw=evdw+evdwij
1902 C
1903 C Calculate the components of the gradient in DC and X
1904 C
1905             gg(1)=xj*fac
1906             gg(2)=yj*fac
1907             gg(3)=zj*fac
1908             do k=1,3
1909               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1910               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1911               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1912               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1913             enddo
1914 cgrad            do k=i,j-1
1915 cgrad              do l=1,3
1916 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1917 cgrad              enddo
1918 cgrad            enddo
1919           enddo ! j
1920         enddo ! iint
1921       enddo ! i
1922       return
1923       end
1924 C--------------------------------------------------------------------------
1925       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1926      &              eello_turn4)
1927 C
1928 C Soft-sphere potential of p-p interaction
1929 C
1930       implicit real*8 (a-h,o-z)
1931       include 'DIMENSIONS'
1932       include 'COMMON.CONTROL'
1933       include 'COMMON.IOUNITS'
1934       include 'COMMON.GEO'
1935       include 'COMMON.VAR'
1936       include 'COMMON.LOCAL'
1937       include 'COMMON.CHAIN'
1938       include 'COMMON.DERIV'
1939       include 'COMMON.INTERACT'
1940       include 'COMMON.CONTACTS'
1941       include 'COMMON.TORSION'
1942       include 'COMMON.VECTORS'
1943       include 'COMMON.FFIELD'
1944       dimension ggg(3)
1945 cd      write(iout,*) 'In EELEC_soft_sphere'
1946       ees=0.0D0
1947       evdw1=0.0D0
1948       eel_loc=0.0d0
1949       eello_turn3=0.0d0
1950       eello_turn4=0.0d0
1951       ind=0
1952       do i=iatel_s,iatel_e
1953         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1954         dxi=dc(1,i)
1955         dyi=dc(2,i)
1956         dzi=dc(3,i)
1957         xmedi=c(1,i)+0.5d0*dxi
1958         ymedi=c(2,i)+0.5d0*dyi
1959         zmedi=c(3,i)+0.5d0*dzi
1960         num_conti=0
1961 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1962         do j=ielstart(i),ielend(i)
1963           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1964           ind=ind+1
1965           iteli=itel(i)
1966           itelj=itel(j)
1967           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1968           r0ij=rpp(iteli,itelj)
1969           r0ijsq=r0ij*r0ij
1970           dxj=dc(1,j)
1971           dyj=dc(2,j)
1972           dzj=dc(3,j)
1973           xj=c(1,j)+0.5D0*dxj-xmedi
1974           yj=c(2,j)+0.5D0*dyj-ymedi
1975           zj=c(3,j)+0.5D0*dzj-zmedi
1976           rij=xj*xj+yj*yj+zj*zj
1977           if (rij.lt.r0ijsq) then
1978             evdw1ij=0.25d0*(rij-r0ijsq)**2
1979             fac=rij-r0ijsq
1980           else
1981             evdw1ij=0.0d0
1982             fac=0.0d0
1983           endif
1984           evdw1=evdw1+evdw1ij
1985 C
1986 C Calculate contributions to the Cartesian gradient.
1987 C
1988           ggg(1)=fac*xj
1989           ggg(2)=fac*yj
1990           ggg(3)=fac*zj
1991           do k=1,3
1992             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1993             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1994           enddo
1995 *
1996 * Loop over residues i+1 thru j-1.
1997 *
1998 cgrad          do k=i+1,j-1
1999 cgrad            do l=1,3
2000 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2001 cgrad            enddo
2002 cgrad          enddo
2003         enddo ! j
2004       enddo   ! i
2005 cgrad      do i=nnt,nct-1
2006 cgrad        do k=1,3
2007 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2008 cgrad        enddo
2009 cgrad        do j=i+1,nct-1
2010 cgrad          do k=1,3
2011 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2012 cgrad          enddo
2013 cgrad        enddo
2014 cgrad      enddo
2015       return
2016       end
2017 c------------------------------------------------------------------------------
2018       subroutine vec_and_deriv
2019       implicit real*8 (a-h,o-z)
2020       include 'DIMENSIONS'
2021 #ifdef MPI
2022       include 'mpif.h'
2023 #endif
2024       include 'COMMON.IOUNITS'
2025       include 'COMMON.GEO'
2026       include 'COMMON.VAR'
2027       include 'COMMON.LOCAL'
2028       include 'COMMON.CHAIN'
2029       include 'COMMON.VECTORS'
2030       include 'COMMON.SETUP'
2031       include 'COMMON.TIME1'
2032       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2033 C Compute the local reference systems. For reference system (i), the
2034 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2035 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2036 #ifdef PARVEC
2037       do i=ivec_start,ivec_end
2038 #else
2039       do i=1,nres-1
2040 #endif
2041           if (i.eq.nres-1) then
2042 C Case of the last full residue
2043 C Compute the Z-axis
2044             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2045             costh=dcos(pi-theta(nres))
2046             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2047             do k=1,3
2048               uz(k,i)=fac*uz(k,i)
2049             enddo
2050 C Compute the derivatives of uz
2051             uzder(1,1,1)= 0.0d0
2052             uzder(2,1,1)=-dc_norm(3,i-1)
2053             uzder(3,1,1)= dc_norm(2,i-1)
2054             uzder(1,2,1)= dc_norm(3,i-1)
2055             uzder(2,2,1)= 0.0d0
2056             uzder(3,2,1)=-dc_norm(1,i-1)
2057             uzder(1,3,1)=-dc_norm(2,i-1)
2058             uzder(2,3,1)= dc_norm(1,i-1)
2059             uzder(3,3,1)= 0.0d0
2060             uzder(1,1,2)= 0.0d0
2061             uzder(2,1,2)= dc_norm(3,i)
2062             uzder(3,1,2)=-dc_norm(2,i)
2063             uzder(1,2,2)=-dc_norm(3,i)
2064             uzder(2,2,2)= 0.0d0
2065             uzder(3,2,2)= dc_norm(1,i)
2066             uzder(1,3,2)= dc_norm(2,i)
2067             uzder(2,3,2)=-dc_norm(1,i)
2068             uzder(3,3,2)= 0.0d0
2069 C Compute the Y-axis
2070             facy=fac
2071             do k=1,3
2072               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2073             enddo
2074 C Compute the derivatives of uy
2075             do j=1,3
2076               do k=1,3
2077                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2078      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2079                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2080               enddo
2081               uyder(j,j,1)=uyder(j,j,1)-costh
2082               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2083             enddo
2084             do j=1,2
2085               do k=1,3
2086                 do l=1,3
2087                   uygrad(l,k,j,i)=uyder(l,k,j)
2088                   uzgrad(l,k,j,i)=uzder(l,k,j)
2089                 enddo
2090               enddo
2091             enddo
2092             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2093             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2094             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2095             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2096           else
2097 C Other residues
2098 C Compute the Z-axis
2099             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2100             costh=dcos(pi-theta(i+2))
2101             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2102             do k=1,3
2103               uz(k,i)=fac*uz(k,i)
2104             enddo
2105 C Compute the derivatives of uz
2106             uzder(1,1,1)= 0.0d0
2107             uzder(2,1,1)=-dc_norm(3,i+1)
2108             uzder(3,1,1)= dc_norm(2,i+1)
2109             uzder(1,2,1)= dc_norm(3,i+1)
2110             uzder(2,2,1)= 0.0d0
2111             uzder(3,2,1)=-dc_norm(1,i+1)
2112             uzder(1,3,1)=-dc_norm(2,i+1)
2113             uzder(2,3,1)= dc_norm(1,i+1)
2114             uzder(3,3,1)= 0.0d0
2115             uzder(1,1,2)= 0.0d0
2116             uzder(2,1,2)= dc_norm(3,i)
2117             uzder(3,1,2)=-dc_norm(2,i)
2118             uzder(1,2,2)=-dc_norm(3,i)
2119             uzder(2,2,2)= 0.0d0
2120             uzder(3,2,2)= dc_norm(1,i)
2121             uzder(1,3,2)= dc_norm(2,i)
2122             uzder(2,3,2)=-dc_norm(1,i)
2123             uzder(3,3,2)= 0.0d0
2124 C Compute the Y-axis
2125             facy=fac
2126             do k=1,3
2127               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2128             enddo
2129 C Compute the derivatives of uy
2130             do j=1,3
2131               do k=1,3
2132                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2133      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2134                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2135               enddo
2136               uyder(j,j,1)=uyder(j,j,1)-costh
2137               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2138             enddo
2139             do j=1,2
2140               do k=1,3
2141                 do l=1,3
2142                   uygrad(l,k,j,i)=uyder(l,k,j)
2143                   uzgrad(l,k,j,i)=uzder(l,k,j)
2144                 enddo
2145               enddo
2146             enddo
2147             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2148             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2149             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2150             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2151           endif
2152       enddo
2153       do i=1,nres-1
2154         vbld_inv_temp(1)=vbld_inv(i+1)
2155         if (i.lt.nres-1) then
2156           vbld_inv_temp(2)=vbld_inv(i+2)
2157           else
2158           vbld_inv_temp(2)=vbld_inv(i)
2159           endif
2160         do j=1,2
2161           do k=1,3
2162             do l=1,3
2163               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2164               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2165             enddo
2166           enddo
2167         enddo
2168       enddo
2169 #if defined(PARVEC) && defined(MPI)
2170       if (nfgtasks1.gt.1) then
2171         time00=MPI_Wtime()
2172 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2173 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2174 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2175         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2176      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2177      &   FG_COMM1,IERR)
2178         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2179      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2180      &   FG_COMM1,IERR)
2181         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2182      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2183      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2184         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2185      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2186      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2187         time_gather=time_gather+MPI_Wtime()-time00
2188       endif
2189 c      if (fg_rank.eq.0) then
2190 c        write (iout,*) "Arrays UY and UZ"
2191 c        do i=1,nres-1
2192 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2193 c     &     (uz(k,i),k=1,3)
2194 c        enddo
2195 c      endif
2196 #endif
2197       return
2198       end
2199 C-----------------------------------------------------------------------------
2200       subroutine check_vecgrad
2201       implicit real*8 (a-h,o-z)
2202       include 'DIMENSIONS'
2203       include 'COMMON.IOUNITS'
2204       include 'COMMON.GEO'
2205       include 'COMMON.VAR'
2206       include 'COMMON.LOCAL'
2207       include 'COMMON.CHAIN'
2208       include 'COMMON.VECTORS'
2209       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2210       dimension uyt(3,maxres),uzt(3,maxres)
2211       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2212       double precision delta /1.0d-7/
2213       call vec_and_deriv
2214 cd      do i=1,nres
2215 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2216 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2217 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2218 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2219 cd     &     (dc_norm(if90,i),if90=1,3)
2220 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2221 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2222 cd          write(iout,'(a)')
2223 cd      enddo
2224       do i=1,nres
2225         do j=1,2
2226           do k=1,3
2227             do l=1,3
2228               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2229               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2230             enddo
2231           enddo
2232         enddo
2233       enddo
2234       call vec_and_deriv
2235       do i=1,nres
2236         do j=1,3
2237           uyt(j,i)=uy(j,i)
2238           uzt(j,i)=uz(j,i)
2239         enddo
2240       enddo
2241       do i=1,nres
2242 cd        write (iout,*) 'i=',i
2243         do k=1,3
2244           erij(k)=dc_norm(k,i)
2245         enddo
2246         do j=1,3
2247           do k=1,3
2248             dc_norm(k,i)=erij(k)
2249           enddo
2250           dc_norm(j,i)=dc_norm(j,i)+delta
2251 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2252 c          do k=1,3
2253 c            dc_norm(k,i)=dc_norm(k,i)/fac
2254 c          enddo
2255 c          write (iout,*) (dc_norm(k,i),k=1,3)
2256 c          write (iout,*) (erij(k),k=1,3)
2257           call vec_and_deriv
2258           do k=1,3
2259             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2260             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2261             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2262             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2263           enddo
2264 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2265 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2266 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2267         enddo
2268         do k=1,3
2269           dc_norm(k,i)=erij(k)
2270         enddo
2271 cd        do k=1,3
2272 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2273 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2274 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2275 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2276 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2277 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2278 cd          write (iout,'(a)')
2279 cd        enddo
2280       enddo
2281       return
2282       end
2283 C--------------------------------------------------------------------------
2284       subroutine set_matrices
2285       implicit real*8 (a-h,o-z)
2286       include 'DIMENSIONS'
2287 #ifdef MPI
2288       include "mpif.h"
2289       include "COMMON.SETUP"
2290       integer IERR
2291       integer status(MPI_STATUS_SIZE)
2292 #endif
2293       include 'COMMON.IOUNITS'
2294       include 'COMMON.GEO'
2295       include 'COMMON.VAR'
2296       include 'COMMON.LOCAL'
2297       include 'COMMON.CHAIN'
2298       include 'COMMON.DERIV'
2299       include 'COMMON.INTERACT'
2300       include 'COMMON.CONTACTS'
2301       include 'COMMON.TORSION'
2302       include 'COMMON.VECTORS'
2303       include 'COMMON.FFIELD'
2304       double precision auxvec(2),auxmat(2,2)
2305 C
2306 C Compute the virtual-bond-torsional-angle dependent quantities needed
2307 C to calculate the el-loc multibody terms of various order.
2308 C
2309 #ifdef PARMAT
2310       do i=ivec_start+2,ivec_end+2
2311 #else
2312       do i=3,nres+1
2313 #endif
2314         if (i .lt. nres+1) then
2315           sin1=dsin(phi(i))
2316           cos1=dcos(phi(i))
2317           sintab(i-2)=sin1
2318           costab(i-2)=cos1
2319           obrot(1,i-2)=cos1
2320           obrot(2,i-2)=sin1
2321           sin2=dsin(2*phi(i))
2322           cos2=dcos(2*phi(i))
2323           sintab2(i-2)=sin2
2324           costab2(i-2)=cos2
2325           obrot2(1,i-2)=cos2
2326           obrot2(2,i-2)=sin2
2327           Ug(1,1,i-2)=-cos1
2328           Ug(1,2,i-2)=-sin1
2329           Ug(2,1,i-2)=-sin1
2330           Ug(2,2,i-2)= cos1
2331           Ug2(1,1,i-2)=-cos2
2332           Ug2(1,2,i-2)=-sin2
2333           Ug2(2,1,i-2)=-sin2
2334           Ug2(2,2,i-2)= cos2
2335         else
2336           costab(i-2)=1.0d0
2337           sintab(i-2)=0.0d0
2338           obrot(1,i-2)=1.0d0
2339           obrot(2,i-2)=0.0d0
2340           obrot2(1,i-2)=0.0d0
2341           obrot2(2,i-2)=0.0d0
2342           Ug(1,1,i-2)=1.0d0
2343           Ug(1,2,i-2)=0.0d0
2344           Ug(2,1,i-2)=0.0d0
2345           Ug(2,2,i-2)=1.0d0
2346           Ug2(1,1,i-2)=0.0d0
2347           Ug2(1,2,i-2)=0.0d0
2348           Ug2(2,1,i-2)=0.0d0
2349           Ug2(2,2,i-2)=0.0d0
2350         endif
2351         if (i .gt. 3 .and. i .lt. nres+1) then
2352           obrot_der(1,i-2)=-sin1
2353           obrot_der(2,i-2)= cos1
2354           Ugder(1,1,i-2)= sin1
2355           Ugder(1,2,i-2)=-cos1
2356           Ugder(2,1,i-2)=-cos1
2357           Ugder(2,2,i-2)=-sin1
2358           dwacos2=cos2+cos2
2359           dwasin2=sin2+sin2
2360           obrot2_der(1,i-2)=-dwasin2
2361           obrot2_der(2,i-2)= dwacos2
2362           Ug2der(1,1,i-2)= dwasin2
2363           Ug2der(1,2,i-2)=-dwacos2
2364           Ug2der(2,1,i-2)=-dwacos2
2365           Ug2der(2,2,i-2)=-dwasin2
2366         else
2367           obrot_der(1,i-2)=0.0d0
2368           obrot_der(2,i-2)=0.0d0
2369           Ugder(1,1,i-2)=0.0d0
2370           Ugder(1,2,i-2)=0.0d0
2371           Ugder(2,1,i-2)=0.0d0
2372           Ugder(2,2,i-2)=0.0d0
2373           obrot2_der(1,i-2)=0.0d0
2374           obrot2_der(2,i-2)=0.0d0
2375           Ug2der(1,1,i-2)=0.0d0
2376           Ug2der(1,2,i-2)=0.0d0
2377           Ug2der(2,1,i-2)=0.0d0
2378           Ug2der(2,2,i-2)=0.0d0
2379         endif
2380 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2381         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2382           iti = itortyp(itype(i-2))
2383         else
2384           iti=ntortyp+1
2385         endif
2386 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2387         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2388           iti1 = itortyp(itype(i-1))
2389         else
2390           iti1=ntortyp+1
2391         endif
2392 cd        write (iout,*) '*******i',i,' iti1',iti
2393 cd        write (iout,*) 'b1',b1(:,iti)
2394 cd        write (iout,*) 'b2',b2(:,iti)
2395 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2396 c        if (i .gt. iatel_s+2) then
2397         if (i .gt. nnt+2) then
2398           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2399           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2400           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2401      &    then
2402           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2403           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2404           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2405           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2406           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2407           endif
2408         else
2409           do k=1,2
2410             Ub2(k,i-2)=0.0d0
2411             Ctobr(k,i-2)=0.0d0
2412             Dtobr2(k,i-2)=0.0d0
2413             do l=1,2
2414               EUg(l,k,i-2)=0.0d0
2415               CUg(l,k,i-2)=0.0d0
2416               DUg(l,k,i-2)=0.0d0
2417               DtUg2(l,k,i-2)=0.0d0
2418             enddo
2419           enddo
2420         endif
2421         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2422         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2423         do k=1,2
2424           muder(k,i-2)=Ub2der(k,i-2)
2425         enddo
2426 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2427         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2428           if (itype(i-1).le.ntyp) then
2429             iti1 = itortyp(itype(i-1))
2430           else
2431             iti1=ntortyp+1
2432           endif
2433         else
2434           iti1=ntortyp+1
2435         endif
2436         do k=1,2
2437           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2438         enddo
2439 cd        write (iout,*) 'mu ',mu(:,i-2)
2440 cd        write (iout,*) 'mu1',mu1(:,i-2)
2441 cd        write (iout,*) 'mu2',mu2(:,i-2)
2442         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2443      &  then
2444         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2445         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2446         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2447         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2448         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2449 C Vectors and matrices dependent on a single virtual-bond dihedral.
2450         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2451         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2452         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2453         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2454         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2455         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2456         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2457         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2458         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2459         endif
2460       enddo
2461 C Matrices dependent on two consecutive virtual-bond dihedrals.
2462 C The order of matrices is from left to right.
2463       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2464      &then
2465 c      do i=max0(ivec_start,2),ivec_end
2466       do i=2,nres-1
2467         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2468         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2469         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2470         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2471         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2472         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2473         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2474         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2475       enddo
2476       endif
2477 #if defined(MPI) && defined(PARMAT)
2478 #ifdef DEBUG
2479 c      if (fg_rank.eq.0) then
2480         write (iout,*) "Arrays UG and UGDER before GATHER"
2481         do i=1,nres-1
2482           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2483      &     ((ug(l,k,i),l=1,2),k=1,2),
2484      &     ((ugder(l,k,i),l=1,2),k=1,2)
2485         enddo
2486         write (iout,*) "Arrays UG2 and UG2DER"
2487         do i=1,nres-1
2488           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2489      &     ((ug2(l,k,i),l=1,2),k=1,2),
2490      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2491         enddo
2492         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2493         do i=1,nres-1
2494           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2495      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2496      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2497         enddo
2498         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2499         do i=1,nres-1
2500           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2501      &     costab(i),sintab(i),costab2(i),sintab2(i)
2502         enddo
2503         write (iout,*) "Array MUDER"
2504         do i=1,nres-1
2505           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2506         enddo
2507 c      endif
2508 #endif
2509       if (nfgtasks.gt.1) then
2510         time00=MPI_Wtime()
2511 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2512 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2513 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2514 #ifdef MATGATHER
2515         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2516      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2517      &   FG_COMM1,IERR)
2518         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2534      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2535      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2536         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2537      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2538      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2539         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2540      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2541      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2542         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2543      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2544      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2545         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2546      &  then
2547         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2548      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2549      &   FG_COMM1,IERR)
2550         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2555      &   FG_COMM1,IERR)
2556        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2557      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2558      &   FG_COMM1,IERR)
2559         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2563      &   ivec_count(fg_rank1),
2564      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2567      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2568      &   FG_COMM1,IERR)
2569         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2573      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2574      &   FG_COMM1,IERR)
2575         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2576      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2577      &   FG_COMM1,IERR)
2578         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2579      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2582      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2583      &   FG_COMM1,IERR)
2584         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2588      &   ivec_count(fg_rank1),
2589      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2592      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2593      &   FG_COMM1,IERR)
2594        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2596      &   FG_COMM1,IERR)
2597         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2598      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2601      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2604      &   ivec_count(fg_rank1),
2605      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2606      &   FG_COMM1,IERR)
2607         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2608      &   ivec_count(fg_rank1),
2609      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2610      &   FG_COMM1,IERR)
2611         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2612      &   ivec_count(fg_rank1),
2613      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2614      &   MPI_MAT2,FG_COMM1,IERR)
2615         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2616      &   ivec_count(fg_rank1),
2617      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2618      &   MPI_MAT2,FG_COMM1,IERR)
2619         endif
2620 #else
2621 c Passes matrix info through the ring
2622       isend=fg_rank1
2623       irecv=fg_rank1-1
2624       if (irecv.lt.0) irecv=nfgtasks1-1
2625       iprev=irecv
2626       inext=fg_rank1+1
2627       if (inext.ge.nfgtasks1) inext=0
2628       do i=1,nfgtasks1-1
2629 c        write (iout,*) "isend",isend," irecv",irecv
2630 c        call flush(iout)
2631         lensend=lentyp(isend)
2632         lenrecv=lentyp(irecv)
2633 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2634 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2635 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2636 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2637 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2638 c        write (iout,*) "Gather ROTAT1"
2639 c        call flush(iout)
2640 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2641 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2642 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2643 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2644 c        write (iout,*) "Gather ROTAT2"
2645 c        call flush(iout)
2646         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2647      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2648      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2649      &   iprev,4400+irecv,FG_COMM,status,IERR)
2650 c        write (iout,*) "Gather ROTAT_OLD"
2651 c        call flush(iout)
2652         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2653      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2654      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2655      &   iprev,5500+irecv,FG_COMM,status,IERR)
2656 c        write (iout,*) "Gather PRECOMP11"
2657 c        call flush(iout)
2658         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2659      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2660      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2661      &   iprev,6600+irecv,FG_COMM,status,IERR)
2662 c        write (iout,*) "Gather PRECOMP12"
2663 c        call flush(iout)
2664         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2665      &  then
2666         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2667      &   MPI_ROTAT2(lensend),inext,7700+isend,
2668      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2669      &   iprev,7700+irecv,FG_COMM,status,IERR)
2670 c        write (iout,*) "Gather PRECOMP21"
2671 c        call flush(iout)
2672         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2673      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2674      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2675      &   iprev,8800+irecv,FG_COMM,status,IERR)
2676 c        write (iout,*) "Gather PRECOMP22"
2677 c        call flush(iout)
2678         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2679      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2680      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2681      &   MPI_PRECOMP23(lenrecv),
2682      &   iprev,9900+irecv,FG_COMM,status,IERR)
2683 c        write (iout,*) "Gather PRECOMP23"
2684 c        call flush(iout)
2685         endif
2686         isend=irecv
2687         irecv=irecv-1
2688         if (irecv.lt.0) irecv=nfgtasks1-1
2689       enddo
2690 #endif
2691         time_gather=time_gather+MPI_Wtime()-time00
2692       endif
2693 #ifdef DEBUG
2694 c      if (fg_rank.eq.0) then
2695         write (iout,*) "Arrays UG and UGDER"
2696         do i=1,nres-1
2697           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2698      &     ((ug(l,k,i),l=1,2),k=1,2),
2699      &     ((ugder(l,k,i),l=1,2),k=1,2)
2700         enddo
2701         write (iout,*) "Arrays UG2 and UG2DER"
2702         do i=1,nres-1
2703           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2704      &     ((ug2(l,k,i),l=1,2),k=1,2),
2705      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2706         enddo
2707         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2708         do i=1,nres-1
2709           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2710      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2711      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2712         enddo
2713         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2714         do i=1,nres-1
2715           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2716      &     costab(i),sintab(i),costab2(i),sintab2(i)
2717         enddo
2718         write (iout,*) "Array MUDER"
2719         do i=1,nres-1
2720           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2721         enddo
2722 c      endif
2723 #endif
2724 #endif
2725 cd      do i=1,nres
2726 cd        iti = itortyp(itype(i))
2727 cd        write (iout,*) i
2728 cd        do j=1,2
2729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2731 cd        enddo
2732 cd      enddo
2733       return
2734       end
2735 C--------------------------------------------------------------------------
2736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2737 C
2738 C This subroutine calculates the average interaction energy and its gradient
2739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2741 C The potential depends both on the distance of peptide-group centers and on
2742 C the orientation of the CA-CA virtual bonds.
2743 C
2744       implicit real*8 (a-h,o-z)
2745 #ifdef MPI
2746       include 'mpif.h'
2747 #endif
2748       include 'DIMENSIONS'
2749       include 'COMMON.CONTROL'
2750       include 'COMMON.SETUP'
2751       include 'COMMON.IOUNITS'
2752       include 'COMMON.GEO'
2753       include 'COMMON.VAR'
2754       include 'COMMON.LOCAL'
2755       include 'COMMON.CHAIN'
2756       include 'COMMON.DERIV'
2757       include 'COMMON.INTERACT'
2758       include 'COMMON.CONTACTS'
2759       include 'COMMON.TORSION'
2760       include 'COMMON.VECTORS'
2761       include 'COMMON.FFIELD'
2762       include 'COMMON.TIME1'
2763       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2764      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2765       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2766      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2767       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2768      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2769      &    num_conti,j1,j2
2770 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2771 #ifdef MOMENT
2772       double precision scal_el /1.0d0/
2773 #else
2774       double precision scal_el /0.5d0/
2775 #endif
2776 C 12/13/98
2777 C 13-go grudnia roku pamietnego...
2778       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2779      &                   0.0d0,1.0d0,0.0d0,
2780      &                   0.0d0,0.0d0,1.0d0/
2781 cd      write(iout,*) 'In EELEC'
2782 cd      do i=1,nloctyp
2783 cd        write(iout,*) 'Type',i
2784 cd        write(iout,*) 'B1',B1(:,i)
2785 cd        write(iout,*) 'B2',B2(:,i)
2786 cd        write(iout,*) 'CC',CC(:,:,i)
2787 cd        write(iout,*) 'DD',DD(:,:,i)
2788 cd        write(iout,*) 'EE',EE(:,:,i)
2789 cd      enddo
2790 cd      call check_vecgrad
2791 cd      stop
2792       if (icheckgrad.eq.1) then
2793         do i=1,nres-1
2794           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2795           do k=1,3
2796             dc_norm(k,i)=dc(k,i)*fac
2797           enddo
2798 c          write (iout,*) 'i',i,' fac',fac
2799         enddo
2800       endif
2801       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2802      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2803      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2804 c        call vec_and_deriv
2805 #ifdef TIMING
2806         time01=MPI_Wtime()
2807 #endif
2808         call set_matrices
2809 #ifdef TIMING
2810         time_mat=time_mat+MPI_Wtime()-time01
2811 #endif
2812       endif
2813 cd      do i=1,nres-1
2814 cd        write (iout,*) 'i=',i
2815 cd        do k=1,3
2816 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2817 cd        enddo
2818 cd        do k=1,3
2819 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2820 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2821 cd        enddo
2822 cd      enddo
2823       t_eelecij=0.0d0
2824       ees=0.0D0
2825       evdw1=0.0D0
2826       eel_loc=0.0d0
2827       eello_turn3=0.0d0
2828       eello_turn4=0.0d0
2829       ind=0
2830       do i=1,nres
2831         num_cont_hb(i)=0
2832       enddo
2833 cd      print '(a)','Enter EELEC'
2834 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2835       do i=1,nres
2836         gel_loc_loc(i)=0.0d0
2837         gcorr_loc(i)=0.0d0
2838       enddo
2839 c
2840 c
2841 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2842 C
2843 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2844 C
2845       do i=iturn3_start,iturn3_end
2846         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2847      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2848         dxi=dc(1,i)
2849         dyi=dc(2,i)
2850         dzi=dc(3,i)
2851         dx_normi=dc_norm(1,i)
2852         dy_normi=dc_norm(2,i)
2853         dz_normi=dc_norm(3,i)
2854         xmedi=c(1,i)+0.5d0*dxi
2855         ymedi=c(2,i)+0.5d0*dyi
2856         zmedi=c(3,i)+0.5d0*dzi
2857         num_conti=0
2858         call eelecij(i,i+2,ees,evdw1,eel_loc)
2859         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2860         num_cont_hb(i)=num_conti
2861       enddo
2862       do i=iturn4_start,iturn4_end
2863         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2864      &    .or. itype(i+3).eq.ntyp1
2865      &    .or. itype(i+4).eq.ntyp1) cycle
2866         dxi=dc(1,i)
2867         dyi=dc(2,i)
2868         dzi=dc(3,i)
2869         dx_normi=dc_norm(1,i)
2870         dy_normi=dc_norm(2,i)
2871         dz_normi=dc_norm(3,i)
2872         xmedi=c(1,i)+0.5d0*dxi
2873         ymedi=c(2,i)+0.5d0*dyi
2874         zmedi=c(3,i)+0.5d0*dzi
2875         num_conti=num_cont_hb(i)
2876         call eelecij(i,i+3,ees,evdw1,eel_loc)
2877         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2878      &   call eturn4(i,eello_turn4)
2879         num_cont_hb(i)=num_conti
2880       enddo   ! i
2881 c
2882 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2883 c
2884       do i=iatel_s,iatel_e
2885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2886         dxi=dc(1,i)
2887         dyi=dc(2,i)
2888         dzi=dc(3,i)
2889         dx_normi=dc_norm(1,i)
2890         dy_normi=dc_norm(2,i)
2891         dz_normi=dc_norm(3,i)
2892         xmedi=c(1,i)+0.5d0*dxi
2893         ymedi=c(2,i)+0.5d0*dyi
2894         zmedi=c(3,i)+0.5d0*dzi
2895 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2896         num_conti=num_cont_hb(i)
2897         do j=ielstart(i),ielend(i)
2898 c          write (iout,*) i,j,itype(i),itype(j)
2899           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2900           call eelecij(i,j,ees,evdw1,eel_loc)
2901         enddo ! j
2902         num_cont_hb(i)=num_conti
2903       enddo   ! i
2904 c      write (iout,*) "Number of loop steps in EELEC:",ind
2905 cd      do i=1,nres
2906 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2907 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2908 cd      enddo
2909 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2910 ccc      eel_loc=eel_loc+eello_turn3
2911 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2912       return
2913       end
2914 C-------------------------------------------------------------------------------
2915       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2916       implicit real*8 (a-h,o-z)
2917       include 'DIMENSIONS'
2918 #ifdef MPI
2919       include "mpif.h"
2920 #endif
2921       include 'COMMON.CONTROL'
2922       include 'COMMON.IOUNITS'
2923       include 'COMMON.GEO'
2924       include 'COMMON.VAR'
2925       include 'COMMON.LOCAL'
2926       include 'COMMON.CHAIN'
2927       include 'COMMON.DERIV'
2928       include 'COMMON.INTERACT'
2929       include 'COMMON.CONTACTS'
2930       include 'COMMON.TORSION'
2931       include 'COMMON.VECTORS'
2932       include 'COMMON.FFIELD'
2933       include 'COMMON.TIME1'
2934       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2935      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2936       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2937      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2938       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2939      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2940      &    num_conti,j1,j2
2941 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2942 #ifdef MOMENT
2943       double precision scal_el /1.0d0/
2944 #else
2945       double precision scal_el /0.5d0/
2946 #endif
2947 C 12/13/98
2948 C 13-go grudnia roku pamietnego...
2949       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2950      &                   0.0d0,1.0d0,0.0d0,
2951      &                   0.0d0,0.0d0,1.0d0/
2952 c          time00=MPI_Wtime()
2953 cd      write (iout,*) "eelecij",i,j
2954 c          ind=ind+1
2955           iteli=itel(i)
2956           itelj=itel(j)
2957           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2958           aaa=app(iteli,itelj)
2959           bbb=bpp(iteli,itelj)
2960           ael6i=ael6(iteli,itelj)
2961           ael3i=ael3(iteli,itelj)
2962           dxj=dc(1,j)
2963           dyj=dc(2,j)
2964           dzj=dc(3,j)
2965           dx_normj=dc_norm(1,j)
2966           dy_normj=dc_norm(2,j)
2967           dz_normj=dc_norm(3,j)
2968           xj=c(1,j)+0.5D0*dxj-xmedi
2969           yj=c(2,j)+0.5D0*dyj-ymedi
2970           zj=c(3,j)+0.5D0*dzj-zmedi
2971           rij=xj*xj+yj*yj+zj*zj
2972           rrmij=1.0D0/rij
2973           rij=dsqrt(rij)
2974           rmij=1.0D0/rij
2975           r3ij=rrmij*rmij
2976           r6ij=r3ij*r3ij
2977           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2978           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2979           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2980           fac=cosa-3.0D0*cosb*cosg
2981           ev1=aaa*r6ij*r6ij
2982 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2983           if (j.eq.i+2) ev1=scal_el*ev1
2984           ev2=bbb*r6ij
2985           fac3=ael6i*r6ij
2986           fac4=ael3i*r3ij
2987           evdwij=ev1+ev2
2988           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2989           el2=fac4*fac
2990           eesij=el1+el2
2991 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2992           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2993           ees=ees+eesij
2994           evdw1=evdw1+evdwij
2995 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2996 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2997 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2998 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2999
3000           if (energy_dec) then
3001               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3002      &'evdw1',i,j,evdwij
3003      &,iteli,itelj,aaa,evdw1
3004               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3005           endif
3006
3007 C
3008 C Calculate contributions to the Cartesian gradient.
3009 C
3010 #ifdef SPLITELE
3011           facvdw=-6*rrmij*(ev1+evdwij)
3012           facel=-3*rrmij*(el1+eesij)
3013           fac1=fac
3014           erij(1)=xj*rmij
3015           erij(2)=yj*rmij
3016           erij(3)=zj*rmij
3017 *
3018 * Radial derivatives. First process both termini of the fragment (i,j)
3019 *
3020           ggg(1)=facel*xj
3021           ggg(2)=facel*yj
3022           ggg(3)=facel*zj
3023 c          do k=1,3
3024 c            ghalf=0.5D0*ggg(k)
3025 c            gelc(k,i)=gelc(k,i)+ghalf
3026 c            gelc(k,j)=gelc(k,j)+ghalf
3027 c          enddo
3028 c 9/28/08 AL Gradient compotents will be summed only at the end
3029           do k=1,3
3030             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3031             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3032           enddo
3033 *
3034 * Loop over residues i+1 thru j-1.
3035 *
3036 cgrad          do k=i+1,j-1
3037 cgrad            do l=1,3
3038 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3039 cgrad            enddo
3040 cgrad          enddo
3041           ggg(1)=facvdw*xj
3042           ggg(2)=facvdw*yj
3043           ggg(3)=facvdw*zj
3044 c          do k=1,3
3045 c            ghalf=0.5D0*ggg(k)
3046 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3047 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3048 c          enddo
3049 c 9/28/08 AL Gradient compotents will be summed only at the end
3050           do k=1,3
3051             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3052             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3053           enddo
3054 *
3055 * Loop over residues i+1 thru j-1.
3056 *
3057 cgrad          do k=i+1,j-1
3058 cgrad            do l=1,3
3059 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3060 cgrad            enddo
3061 cgrad          enddo
3062 #else
3063           facvdw=ev1+evdwij
3064           facel=el1+eesij
3065           fac1=fac
3066           fac=-3*rrmij*(facvdw+facvdw+facel)
3067           erij(1)=xj*rmij
3068           erij(2)=yj*rmij
3069           erij(3)=zj*rmij
3070 *
3071 * Radial derivatives. First process both termini of the fragment (i,j)
3072 *
3073           ggg(1)=fac*xj
3074           ggg(2)=fac*yj
3075           ggg(3)=fac*zj
3076 c          do k=1,3
3077 c            ghalf=0.5D0*ggg(k)
3078 c            gelc(k,i)=gelc(k,i)+ghalf
3079 c            gelc(k,j)=gelc(k,j)+ghalf
3080 c          enddo
3081 c 9/28/08 AL Gradient compotents will be summed only at the end
3082           do k=1,3
3083             gelc_long(k,j)=gelc(k,j)+ggg(k)
3084             gelc_long(k,i)=gelc(k,i)-ggg(k)
3085           enddo
3086 *
3087 * Loop over residues i+1 thru j-1.
3088 *
3089 cgrad          do k=i+1,j-1
3090 cgrad            do l=1,3
3091 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3092 cgrad            enddo
3093 cgrad          enddo
3094 c 9/28/08 AL Gradient compotents will be summed only at the end
3095           ggg(1)=facvdw*xj
3096           ggg(2)=facvdw*yj
3097           ggg(3)=facvdw*zj
3098           do k=1,3
3099             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3100             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3101           enddo
3102 #endif
3103 *
3104 * Angular part
3105 *
3106           ecosa=2.0D0*fac3*fac1+fac4
3107           fac4=-3.0D0*fac4
3108           fac3=-6.0D0*fac3
3109           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3110           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3111           do k=1,3
3112             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3113             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3114           enddo
3115 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3116 cd   &          (dcosg(k),k=1,3)
3117           do k=1,3
3118             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3119           enddo
3120 c          do k=1,3
3121 c            ghalf=0.5D0*ggg(k)
3122 c            gelc(k,i)=gelc(k,i)+ghalf
3123 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3124 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3125 c            gelc(k,j)=gelc(k,j)+ghalf
3126 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3127 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3128 c          enddo
3129 cgrad          do k=i+1,j-1
3130 cgrad            do l=1,3
3131 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3132 cgrad            enddo
3133 cgrad          enddo
3134           do k=1,3
3135             gelc(k,i)=gelc(k,i)
3136      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3137      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3138             gelc(k,j)=gelc(k,j)
3139      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3140      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3141             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3142             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3143           enddo
3144           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3145      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3146      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3147 C
3148 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3149 C   energy of a peptide unit is assumed in the form of a second-order
3150 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3151 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3152 C   are computed for EVERY pair of non-contiguous peptide groups.
3153 C
3154           if (j.lt.nres-1) then
3155             j1=j+1
3156             j2=j-1
3157           else
3158             j1=j-1
3159             j2=j-2
3160           endif
3161           kkk=0
3162           do k=1,2
3163             do l=1,2
3164               kkk=kkk+1
3165               muij(kkk)=mu(k,i)*mu(l,j)
3166             enddo
3167           enddo
3168 cd         write (iout,*) 'EELEC: i',i,' j',j
3169 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3170 cd          write(iout,*) 'muij',muij
3171           ury=scalar(uy(1,i),erij)
3172           urz=scalar(uz(1,i),erij)
3173           vry=scalar(uy(1,j),erij)
3174           vrz=scalar(uz(1,j),erij)
3175           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3176           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3177           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3178           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3179           fac=dsqrt(-ael6i)*r3ij
3180           a22=a22*fac
3181           a23=a23*fac
3182           a32=a32*fac
3183           a33=a33*fac
3184 cd          write (iout,'(4i5,4f10.5)')
3185 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3186 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3187 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3188 cd     &      uy(:,j),uz(:,j)
3189 cd          write (iout,'(4f10.5)')
3190 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3191 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3192 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3193 cd           write (iout,'(9f10.5/)')
3194 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3195 C Derivatives of the elements of A in virtual-bond vectors
3196           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3197           do k=1,3
3198             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3199             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3200             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3201             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3202             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3203             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3204             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3205             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3206             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3207             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3208             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3209             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3210           enddo
3211 C Compute radial contributions to the gradient
3212           facr=-3.0d0*rrmij
3213           a22der=a22*facr
3214           a23der=a23*facr
3215           a32der=a32*facr
3216           a33der=a33*facr
3217           agg(1,1)=a22der*xj
3218           agg(2,1)=a22der*yj
3219           agg(3,1)=a22der*zj
3220           agg(1,2)=a23der*xj
3221           agg(2,2)=a23der*yj
3222           agg(3,2)=a23der*zj
3223           agg(1,3)=a32der*xj
3224           agg(2,3)=a32der*yj
3225           agg(3,3)=a32der*zj
3226           agg(1,4)=a33der*xj
3227           agg(2,4)=a33der*yj
3228           agg(3,4)=a33der*zj
3229 C Add the contributions coming from er
3230           fac3=-3.0d0*fac
3231           do k=1,3
3232             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3233             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3234             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3235             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3236           enddo
3237           do k=1,3
3238 C Derivatives in DC(i)
3239 cgrad            ghalf1=0.5d0*agg(k,1)
3240 cgrad            ghalf2=0.5d0*agg(k,2)
3241 cgrad            ghalf3=0.5d0*agg(k,3)
3242 cgrad            ghalf4=0.5d0*agg(k,4)
3243             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3244      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3245             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3246      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3247             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3248      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3249             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3250      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3251 C Derivatives in DC(i+1)
3252             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3253      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3254             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3255      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3256             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3257      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3258             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3259      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3260 C Derivatives in DC(j)
3261             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3262      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3263             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3264      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3265             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3266      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3267             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3268      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3269 C Derivatives in DC(j+1) or DC(nres-1)
3270             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3271      &      -3.0d0*vryg(k,3)*ury)
3272             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3273      &      -3.0d0*vrzg(k,3)*ury)
3274             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3275      &      -3.0d0*vryg(k,3)*urz)
3276             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3277      &      -3.0d0*vrzg(k,3)*urz)
3278 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3279 cgrad              do l=1,4
3280 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3281 cgrad              enddo
3282 cgrad            endif
3283           enddo
3284           acipa(1,1)=a22
3285           acipa(1,2)=a23
3286           acipa(2,1)=a32
3287           acipa(2,2)=a33
3288           a22=-a22
3289           a23=-a23
3290           do l=1,2
3291             do k=1,3
3292               agg(k,l)=-agg(k,l)
3293               aggi(k,l)=-aggi(k,l)
3294               aggi1(k,l)=-aggi1(k,l)
3295               aggj(k,l)=-aggj(k,l)
3296               aggj1(k,l)=-aggj1(k,l)
3297             enddo
3298           enddo
3299           if (j.lt.nres-1) then
3300             a22=-a22
3301             a32=-a32
3302             do l=1,3,2
3303               do k=1,3
3304                 agg(k,l)=-agg(k,l)
3305                 aggi(k,l)=-aggi(k,l)
3306                 aggi1(k,l)=-aggi1(k,l)
3307                 aggj(k,l)=-aggj(k,l)
3308                 aggj1(k,l)=-aggj1(k,l)
3309               enddo
3310             enddo
3311           else
3312             a22=-a22
3313             a23=-a23
3314             a32=-a32
3315             a33=-a33
3316             do l=1,4
3317               do k=1,3
3318                 agg(k,l)=-agg(k,l)
3319                 aggi(k,l)=-aggi(k,l)
3320                 aggi1(k,l)=-aggi1(k,l)
3321                 aggj(k,l)=-aggj(k,l)
3322                 aggj1(k,l)=-aggj1(k,l)
3323               enddo
3324             enddo
3325           endif
3326           ENDIF ! WCORR
3327           IF (wel_loc.gt.0.0d0) THEN
3328 C Contribution to the local-electrostatic energy coming from the i-j pair
3329           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3330      &     +a33*muij(4)
3331 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3332
3333           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3334      &            'eelloc',i,j,eel_loc_ij
3335 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3336
3337           eel_loc=eel_loc+eel_loc_ij
3338 C Partial derivatives in virtual-bond dihedral angles gamma
3339           if (i.gt.1)
3340      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3341      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3342      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3343           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3344      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3345      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3346 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3347           do l=1,3
3348             ggg(l)=agg(l,1)*muij(1)+
3349      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3350             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3351             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3352 cgrad            ghalf=0.5d0*ggg(l)
3353 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3354 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3355           enddo
3356 cgrad          do k=i+1,j2
3357 cgrad            do l=1,3
3358 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3359 cgrad            enddo
3360 cgrad          enddo
3361 C Remaining derivatives of eello
3362           do l=1,3
3363             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3364      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3365             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3366      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3367             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3368      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3369             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3370      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3371           enddo
3372           ENDIF
3373 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3374 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3375           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3376      &       .and. num_conti.le.maxconts) then
3377 c            write (iout,*) i,j," entered corr"
3378 C
3379 C Calculate the contact function. The ith column of the array JCONT will
3380 C contain the numbers of atoms that make contacts with the atom I (of numbers
3381 C greater than I). The arrays FACONT and GACONT will contain the values of
3382 C the contact function and its derivative.
3383 c           r0ij=1.02D0*rpp(iteli,itelj)
3384 c           r0ij=1.11D0*rpp(iteli,itelj)
3385             r0ij=2.20D0*rpp(iteli,itelj)
3386 c           r0ij=1.55D0*rpp(iteli,itelj)
3387             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3388             if (fcont.gt.0.0D0) then
3389               num_conti=num_conti+1
3390               if (num_conti.gt.maxconts) then
3391                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3392      &                         ' will skip next contacts for this conf.'
3393               else
3394                 jcont_hb(num_conti,i)=j
3395 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3396 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3397                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3398      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3399 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3400 C  terms.
3401                 d_cont(num_conti,i)=rij
3402 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3403 C     --- Electrostatic-interaction matrix ---
3404                 a_chuj(1,1,num_conti,i)=a22
3405                 a_chuj(1,2,num_conti,i)=a23
3406                 a_chuj(2,1,num_conti,i)=a32
3407                 a_chuj(2,2,num_conti,i)=a33
3408 C     --- Gradient of rij
3409                 do kkk=1,3
3410                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3411                 enddo
3412                 kkll=0
3413                 do k=1,2
3414                   do l=1,2
3415                     kkll=kkll+1
3416                     do m=1,3
3417                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3418                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3419                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3420                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3421                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3422                     enddo
3423                   enddo
3424                 enddo
3425                 ENDIF
3426                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3427 C Calculate contact energies
3428                 cosa4=4.0D0*cosa
3429                 wij=cosa-3.0D0*cosb*cosg
3430                 cosbg1=cosb+cosg
3431                 cosbg2=cosb-cosg
3432 c               fac3=dsqrt(-ael6i)/r0ij**3
3433                 fac3=dsqrt(-ael6i)*r3ij
3434 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3435                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3436                 if (ees0tmp.gt.0) then
3437                   ees0pij=dsqrt(ees0tmp)
3438                 else
3439                   ees0pij=0
3440                 endif
3441 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3442                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3443                 if (ees0tmp.gt.0) then
3444                   ees0mij=dsqrt(ees0tmp)
3445                 else
3446                   ees0mij=0
3447                 endif
3448 c               ees0mij=0.0D0
3449                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3450                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3451 C Diagnostics. Comment out or remove after debugging!
3452 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3453 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3454 c               ees0m(num_conti,i)=0.0D0
3455 C End diagnostics.
3456 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3457 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3458 C Angular derivatives of the contact function
3459                 ees0pij1=fac3/ees0pij
3460                 ees0mij1=fac3/ees0mij
3461                 fac3p=-3.0D0*fac3*rrmij
3462                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3463                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3464 c               ees0mij1=0.0D0
3465                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3466                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3467                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3468                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3469                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3470                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3471                 ecosap=ecosa1+ecosa2
3472                 ecosbp=ecosb1+ecosb2
3473                 ecosgp=ecosg1+ecosg2
3474                 ecosam=ecosa1-ecosa2
3475                 ecosbm=ecosb1-ecosb2
3476                 ecosgm=ecosg1-ecosg2
3477 C Diagnostics
3478 c               ecosap=ecosa1
3479 c               ecosbp=ecosb1
3480 c               ecosgp=ecosg1
3481 c               ecosam=0.0D0
3482 c               ecosbm=0.0D0
3483 c               ecosgm=0.0D0
3484 C End diagnostics
3485                 facont_hb(num_conti,i)=fcont
3486                 fprimcont=fprimcont/rij
3487 cd              facont_hb(num_conti,i)=1.0D0
3488 C Following line is for diagnostics.
3489 cd              fprimcont=0.0D0
3490                 do k=1,3
3491                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3492                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3493                 enddo
3494                 do k=1,3
3495                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3496                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3497                 enddo
3498                 gggp(1)=gggp(1)+ees0pijp*xj
3499                 gggp(2)=gggp(2)+ees0pijp*yj
3500                 gggp(3)=gggp(3)+ees0pijp*zj
3501                 gggm(1)=gggm(1)+ees0mijp*xj
3502                 gggm(2)=gggm(2)+ees0mijp*yj
3503                 gggm(3)=gggm(3)+ees0mijp*zj
3504 C Derivatives due to the contact function
3505                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3506                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3507                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3508                 do k=1,3
3509 c
3510 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3511 c          following the change of gradient-summation algorithm.
3512 c
3513 cgrad                  ghalfp=0.5D0*gggp(k)
3514 cgrad                  ghalfm=0.5D0*gggm(k)
3515                   gacontp_hb1(k,num_conti,i)=!ghalfp
3516      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3517      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3518                   gacontp_hb2(k,num_conti,i)=!ghalfp
3519      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3520      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3521                   gacontp_hb3(k,num_conti,i)=gggp(k)
3522                   gacontm_hb1(k,num_conti,i)=!ghalfm
3523      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3524      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3525                   gacontm_hb2(k,num_conti,i)=!ghalfm
3526      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3527      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3528                   gacontm_hb3(k,num_conti,i)=gggm(k)
3529                 enddo
3530 C Diagnostics. Comment out or remove after debugging!
3531 cdiag           do k=1,3
3532 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3533 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3534 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3535 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3536 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3537 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3538 cdiag           enddo
3539               ENDIF ! wcorr
3540               endif  ! num_conti.le.maxconts
3541             endif  ! fcont.gt.0
3542           endif    ! j.gt.i+1
3543           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3544             do k=1,4
3545               do l=1,3
3546                 ghalf=0.5d0*agg(l,k)
3547                 aggi(l,k)=aggi(l,k)+ghalf
3548                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3549                 aggj(l,k)=aggj(l,k)+ghalf
3550               enddo
3551             enddo
3552             if (j.eq.nres-1 .and. i.lt.j-2) then
3553               do k=1,4
3554                 do l=1,3
3555                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3556                 enddo
3557               enddo
3558             endif
3559           endif
3560 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3561       return
3562       end
3563 C-----------------------------------------------------------------------------
3564       subroutine eturn3(i,eello_turn3)
3565 C Third- and fourth-order contributions from turns
3566       implicit real*8 (a-h,o-z)
3567       include 'DIMENSIONS'
3568       include 'COMMON.IOUNITS'
3569       include 'COMMON.GEO'
3570       include 'COMMON.VAR'
3571       include 'COMMON.LOCAL'
3572       include 'COMMON.CHAIN'
3573       include 'COMMON.DERIV'
3574       include 'COMMON.INTERACT'
3575       include 'COMMON.CONTACTS'
3576       include 'COMMON.TORSION'
3577       include 'COMMON.VECTORS'
3578       include 'COMMON.FFIELD'
3579       include 'COMMON.CONTROL'
3580       dimension ggg(3)
3581       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3582      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3583      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3584       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3585      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3586       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3587      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3588      &    num_conti,j1,j2
3589       j=i+2
3590 c      write (iout,*) "eturn3",i,j,j1,j2
3591       a_temp(1,1)=a22
3592       a_temp(1,2)=a23
3593       a_temp(2,1)=a32
3594       a_temp(2,2)=a33
3595 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3596 C
3597 C               Third-order contributions
3598 C
3599 C                 (i+2)o----(i+3)
3600 C                      | |
3601 C                      | |
3602 C                 (i+1)o----i
3603 C
3604 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3605 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3606         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3607         call transpose2(auxmat(1,1),auxmat1(1,1))
3608         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3609         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3610         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3611      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3612 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3613 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3614 cd     &    ' eello_turn3_num',4*eello_turn3_num
3615 C Derivatives in gamma(i)
3616         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3617         call transpose2(auxmat2(1,1),auxmat3(1,1))
3618         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3619         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3620 C Derivatives in gamma(i+1)
3621         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3622         call transpose2(auxmat2(1,1),auxmat3(1,1))
3623         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3624         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3625      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3626 C Cartesian derivatives
3627         do l=1,3
3628 c            ghalf1=0.5d0*agg(l,1)
3629 c            ghalf2=0.5d0*agg(l,2)
3630 c            ghalf3=0.5d0*agg(l,3)
3631 c            ghalf4=0.5d0*agg(l,4)
3632           a_temp(1,1)=aggi(l,1)!+ghalf1
3633           a_temp(1,2)=aggi(l,2)!+ghalf2
3634           a_temp(2,1)=aggi(l,3)!+ghalf3
3635           a_temp(2,2)=aggi(l,4)!+ghalf4
3636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3637           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3639           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3640           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3641           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3642           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3643           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3644           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3645      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3646           a_temp(1,1)=aggj(l,1)!+ghalf1
3647           a_temp(1,2)=aggj(l,2)!+ghalf2
3648           a_temp(2,1)=aggj(l,3)!+ghalf3
3649           a_temp(2,2)=aggj(l,4)!+ghalf4
3650           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3651           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3652      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3653           a_temp(1,1)=aggj1(l,1)
3654           a_temp(1,2)=aggj1(l,2)
3655           a_temp(2,1)=aggj1(l,3)
3656           a_temp(2,2)=aggj1(l,4)
3657           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3658           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3659      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3660         enddo
3661       return
3662       end
3663 C-------------------------------------------------------------------------------
3664       subroutine eturn4(i,eello_turn4)
3665 C Third- and fourth-order contributions from turns
3666       implicit real*8 (a-h,o-z)
3667       include 'DIMENSIONS'
3668       include 'COMMON.IOUNITS'
3669       include 'COMMON.GEO'
3670       include 'COMMON.VAR'
3671       include 'COMMON.LOCAL'
3672       include 'COMMON.CHAIN'
3673       include 'COMMON.DERIV'
3674       include 'COMMON.INTERACT'
3675       include 'COMMON.CONTACTS'
3676       include 'COMMON.TORSION'
3677       include 'COMMON.VECTORS'
3678       include 'COMMON.FFIELD'
3679       include 'COMMON.CONTROL'
3680       dimension ggg(3)
3681       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3682      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3683      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3684       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3685      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3686       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3687      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3688      &    num_conti,j1,j2
3689       j=i+3
3690 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3691 C
3692 C               Fourth-order contributions
3693 C
3694 C                 (i+3)o----(i+4)
3695 C                     /  |
3696 C               (i+2)o   |
3697 C                     \  |
3698 C                 (i+1)o----i
3699 C
3700 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3701 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3702 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3703         a_temp(1,1)=a22
3704         a_temp(1,2)=a23
3705         a_temp(2,1)=a32
3706         a_temp(2,2)=a33
3707         iti1=itortyp(itype(i+1))
3708         iti2=itortyp(itype(i+2))
3709         iti3=itortyp(itype(i+3))
3710 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3711         call transpose2(EUg(1,1,i+1),e1t(1,1))
3712         call transpose2(Eug(1,1,i+2),e2t(1,1))
3713         call transpose2(Eug(1,1,i+3),e3t(1,1))
3714         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3715         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3716         s1=scalar2(b1(1,iti2),auxvec(1))
3717         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3718         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3719         s2=scalar2(b1(1,iti1),auxvec(1))
3720         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3721         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3722         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3723         eello_turn4=eello_turn4-(s1+s2+s3)
3724         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3725      &      'eturn4',i,j,-(s1+s2+s3)
3726 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3727 cd     &    ' eello_turn4_num',8*eello_turn4_num
3728 C Derivatives in gamma(i)
3729         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3730         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3731         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3732         s1=scalar2(b1(1,iti2),auxvec(1))
3733         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3734         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3735         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3736 C Derivatives in gamma(i+1)
3737         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3738         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3739         s2=scalar2(b1(1,iti1),auxvec(1))
3740         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3741         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3742         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3744 C Derivatives in gamma(i+2)
3745         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3746         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3747         s1=scalar2(b1(1,iti2),auxvec(1))
3748         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3749         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3750         s2=scalar2(b1(1,iti1),auxvec(1))
3751         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3752         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3753         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3754         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3755 C Cartesian derivatives
3756 C Derivatives of this turn contributions in DC(i+2)
3757         if (j.lt.nres-1) then
3758           do l=1,3
3759             a_temp(1,1)=agg(l,1)
3760             a_temp(1,2)=agg(l,2)
3761             a_temp(2,1)=agg(l,3)
3762             a_temp(2,2)=agg(l,4)
3763             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3764             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3765             s1=scalar2(b1(1,iti2),auxvec(1))
3766             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3767             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3768             s2=scalar2(b1(1,iti1),auxvec(1))
3769             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3770             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3771             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3772             ggg(l)=-(s1+s2+s3)
3773             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3774           enddo
3775         endif
3776 C Remaining derivatives of this turn contribution
3777         do l=1,3
3778           a_temp(1,1)=aggi(l,1)
3779           a_temp(1,2)=aggi(l,2)
3780           a_temp(2,1)=aggi(l,3)
3781           a_temp(2,2)=aggi(l,4)
3782           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3783           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3784           s1=scalar2(b1(1,iti2),auxvec(1))
3785           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3786           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3787           s2=scalar2(b1(1,iti1),auxvec(1))
3788           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3789           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3790           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3791           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3792           a_temp(1,1)=aggi1(l,1)
3793           a_temp(1,2)=aggi1(l,2)
3794           a_temp(2,1)=aggi1(l,3)
3795           a_temp(2,2)=aggi1(l,4)
3796           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3797           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3798           s1=scalar2(b1(1,iti2),auxvec(1))
3799           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3800           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3801           s2=scalar2(b1(1,iti1),auxvec(1))
3802           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3803           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3804           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3805           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3806           a_temp(1,1)=aggj(l,1)
3807           a_temp(1,2)=aggj(l,2)
3808           a_temp(2,1)=aggj(l,3)
3809           a_temp(2,2)=aggj(l,4)
3810           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3811           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3812           s1=scalar2(b1(1,iti2),auxvec(1))
3813           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3814           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3815           s2=scalar2(b1(1,iti1),auxvec(1))
3816           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3817           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3818           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3819           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3820           a_temp(1,1)=aggj1(l,1)
3821           a_temp(1,2)=aggj1(l,2)
3822           a_temp(2,1)=aggj1(l,3)
3823           a_temp(2,2)=aggj1(l,4)
3824           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3825           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3826           s1=scalar2(b1(1,iti2),auxvec(1))
3827           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3828           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3829           s2=scalar2(b1(1,iti1),auxvec(1))
3830           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3831           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3832           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3833 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3834           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3835         enddo
3836       return
3837       end
3838 C-----------------------------------------------------------------------------
3839       subroutine vecpr(u,v,w)
3840       implicit real*8(a-h,o-z)
3841       dimension u(3),v(3),w(3)
3842       w(1)=u(2)*v(3)-u(3)*v(2)
3843       w(2)=-u(1)*v(3)+u(3)*v(1)
3844       w(3)=u(1)*v(2)-u(2)*v(1)
3845       return
3846       end
3847 C-----------------------------------------------------------------------------
3848       subroutine unormderiv(u,ugrad,unorm,ungrad)
3849 C This subroutine computes the derivatives of a normalized vector u, given
3850 C the derivatives computed without normalization conditions, ugrad. Returns
3851 C ungrad.
3852       implicit none
3853       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3854       double precision vec(3)
3855       double precision scalar
3856       integer i,j
3857 c      write (2,*) 'ugrad',ugrad
3858 c      write (2,*) 'u',u
3859       do i=1,3
3860         vec(i)=scalar(ugrad(1,i),u(1))
3861       enddo
3862 c      write (2,*) 'vec',vec
3863       do i=1,3
3864         do j=1,3
3865           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3866         enddo
3867       enddo
3868 c      write (2,*) 'ungrad',ungrad
3869       return
3870       end
3871 C-----------------------------------------------------------------------------
3872       subroutine escp_soft_sphere(evdw2,evdw2_14)
3873 C
3874 C This subroutine calculates the excluded-volume interaction energy between
3875 C peptide-group centers and side chains and its gradient in virtual-bond and
3876 C side-chain vectors.
3877 C
3878       implicit real*8 (a-h,o-z)
3879       include 'DIMENSIONS'
3880       include 'COMMON.GEO'
3881       include 'COMMON.VAR'
3882       include 'COMMON.LOCAL'
3883       include 'COMMON.CHAIN'
3884       include 'COMMON.DERIV'
3885       include 'COMMON.INTERACT'
3886       include 'COMMON.FFIELD'
3887       include 'COMMON.IOUNITS'
3888       include 'COMMON.CONTROL'
3889       dimension ggg(3)
3890       evdw2=0.0D0
3891       evdw2_14=0.0d0
3892       r0_scp=4.5d0
3893 cd    print '(a)','Enter ESCP'
3894 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3895       do i=iatscp_s,iatscp_e
3896         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3897         iteli=itel(i)
3898         xi=0.5D0*(c(1,i)+c(1,i+1))
3899         yi=0.5D0*(c(2,i)+c(2,i+1))
3900         zi=0.5D0*(c(3,i)+c(3,i+1))
3901
3902         do iint=1,nscp_gr(i)
3903
3904         do j=iscpstart(i,iint),iscpend(i,iint)
3905           if (itype(j).eq.ntyp1) cycle
3906           itypj=iabs(itype(j))
3907 C Uncomment following three lines for SC-p interactions
3908 c         xj=c(1,nres+j)-xi
3909 c         yj=c(2,nres+j)-yi
3910 c         zj=c(3,nres+j)-zi
3911 C Uncomment following three lines for Ca-p interactions
3912           xj=c(1,j)-xi
3913           yj=c(2,j)-yi
3914           zj=c(3,j)-zi
3915           rij=xj*xj+yj*yj+zj*zj
3916           r0ij=r0_scp
3917           r0ijsq=r0ij*r0ij
3918           if (rij.lt.r0ijsq) then
3919             evdwij=0.25d0*(rij-r0ijsq)**2
3920             fac=rij-r0ijsq
3921           else
3922             evdwij=0.0d0
3923             fac=0.0d0
3924           endif
3925           evdw2=evdw2+evdwij
3926 C
3927 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3928 C
3929           ggg(1)=xj*fac
3930           ggg(2)=yj*fac
3931           ggg(3)=zj*fac
3932 cgrad          if (j.lt.i) then
3933 cd          write (iout,*) 'j<i'
3934 C Uncomment following three lines for SC-p interactions
3935 c           do k=1,3
3936 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3937 c           enddo
3938 cgrad          else
3939 cd          write (iout,*) 'j>i'
3940 cgrad            do k=1,3
3941 cgrad              ggg(k)=-ggg(k)
3942 C Uncomment following line for SC-p interactions
3943 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3944 cgrad            enddo
3945 cgrad          endif
3946 cgrad          do k=1,3
3947 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3948 cgrad          enddo
3949 cgrad          kstart=min0(i+1,j)
3950 cgrad          kend=max0(i-1,j-1)
3951 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3952 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3953 cgrad          do k=kstart,kend
3954 cgrad            do l=1,3
3955 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3956 cgrad            enddo
3957 cgrad          enddo
3958           do k=1,3
3959             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3960             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3961           enddo
3962         enddo
3963
3964         enddo ! iint
3965       enddo ! i
3966       return
3967       end
3968 C-----------------------------------------------------------------------------
3969       subroutine escp(evdw2,evdw2_14)
3970 C
3971 C This subroutine calculates the excluded-volume interaction energy between
3972 C peptide-group centers and side chains and its gradient in virtual-bond and
3973 C side-chain vectors.
3974 C
3975       implicit real*8 (a-h,o-z)
3976       include 'DIMENSIONS'
3977       include 'COMMON.GEO'
3978       include 'COMMON.VAR'
3979       include 'COMMON.LOCAL'
3980       include 'COMMON.CHAIN'
3981       include 'COMMON.DERIV'
3982       include 'COMMON.INTERACT'
3983       include 'COMMON.FFIELD'
3984       include 'COMMON.IOUNITS'
3985       include 'COMMON.CONTROL'
3986       dimension ggg(3)
3987       evdw2=0.0D0
3988       evdw2_14=0.0d0
3989 cd    print '(a)','Enter ESCP'
3990 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3991       do i=iatscp_s,iatscp_e
3992         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3993         iteli=itel(i)
3994         xi=0.5D0*(c(1,i)+c(1,i+1))
3995         yi=0.5D0*(c(2,i)+c(2,i+1))
3996         zi=0.5D0*(c(3,i)+c(3,i+1))
3997
3998         do iint=1,nscp_gr(i)
3999
4000         do j=iscpstart(i,iint),iscpend(i,iint)
4001           itypj=iabs(itype(j))
4002           if (itypj.eq.ntyp1) cycle
4003 C Uncomment following three lines for SC-p interactions
4004 c         xj=c(1,nres+j)-xi
4005 c         yj=c(2,nres+j)-yi
4006 c         zj=c(3,nres+j)-zi
4007 C Uncomment following three lines for Ca-p interactions
4008           xj=c(1,j)-xi
4009           yj=c(2,j)-yi
4010           zj=c(3,j)-zi
4011           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4012           fac=rrij**expon2
4013           e1=fac*fac*aad(itypj,iteli)
4014           e2=fac*bad(itypj,iteli)
4015           if (iabs(j-i) .le. 2) then
4016             e1=scal14*e1
4017             e2=scal14*e2
4018             evdw2_14=evdw2_14+e1+e2
4019           endif
4020           evdwij=e1+e2
4021           evdw2=evdw2+evdwij
4022           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4023      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4024      &       bad(itypj,iteli)
4025 C
4026 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4027 C
4028           fac=-(evdwij+e1)*rrij
4029           ggg(1)=xj*fac
4030           ggg(2)=yj*fac
4031           ggg(3)=zj*fac
4032 cgrad          if (j.lt.i) then
4033 cd          write (iout,*) 'j<i'
4034 C Uncomment following three lines for SC-p interactions
4035 c           do k=1,3
4036 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4037 c           enddo
4038 cgrad          else
4039 cd          write (iout,*) 'j>i'
4040 cgrad            do k=1,3
4041 cgrad              ggg(k)=-ggg(k)
4042 C Uncomment following line for SC-p interactions
4043 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4044 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4045 cgrad            enddo
4046 cgrad          endif
4047 cgrad          do k=1,3
4048 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4049 cgrad          enddo
4050 cgrad          kstart=min0(i+1,j)
4051 cgrad          kend=max0(i-1,j-1)
4052 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4053 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4054 cgrad          do k=kstart,kend
4055 cgrad            do l=1,3
4056 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4057 cgrad            enddo
4058 cgrad          enddo
4059           do k=1,3
4060             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4061             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4062           enddo
4063         enddo
4064
4065         enddo ! iint
4066       enddo ! i
4067       do i=1,nct
4068         do j=1,3
4069           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4070           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4071           gradx_scp(j,i)=expon*gradx_scp(j,i)
4072         enddo
4073       enddo
4074 C******************************************************************************
4075 C
4076 C                              N O T E !!!
4077 C
4078 C To save time the factor EXPON has been extracted from ALL components
4079 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4080 C use!
4081 C
4082 C******************************************************************************
4083       return
4084       end
4085 C--------------------------------------------------------------------------
4086       subroutine edis(ehpb)
4087 C
4088 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4089 C
4090       implicit real*8 (a-h,o-z)
4091       include 'DIMENSIONS'
4092       include 'COMMON.SBRIDGE'
4093       include 'COMMON.CHAIN'
4094       include 'COMMON.DERIV'
4095       include 'COMMON.VAR'
4096       include 'COMMON.INTERACT'
4097       include 'COMMON.IOUNITS'
4098       include 'COMMON.CONTROL'
4099       dimension ggg(3)
4100       ehpb=0.0D0
4101       do i=1,3
4102        ggg(i)=0.0d0
4103       enddo
4104 C      write (iout,*) ,"link_end",link_end,constr_dist
4105 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4106 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4107       if (link_end.eq.0) return
4108       do i=link_start,link_end
4109 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4110 C CA-CA distance used in regularization of structure.
4111         ii=ihpb(i)
4112         jj=jhpb(i)
4113 C iii and jjj point to the residues for which the distance is assigned.
4114         if (ii.gt.nres) then
4115           iii=ii-nres
4116           jjj=jj-nres
4117         else
4118           iii=ii
4119           jjj=jj
4120         endif
4121 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4122 c     &    dhpb(i),dhpb1(i),forcon(i)
4123 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4124 C    distance and angle dependent SS bond potential.
4125 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4126 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4127         if (.not.dyn_ss .and. i.le.nss) then
4128 C 15/02/13 CC dynamic SSbond - additional check
4129          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4130      & iabs(itype(jjj)).eq.1) then
4131           call ssbond_ene(iii,jjj,eij)
4132           ehpb=ehpb+2*eij
4133          endif
4134 cd          write (iout,*) "eij",eij
4135 cd   &   ' waga=',waga,' fac=',fac
4136         else if (ii.gt.nres .and. jj.gt.nres) then
4137 c Restraints from contact prediction
4138           dd=dist(ii,jj)
4139           if (constr_dist.eq.11) then
4140             ehpb=ehpb+fordepth(i)**4.0d0
4141      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4142             fac=fordepth(i)**4.0d0
4143      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4144           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4145      &    ehpb,fordepth(i),dd
4146            else
4147           if (dhpb1(i).gt.0.0d0) then
4148             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4149             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4150 c            write (iout,*) "beta nmr",
4151 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4152           else
4153             dd=dist(ii,jj)
4154             rdis=dd-dhpb(i)
4155 C Get the force constant corresponding to this distance.
4156             waga=forcon(i)
4157 C Calculate the contribution to energy.
4158             ehpb=ehpb+waga*rdis*rdis
4159 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4160 C
4161 C Evaluate gradient.
4162 C
4163             fac=waga*rdis/dd
4164           endif
4165           endif
4166           do j=1,3
4167             ggg(j)=fac*(c(j,jj)-c(j,ii))
4168           enddo
4169           do j=1,3
4170             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4171             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4172           enddo
4173           do k=1,3
4174             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4175             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4176           enddo
4177         else
4178 C Calculate the distance between the two points and its difference from the
4179 C target distance.
4180           dd=dist(ii,jj)
4181           if (constr_dist.eq.11) then
4182             ehpb=ehpb+fordepth(i)**4.0d0
4183      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4184             fac=fordepth(i)**4.0d0
4185      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4186           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4187      &    ehpb,fordepth(i),dd
4188            else
4189           if (dhpb1(i).gt.0.0d0) then
4190             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4191             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4192 c            write (iout,*) "alph nmr",
4193 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4194           else
4195             rdis=dd-dhpb(i)
4196 C Get the force constant corresponding to this distance.
4197             waga=forcon(i)
4198 C Calculate the contribution to energy.
4199             ehpb=ehpb+waga*rdis*rdis
4200 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4201 C
4202 C Evaluate gradient.
4203 C
4204             fac=waga*rdis/dd
4205           endif
4206           endif
4207             do j=1,3
4208               ggg(j)=fac*(c(j,jj)-c(j,ii))
4209             enddo
4210 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4211 C If this is a SC-SC distance, we need to calculate the contributions to the
4212 C Cartesian gradient in the SC vectors (ghpbx).
4213           if (iii.lt.ii) then
4214           do j=1,3
4215             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4216             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4217           enddo
4218           endif
4219 cgrad        do j=iii,jjj-1
4220 cgrad          do k=1,3
4221 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4222 cgrad          enddo
4223 cgrad        enddo
4224           do k=1,3
4225             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4226             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4227           enddo
4228         endif
4229       enddo
4230       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4231       return
4232       end
4233 C--------------------------------------------------------------------------
4234       subroutine ssbond_ene(i,j,eij)
4235 C
4236 C Calculate the distance and angle dependent SS-bond potential energy
4237 C using a free-energy function derived based on RHF/6-31G** ab initio
4238 C calculations of diethyl disulfide.
4239 C
4240 C A. Liwo and U. Kozlowska, 11/24/03
4241 C
4242       implicit real*8 (a-h,o-z)
4243       include 'DIMENSIONS'
4244       include 'COMMON.SBRIDGE'
4245       include 'COMMON.CHAIN'
4246       include 'COMMON.DERIV'
4247       include 'COMMON.LOCAL'
4248       include 'COMMON.INTERACT'
4249       include 'COMMON.VAR'
4250       include 'COMMON.IOUNITS'
4251       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4252       itypi=iabs(itype(i))
4253       xi=c(1,nres+i)
4254       yi=c(2,nres+i)
4255       zi=c(3,nres+i)
4256       dxi=dc_norm(1,nres+i)
4257       dyi=dc_norm(2,nres+i)
4258       dzi=dc_norm(3,nres+i)
4259 c      dsci_inv=dsc_inv(itypi)
4260       dsci_inv=vbld_inv(nres+i)
4261       itypj=iabs(itype(j))
4262 c      dscj_inv=dsc_inv(itypj)
4263       dscj_inv=vbld_inv(nres+j)
4264       xj=c(1,nres+j)-xi
4265       yj=c(2,nres+j)-yi
4266       zj=c(3,nres+j)-zi
4267       dxj=dc_norm(1,nres+j)
4268       dyj=dc_norm(2,nres+j)
4269       dzj=dc_norm(3,nres+j)
4270       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4271       rij=dsqrt(rrij)
4272       erij(1)=xj*rij
4273       erij(2)=yj*rij
4274       erij(3)=zj*rij
4275       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4276       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4277       om12=dxi*dxj+dyi*dyj+dzi*dzj
4278       do k=1,3
4279         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4280         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4281       enddo
4282       rij=1.0d0/rij
4283       deltad=rij-d0cm
4284       deltat1=1.0d0-om1
4285       deltat2=1.0d0+om2
4286       deltat12=om2-om1+2.0d0
4287       cosphi=om12-om1*om2
4288       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4289      &  +akct*deltad*deltat12
4290      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4291 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4292 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4293 c     &  " deltat12",deltat12," eij",eij
4294       ed=2*akcm*deltad+akct*deltat12
4295       pom1=akct*deltad
4296       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4297       eom1=-2*akth*deltat1-pom1-om2*pom2
4298       eom2= 2*akth*deltat2+pom1-om1*pom2
4299       eom12=pom2
4300       do k=1,3
4301         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4302         ghpbx(k,i)=ghpbx(k,i)-ggk
4303      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4304      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4305         ghpbx(k,j)=ghpbx(k,j)+ggk
4306      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4307      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4308         ghpbc(k,i)=ghpbc(k,i)-ggk
4309         ghpbc(k,j)=ghpbc(k,j)+ggk
4310       enddo
4311 C
4312 C Calculate the components of the gradient in DC and X
4313 C
4314 cgrad      do k=i,j-1
4315 cgrad        do l=1,3
4316 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4317 cgrad        enddo
4318 cgrad      enddo
4319       return
4320       end
4321 C--------------------------------------------------------------------------
4322       subroutine ebond(estr)
4323 c
4324 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4325 c
4326       implicit real*8 (a-h,o-z)
4327       include 'DIMENSIONS'
4328       include 'COMMON.LOCAL'
4329       include 'COMMON.GEO'
4330       include 'COMMON.INTERACT'
4331       include 'COMMON.DERIV'
4332       include 'COMMON.VAR'
4333       include 'COMMON.CHAIN'
4334       include 'COMMON.IOUNITS'
4335       include 'COMMON.NAMES'
4336       include 'COMMON.FFIELD'
4337       include 'COMMON.CONTROL'
4338       include 'COMMON.SETUP'
4339       double precision u(3),ud(3)
4340       estr=0.0d0
4341       estr1=0.0d0
4342       do i=ibondp_start,ibondp_end
4343         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4344           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4345           do j=1,3
4346           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4347      &      *dc(j,i-1)/vbld(i)
4348           enddo
4349           if (energy_dec) write(iout,*)
4350      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4351         else
4352         diff = vbld(i)-vbldp0
4353         if (energy_dec) write (iout,*)
4354      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4355         estr=estr+diff*diff
4356         do j=1,3
4357           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4358         enddo
4359 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4360         endif
4361       enddo
4362       estr=0.5d0*AKP*estr+estr1
4363 c
4364 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4365 c
4366       do i=ibond_start,ibond_end
4367         iti=iabs(itype(i))
4368         if (iti.ne.10 .and. iti.ne.ntyp1) then
4369           nbi=nbondterm(iti)
4370           if (nbi.eq.1) then
4371             diff=vbld(i+nres)-vbldsc0(1,iti)
4372             if (energy_dec) write (iout,*)
4373      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4374      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4375             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4376             do j=1,3
4377               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4378             enddo
4379           else
4380             do j=1,nbi
4381               diff=vbld(i+nres)-vbldsc0(j,iti)
4382               ud(j)=aksc(j,iti)*diff
4383               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4384             enddo
4385             uprod=u(1)
4386             do j=2,nbi
4387               uprod=uprod*u(j)
4388             enddo
4389             usum=0.0d0
4390             usumsqder=0.0d0
4391             do j=1,nbi
4392               uprod1=1.0d0
4393               uprod2=1.0d0
4394               do k=1,nbi
4395                 if (k.ne.j) then
4396                   uprod1=uprod1*u(k)
4397                   uprod2=uprod2*u(k)*u(k)
4398                 endif
4399               enddo
4400               usum=usum+uprod1
4401               usumsqder=usumsqder+ud(j)*uprod2
4402             enddo
4403             estr=estr+uprod/usum
4404             do j=1,3
4405              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4406             enddo
4407           endif
4408         endif
4409       enddo
4410       return
4411       end
4412 #ifdef CRYST_THETA
4413 C--------------------------------------------------------------------------
4414       subroutine ebend(etheta,ethetacnstr)
4415 C
4416 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4417 C angles gamma and its derivatives in consecutive thetas and gammas.
4418 C
4419       implicit real*8 (a-h,o-z)
4420       include 'DIMENSIONS'
4421       include 'COMMON.LOCAL'
4422       include 'COMMON.GEO'
4423       include 'COMMON.INTERACT'
4424       include 'COMMON.DERIV'
4425       include 'COMMON.VAR'
4426       include 'COMMON.CHAIN'
4427       include 'COMMON.IOUNITS'
4428       include 'COMMON.NAMES'
4429       include 'COMMON.FFIELD'
4430       include 'COMMON.CONTROL'
4431       include 'COMMON.TORCNSTR'
4432       common /calcthet/ term1,term2,termm,diffak,ratak,
4433      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4434      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4435       double precision y(2),z(2)
4436       delta=0.02d0*pi
4437 c      time11=dexp(-2*time)
4438 c      time12=1.0d0
4439       etheta=0.0D0
4440 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4441       do i=ithet_start,ithet_end
4442         if (itype(i-1).eq.ntyp1) cycle
4443 C Zero the energy function and its derivative at 0 or pi.
4444         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4445         it=itype(i-1)
4446         ichir1=isign(1,itype(i-2))
4447         ichir2=isign(1,itype(i))
4448          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4449          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4450          if (itype(i-1).eq.10) then
4451           itype1=isign(10,itype(i-2))
4452           ichir11=isign(1,itype(i-2))
4453           ichir12=isign(1,itype(i-2))
4454           itype2=isign(10,itype(i))
4455           ichir21=isign(1,itype(i))
4456           ichir22=isign(1,itype(i))
4457          endif
4458
4459         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4460 #ifdef OSF
4461           phii=phi(i)
4462           if (phii.ne.phii) phii=150.0
4463 #else
4464           phii=phi(i)
4465 #endif
4466           y(1)=dcos(phii)
4467           y(2)=dsin(phii)
4468         else
4469           y(1)=0.0D0
4470           y(2)=0.0D0
4471         endif
4472         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4473 #ifdef OSF
4474           phii1=phi(i+1)
4475           if (phii1.ne.phii1) phii1=150.0
4476           phii1=pinorm(phii1)
4477           z(1)=cos(phii1)
4478 #else
4479           phii1=phi(i+1)
4480           z(1)=dcos(phii1)
4481 #endif
4482           z(2)=dsin(phii1)
4483         else
4484           z(1)=0.0D0
4485           z(2)=0.0D0
4486         endif
4487 C Calculate the "mean" value of theta from the part of the distribution
4488 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4489 C In following comments this theta will be referred to as t_c.
4490         thet_pred_mean=0.0d0
4491         do k=1,2
4492             athetk=athet(k,it,ichir1,ichir2)
4493             bthetk=bthet(k,it,ichir1,ichir2)
4494           if (it.eq.10) then
4495              athetk=athet(k,itype1,ichir11,ichir12)
4496              bthetk=bthet(k,itype2,ichir21,ichir22)
4497           endif
4498          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4499         enddo
4500         dthett=thet_pred_mean*ssd
4501         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4502 C Derivatives of the "mean" values in gamma1 and gamma2.
4503         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4504      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4505          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4506      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4507          if (it.eq.10) then
4508       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4509      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4510         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4511      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4512          endif
4513         if (theta(i).gt.pi-delta) then
4514           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4515      &         E_tc0)
4516           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4517           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4518           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4519      &        E_theta)
4520           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4521      &        E_tc)
4522         else if (theta(i).lt.delta) then
4523           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4524           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4525           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4526      &        E_theta)
4527           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4528           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4529      &        E_tc)
4530         else
4531           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4532      &        E_theta,E_tc)
4533         endif
4534         etheta=etheta+ethetai
4535         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4536      &      'ebend',i,ethetai
4537         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4538         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4539         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4540       enddo
4541       ethetacnstr=0.0d0
4542 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4543       do i=ithetaconstr_start,ithetaconstr_end
4544         itheta=itheta_constr(i)
4545         thetiii=theta(itheta)
4546         difi=pinorm(thetiii-theta_constr0(i))
4547         if (difi.gt.theta_drange(i)) then
4548           difi=difi-theta_drange(i)
4549           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4550           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4551      &    +for_thet_constr(i)*difi**3
4552         else if (difi.lt.-drange(i)) then
4553           difi=difi+drange(i)
4554           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4555           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4556      &    +for_thet_constr(i)*difi**3
4557         else
4558           difi=0.0
4559         endif
4560        if (energy_dec) then
4561         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4562      &    i,itheta,rad2deg*thetiii,
4563      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4564      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4565      &    gloc(itheta+nphi-2,icg)
4566         endif
4567       enddo
4568
4569 C Ufff.... We've done all this!!!
4570       return
4571       end
4572 C---------------------------------------------------------------------------
4573       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4574      &     E_tc)
4575       implicit real*8 (a-h,o-z)
4576       include 'DIMENSIONS'
4577       include 'COMMON.LOCAL'
4578       include 'COMMON.IOUNITS'
4579       common /calcthet/ term1,term2,termm,diffak,ratak,
4580      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4581      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4582 C Calculate the contributions to both Gaussian lobes.
4583 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4584 C The "polynomial part" of the "standard deviation" of this part of
4585 C the distribution.
4586         sig=polthet(3,it)
4587         do j=2,0,-1
4588           sig=sig*thet_pred_mean+polthet(j,it)
4589         enddo
4590 C Derivative of the "interior part" of the "standard deviation of the"
4591 C gamma-dependent Gaussian lobe in t_c.
4592         sigtc=3*polthet(3,it)
4593         do j=2,1,-1
4594           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4595         enddo
4596         sigtc=sig*sigtc
4597 C Set the parameters of both Gaussian lobes of the distribution.
4598 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4599         fac=sig*sig+sigc0(it)
4600         sigcsq=fac+fac
4601         sigc=1.0D0/sigcsq
4602 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4603         sigsqtc=-4.0D0*sigcsq*sigtc
4604 c       print *,i,sig,sigtc,sigsqtc
4605 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4606         sigtc=-sigtc/(fac*fac)
4607 C Following variable is sigma(t_c)**(-2)
4608         sigcsq=sigcsq*sigcsq
4609         sig0i=sig0(it)
4610         sig0inv=1.0D0/sig0i**2
4611         delthec=thetai-thet_pred_mean
4612         delthe0=thetai-theta0i
4613         term1=-0.5D0*sigcsq*delthec*delthec
4614         term2=-0.5D0*sig0inv*delthe0*delthe0
4615 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4616 C NaNs in taking the logarithm. We extract the largest exponent which is added
4617 C to the energy (this being the log of the distribution) at the end of energy
4618 C term evaluation for this virtual-bond angle.
4619         if (term1.gt.term2) then
4620           termm=term1
4621           term2=dexp(term2-termm)
4622           term1=1.0d0
4623         else
4624           termm=term2
4625           term1=dexp(term1-termm)
4626           term2=1.0d0
4627         endif
4628 C The ratio between the gamma-independent and gamma-dependent lobes of
4629 C the distribution is a Gaussian function of thet_pred_mean too.
4630         diffak=gthet(2,it)-thet_pred_mean
4631         ratak=diffak/gthet(3,it)**2
4632         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4633 C Let's differentiate it in thet_pred_mean NOW.
4634         aktc=ak*ratak
4635 C Now put together the distribution terms to make complete distribution.
4636         termexp=term1+ak*term2
4637         termpre=sigc+ak*sig0i
4638 C Contribution of the bending energy from this theta is just the -log of
4639 C the sum of the contributions from the two lobes and the pre-exponential
4640 C factor. Simple enough, isn't it?
4641         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4642 C NOW the derivatives!!!
4643 C 6/6/97 Take into account the deformation.
4644         E_theta=(delthec*sigcsq*term1
4645      &       +ak*delthe0*sig0inv*term2)/termexp
4646         E_tc=((sigtc+aktc*sig0i)/termpre
4647      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4648      &       aktc*term2)/termexp)
4649       return
4650       end
4651 c-----------------------------------------------------------------------------
4652       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4653       implicit real*8 (a-h,o-z)
4654       include 'DIMENSIONS'
4655       include 'COMMON.LOCAL'
4656       include 'COMMON.IOUNITS'
4657       common /calcthet/ term1,term2,termm,diffak,ratak,
4658      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4659      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4660       delthec=thetai-thet_pred_mean
4661       delthe0=thetai-theta0i
4662 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4663       t3 = thetai-thet_pred_mean
4664       t6 = t3**2
4665       t9 = term1
4666       t12 = t3*sigcsq
4667       t14 = t12+t6*sigsqtc
4668       t16 = 1.0d0
4669       t21 = thetai-theta0i
4670       t23 = t21**2
4671       t26 = term2
4672       t27 = t21*t26
4673       t32 = termexp
4674       t40 = t32**2
4675       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4676      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4677      & *(-t12*t9-ak*sig0inv*t27)
4678       return
4679       end
4680 #else
4681 C--------------------------------------------------------------------------
4682       subroutine ebend(etheta,ethetacnstr)
4683 C
4684 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4685 C angles gamma and its derivatives in consecutive thetas and gammas.
4686 C ab initio-derived potentials from
4687 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4688 C
4689       implicit real*8 (a-h,o-z)
4690       include 'DIMENSIONS'
4691       include 'COMMON.LOCAL'
4692       include 'COMMON.GEO'
4693       include 'COMMON.INTERACT'
4694       include 'COMMON.DERIV'
4695       include 'COMMON.VAR'
4696       include 'COMMON.CHAIN'
4697       include 'COMMON.IOUNITS'
4698       include 'COMMON.NAMES'
4699       include 'COMMON.FFIELD'
4700       include 'COMMON.CONTROL'
4701       include 'COMMON.TORCNSTR'
4702       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4703      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4704      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4705      & sinph1ph2(maxdouble,maxdouble)
4706       logical lprn /.false./, lprn1 /.false./
4707       etheta=0.0D0
4708       do i=ithet_start,ithet_end
4709         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4710      &(itype(i).eq.ntyp1)) cycle
4711 C        print *,i,theta(i)
4712         if (iabs(itype(i+1)).eq.20) iblock=2
4713         if (iabs(itype(i+1)).ne.20) iblock=1
4714         dethetai=0.0d0
4715         dephii=0.0d0
4716         dephii1=0.0d0
4717         theti2=0.5d0*theta(i)
4718         ityp2=ithetyp((itype(i-1)))
4719         do k=1,nntheterm
4720           coskt(k)=dcos(k*theti2)
4721           sinkt(k)=dsin(k*theti2)
4722         enddo
4723 C        print *,ethetai
4724
4725         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4726 #ifdef OSF
4727           phii=phi(i)
4728           if (phii.ne.phii) phii=150.0
4729 #else
4730           phii=phi(i)
4731 #endif
4732           ityp1=ithetyp((itype(i-2)))
4733 C propagation of chirality for glycine type
4734           do k=1,nsingle
4735             cosph1(k)=dcos(k*phii)
4736             sinph1(k)=dsin(k*phii)
4737           enddo
4738         else
4739           phii=0.0d0
4740           do k=1,nsingle
4741           ityp1=ithetyp((itype(i-2)))
4742             cosph1(k)=0.0d0
4743             sinph1(k)=0.0d0
4744           enddo
4745         endif
4746         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4747 #ifdef OSF
4748           phii1=phi(i+1)
4749           if (phii1.ne.phii1) phii1=150.0
4750           phii1=pinorm(phii1)
4751 #else
4752           phii1=phi(i+1)
4753 #endif
4754           ityp3=ithetyp((itype(i)))
4755           do k=1,nsingle
4756             cosph2(k)=dcos(k*phii1)
4757             sinph2(k)=dsin(k*phii1)
4758           enddo
4759         else
4760           phii1=0.0d0
4761           ityp3=ithetyp((itype(i)))
4762           do k=1,nsingle
4763             cosph2(k)=0.0d0
4764             sinph2(k)=0.0d0
4765           enddo
4766         endif
4767         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4768         do k=1,ndouble
4769           do l=1,k-1
4770             ccl=cosph1(l)*cosph2(k-l)
4771             ssl=sinph1(l)*sinph2(k-l)
4772             scl=sinph1(l)*cosph2(k-l)
4773             csl=cosph1(l)*sinph2(k-l)
4774             cosph1ph2(l,k)=ccl-ssl
4775             cosph1ph2(k,l)=ccl+ssl
4776             sinph1ph2(l,k)=scl+csl
4777             sinph1ph2(k,l)=scl-csl
4778           enddo
4779         enddo
4780         if (lprn) then
4781         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4782      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4783         write (iout,*) "coskt and sinkt"
4784         do k=1,nntheterm
4785           write (iout,*) k,coskt(k),sinkt(k)
4786         enddo
4787         endif
4788         do k=1,ntheterm
4789           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4790           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4791      &      *coskt(k)
4792           if (lprn)
4793      &    write (iout,*) "k",k,"
4794      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4795      &     " ethetai",ethetai
4796         enddo
4797         if (lprn) then
4798         write (iout,*) "cosph and sinph"
4799         do k=1,nsingle
4800           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4801         enddo
4802         write (iout,*) "cosph1ph2 and sinph2ph2"
4803         do k=2,ndouble
4804           do l=1,k-1
4805             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4806      &         sinph1ph2(l,k),sinph1ph2(k,l)
4807           enddo
4808         enddo
4809         write(iout,*) "ethetai",ethetai
4810         endif
4811 C       print *,ethetai
4812         do m=1,ntheterm2
4813           do k=1,nsingle
4814             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4815      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4816      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4817      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4818             ethetai=ethetai+sinkt(m)*aux
4819             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4820             dephii=dephii+k*sinkt(m)*(
4821      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4822      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4823             dephii1=dephii1+k*sinkt(m)*(
4824      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4825      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4826             if (lprn)
4827      &      write (iout,*) "m",m," k",k," bbthet",
4828      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4829      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4830      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4831      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4832 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4833           enddo
4834         enddo
4835 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4836 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4837 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4838 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4839         if (lprn)
4840      &  write(iout,*) "ethetai",ethetai
4841 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4842         do m=1,ntheterm3
4843           do k=2,ndouble
4844             do l=1,k-1
4845               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4846      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4847      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4848      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4849               ethetai=ethetai+sinkt(m)*aux
4850               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4851               dephii=dephii+l*sinkt(m)*(
4852      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4853      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4854      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4855      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4856               dephii1=dephii1+(k-l)*sinkt(m)*(
4857      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4858      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4859      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4860      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4861               if (lprn) then
4862               write (iout,*) "m",m," k",k," l",l," ffthet",
4863      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4864      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4865      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4866      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4867      &            " ethetai",ethetai
4868               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4869      &            cosph1ph2(k,l)*sinkt(m),
4870      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4871               endif
4872             enddo
4873           enddo
4874         enddo
4875 10      continue
4876 c        lprn1=.true.
4877 C        print *,ethetai
4878         if (lprn1)
4879      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4880      &   i,theta(i)*rad2deg,phii*rad2deg,
4881      &   phii1*rad2deg,ethetai
4882 c        lprn1=.false.
4883         etheta=etheta+ethetai
4884         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4885         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4886         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4887       enddo
4888 C now constrains
4889       ethetacnstr=0.0d0
4890 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4891       do i=ithetaconstr_start,ithetaconstr_end
4892         itheta=itheta_constr(i)
4893         thetiii=theta(itheta)
4894         difi=pinorm(thetiii-theta_constr0(i))
4895         if (difi.gt.theta_drange(i)) then
4896           difi=difi-theta_drange(i)
4897           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4898           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4899      &    +for_thet_constr(i)*difi**3
4900         else if (difi.lt.-drange(i)) then
4901           difi=difi+drange(i)
4902           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4903           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4904      &    +for_thet_constr(i)*difi**3
4905         else
4906           difi=0.0
4907         endif
4908        if (energy_dec) then
4909         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4910      &    i,itheta,rad2deg*thetiii,
4911      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4912      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4913      &    gloc(itheta+nphi-2,icg)
4914         endif
4915       enddo
4916
4917       return
4918       end
4919 #endif
4920 #ifdef CRYST_SC
4921 c-----------------------------------------------------------------------------
4922       subroutine esc(escloc)
4923 C Calculate the local energy of a side chain and its derivatives in the
4924 C corresponding virtual-bond valence angles THETA and the spherical angles
4925 C ALPHA and OMEGA.
4926       implicit real*8 (a-h,o-z)
4927       include 'DIMENSIONS'
4928       include 'COMMON.GEO'
4929       include 'COMMON.LOCAL'
4930       include 'COMMON.VAR'
4931       include 'COMMON.INTERACT'
4932       include 'COMMON.DERIV'
4933       include 'COMMON.CHAIN'
4934       include 'COMMON.IOUNITS'
4935       include 'COMMON.NAMES'
4936       include 'COMMON.FFIELD'
4937       include 'COMMON.CONTROL'
4938       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4939      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4940       common /sccalc/ time11,time12,time112,theti,it,nlobit
4941       delta=0.02d0*pi
4942       escloc=0.0D0
4943 c     write (iout,'(a)') 'ESC'
4944       do i=loc_start,loc_end
4945         it=itype(i)
4946         if (it.eq.ntyp1) cycle
4947         if (it.eq.10) goto 1
4948         nlobit=nlob(iabs(it))
4949 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4950 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4951         theti=theta(i+1)-pipol
4952         x(1)=dtan(theti)
4953         x(2)=alph(i)
4954         x(3)=omeg(i)
4955
4956         if (x(2).gt.pi-delta) then
4957           xtemp(1)=x(1)
4958           xtemp(2)=pi-delta
4959           xtemp(3)=x(3)
4960           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4961           xtemp(2)=pi
4962           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4963           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4964      &        escloci,dersc(2))
4965           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4966      &        ddersc0(1),dersc(1))
4967           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4968      &        ddersc0(3),dersc(3))
4969           xtemp(2)=pi-delta
4970           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4971           xtemp(2)=pi
4972           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4973           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4974      &            dersc0(2),esclocbi,dersc02)
4975           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4976      &            dersc12,dersc01)
4977           call splinthet(x(2),0.5d0*delta,ss,ssd)
4978           dersc0(1)=dersc01
4979           dersc0(2)=dersc02
4980           dersc0(3)=0.0d0
4981           do k=1,3
4982             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4983           enddo
4984           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4985 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4986 c    &             esclocbi,ss,ssd
4987           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4988 c         escloci=esclocbi
4989 c         write (iout,*) escloci
4990         else if (x(2).lt.delta) then
4991           xtemp(1)=x(1)
4992           xtemp(2)=delta
4993           xtemp(3)=x(3)
4994           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4995           xtemp(2)=0.0d0
4996           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4997           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4998      &        escloci,dersc(2))
4999           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5000      &        ddersc0(1),dersc(1))
5001           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5002      &        ddersc0(3),dersc(3))
5003           xtemp(2)=delta
5004           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5005           xtemp(2)=0.0d0
5006           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5007           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5008      &            dersc0(2),esclocbi,dersc02)
5009           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5010      &            dersc12,dersc01)
5011           dersc0(1)=dersc01
5012           dersc0(2)=dersc02
5013           dersc0(3)=0.0d0
5014           call splinthet(x(2),0.5d0*delta,ss,ssd)
5015           do k=1,3
5016             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5017           enddo
5018           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5019 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5020 c    &             esclocbi,ss,ssd
5021           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5022 c         write (iout,*) escloci
5023         else
5024           call enesc(x,escloci,dersc,ddummy,.false.)
5025         endif
5026
5027         escloc=escloc+escloci
5028         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5029      &     'escloc',i,escloci
5030 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5031
5032         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5033      &   wscloc*dersc(1)
5034         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5035         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5036     1   continue
5037       enddo
5038       return
5039       end
5040 C---------------------------------------------------------------------------
5041       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5042       implicit real*8 (a-h,o-z)
5043       include 'DIMENSIONS'
5044       include 'COMMON.GEO'
5045       include 'COMMON.LOCAL'
5046       include 'COMMON.IOUNITS'
5047       common /sccalc/ time11,time12,time112,theti,it,nlobit
5048       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5049       double precision contr(maxlob,-1:1)
5050       logical mixed
5051 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5052         escloc_i=0.0D0
5053         do j=1,3
5054           dersc(j)=0.0D0
5055           if (mixed) ddersc(j)=0.0d0
5056         enddo
5057         x3=x(3)
5058
5059 C Because of periodicity of the dependence of the SC energy in omega we have
5060 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5061 C To avoid underflows, first compute & store the exponents.
5062
5063         do iii=-1,1
5064
5065           x(3)=x3+iii*dwapi
5066
5067           do j=1,nlobit
5068             do k=1,3
5069               z(k)=x(k)-censc(k,j,it)
5070             enddo
5071             do k=1,3
5072               Axk=0.0D0
5073               do l=1,3
5074                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5075               enddo
5076               Ax(k,j,iii)=Axk
5077             enddo
5078             expfac=0.0D0
5079             do k=1,3
5080               expfac=expfac+Ax(k,j,iii)*z(k)
5081             enddo
5082             contr(j,iii)=expfac
5083           enddo ! j
5084
5085         enddo ! iii
5086
5087         x(3)=x3
5088 C As in the case of ebend, we want to avoid underflows in exponentiation and
5089 C subsequent NaNs and INFs in energy calculation.
5090 C Find the largest exponent
5091         emin=contr(1,-1)
5092         do iii=-1,1
5093           do j=1,nlobit
5094             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5095           enddo
5096         enddo
5097         emin=0.5D0*emin
5098 cd      print *,'it=',it,' emin=',emin
5099
5100 C Compute the contribution to SC energy and derivatives
5101         do iii=-1,1
5102
5103           do j=1,nlobit
5104 #ifdef OSF
5105             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5106             if(adexp.ne.adexp) adexp=1.0
5107             expfac=dexp(adexp)
5108 #else
5109             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5110 #endif
5111 cd          print *,'j=',j,' expfac=',expfac
5112             escloc_i=escloc_i+expfac
5113             do k=1,3
5114               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5115             enddo
5116             if (mixed) then
5117               do k=1,3,2
5118                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5119      &            +gaussc(k,2,j,it))*expfac
5120               enddo
5121             endif
5122           enddo
5123
5124         enddo ! iii
5125
5126         dersc(1)=dersc(1)/cos(theti)**2
5127         ddersc(1)=ddersc(1)/cos(theti)**2
5128         ddersc(3)=ddersc(3)
5129
5130         escloci=-(dlog(escloc_i)-emin)
5131         do j=1,3
5132           dersc(j)=dersc(j)/escloc_i
5133         enddo
5134         if (mixed) then
5135           do j=1,3,2
5136             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5137           enddo
5138         endif
5139       return
5140       end
5141 C------------------------------------------------------------------------------
5142       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5143       implicit real*8 (a-h,o-z)
5144       include 'DIMENSIONS'
5145       include 'COMMON.GEO'
5146       include 'COMMON.LOCAL'
5147       include 'COMMON.IOUNITS'
5148       common /sccalc/ time11,time12,time112,theti,it,nlobit
5149       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5150       double precision contr(maxlob)
5151       logical mixed
5152
5153       escloc_i=0.0D0
5154
5155       do j=1,3
5156         dersc(j)=0.0D0
5157       enddo
5158
5159       do j=1,nlobit
5160         do k=1,2
5161           z(k)=x(k)-censc(k,j,it)
5162         enddo
5163         z(3)=dwapi
5164         do k=1,3
5165           Axk=0.0D0
5166           do l=1,3
5167             Axk=Axk+gaussc(l,k,j,it)*z(l)
5168           enddo
5169           Ax(k,j)=Axk
5170         enddo
5171         expfac=0.0D0
5172         do k=1,3
5173           expfac=expfac+Ax(k,j)*z(k)
5174         enddo
5175         contr(j)=expfac
5176       enddo ! j
5177
5178 C As in the case of ebend, we want to avoid underflows in exponentiation and
5179 C subsequent NaNs and INFs in energy calculation.
5180 C Find the largest exponent
5181       emin=contr(1)
5182       do j=1,nlobit
5183         if (emin.gt.contr(j)) emin=contr(j)
5184       enddo
5185       emin=0.5D0*emin
5186
5187 C Compute the contribution to SC energy and derivatives
5188
5189       dersc12=0.0d0
5190       do j=1,nlobit
5191         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5192         escloc_i=escloc_i+expfac
5193         do k=1,2
5194           dersc(k)=dersc(k)+Ax(k,j)*expfac
5195         enddo
5196         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5197      &            +gaussc(1,2,j,it))*expfac
5198         dersc(3)=0.0d0
5199       enddo
5200
5201       dersc(1)=dersc(1)/cos(theti)**2
5202       dersc12=dersc12/cos(theti)**2
5203       escloci=-(dlog(escloc_i)-emin)
5204       do j=1,2
5205         dersc(j)=dersc(j)/escloc_i
5206       enddo
5207       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5208       return
5209       end
5210 #else
5211 c----------------------------------------------------------------------------------
5212       subroutine esc(escloc)
5213 C Calculate the local energy of a side chain and its derivatives in the
5214 C corresponding virtual-bond valence angles THETA and the spherical angles
5215 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5216 C added by Urszula Kozlowska. 07/11/2007
5217 C
5218       implicit real*8 (a-h,o-z)
5219       include 'DIMENSIONS'
5220       include 'COMMON.GEO'
5221       include 'COMMON.LOCAL'
5222       include 'COMMON.VAR'
5223       include 'COMMON.SCROT'
5224       include 'COMMON.INTERACT'
5225       include 'COMMON.DERIV'
5226       include 'COMMON.CHAIN'
5227       include 'COMMON.IOUNITS'
5228       include 'COMMON.NAMES'
5229       include 'COMMON.FFIELD'
5230       include 'COMMON.CONTROL'
5231       include 'COMMON.VECTORS'
5232       double precision x_prime(3),y_prime(3),z_prime(3)
5233      &    , sumene,dsc_i,dp2_i,x(65),
5234      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5235      &    de_dxx,de_dyy,de_dzz,de_dt
5236       double precision s1_t,s1_6_t,s2_t,s2_6_t
5237       double precision
5238      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5239      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5240      & dt_dCi(3),dt_dCi1(3)
5241       common /sccalc/ time11,time12,time112,theti,it,nlobit
5242       delta=0.02d0*pi
5243       escloc=0.0D0
5244       do i=loc_start,loc_end
5245         if (itype(i).eq.ntyp1) cycle
5246         costtab(i+1) =dcos(theta(i+1))
5247         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5248         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5249         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5250         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5251         cosfac=dsqrt(cosfac2)
5252         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5253         sinfac=dsqrt(sinfac2)
5254         it=iabs(itype(i))
5255         if (it.eq.10) goto 1
5256 c
5257 C  Compute the axes of tghe local cartesian coordinates system; store in
5258 c   x_prime, y_prime and z_prime
5259 c
5260         do j=1,3
5261           x_prime(j) = 0.00
5262           y_prime(j) = 0.00
5263           z_prime(j) = 0.00
5264         enddo
5265 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5266 C     &   dc_norm(3,i+nres)
5267         do j = 1,3
5268           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5269           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5270         enddo
5271         do j = 1,3
5272           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5273         enddo
5274 c       write (2,*) "i",i
5275 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5276 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5277 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5278 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5279 c      & " xy",scalar(x_prime(1),y_prime(1)),
5280 c      & " xz",scalar(x_prime(1),z_prime(1)),
5281 c      & " yy",scalar(y_prime(1),y_prime(1)),
5282 c      & " yz",scalar(y_prime(1),z_prime(1)),
5283 c      & " zz",scalar(z_prime(1),z_prime(1))
5284 c
5285 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5286 C to local coordinate system. Store in xx, yy, zz.
5287 c
5288         xx=0.0d0
5289         yy=0.0d0
5290         zz=0.0d0
5291         do j = 1,3
5292           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5293           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5294           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5295         enddo
5296
5297         xxtab(i)=xx
5298         yytab(i)=yy
5299         zztab(i)=zz
5300 C
5301 C Compute the energy of the ith side cbain
5302 C
5303 c        write (2,*) "xx",xx," yy",yy," zz",zz
5304         it=iabs(itype(i))
5305         do j = 1,65
5306           x(j) = sc_parmin(j,it)
5307         enddo
5308 #ifdef CHECK_COORD
5309 Cc diagnostics - remove later
5310         xx1 = dcos(alph(2))
5311         yy1 = dsin(alph(2))*dcos(omeg(2))
5312         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5313         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5314      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5315      &    xx1,yy1,zz1
5316 C,"  --- ", xx_w,yy_w,zz_w
5317 c end diagnostics
5318 #endif
5319         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5320      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5321      &   + x(10)*yy*zz
5322         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5323      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5324      & + x(20)*yy*zz
5325         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5326      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5327      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5328      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5329      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5330      &  +x(40)*xx*yy*zz
5331         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5332      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5333      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5334      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5335      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5336      &  +x(60)*xx*yy*zz
5337         dsc_i   = 0.743d0+x(61)
5338         dp2_i   = 1.9d0+x(62)
5339         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5340      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5341         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5342      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5343         s1=(1+x(63))/(0.1d0 + dscp1)
5344         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5345         s2=(1+x(65))/(0.1d0 + dscp2)
5346         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5347         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5348      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5349 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5350 c     &   sumene4,
5351 c     &   dscp1,dscp2,sumene
5352 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5353         escloc = escloc + sumene
5354 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5355 c     & ,zz,xx,yy
5356 c#define DEBUG
5357 #ifdef DEBUG
5358 C
5359 C This section to check the numerical derivatives of the energy of ith side
5360 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5361 C #define DEBUG in the code to turn it on.
5362 C
5363         write (2,*) "sumene               =",sumene
5364         aincr=1.0d-7
5365         xxsave=xx
5366         xx=xx+aincr
5367         write (2,*) xx,yy,zz
5368         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5369         de_dxx_num=(sumenep-sumene)/aincr
5370         xx=xxsave
5371         write (2,*) "xx+ sumene from enesc=",sumenep
5372         yysave=yy
5373         yy=yy+aincr
5374         write (2,*) xx,yy,zz
5375         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5376         de_dyy_num=(sumenep-sumene)/aincr
5377         yy=yysave
5378         write (2,*) "yy+ sumene from enesc=",sumenep
5379         zzsave=zz
5380         zz=zz+aincr
5381         write (2,*) xx,yy,zz
5382         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5383         de_dzz_num=(sumenep-sumene)/aincr
5384         zz=zzsave
5385         write (2,*) "zz+ sumene from enesc=",sumenep
5386         costsave=cost2tab(i+1)
5387         sintsave=sint2tab(i+1)
5388         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5389         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5390         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5391         de_dt_num=(sumenep-sumene)/aincr
5392         write (2,*) " t+ sumene from enesc=",sumenep
5393         cost2tab(i+1)=costsave
5394         sint2tab(i+1)=sintsave
5395 C End of diagnostics section.
5396 #endif
5397 C
5398 C Compute the gradient of esc
5399 C
5400 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5401         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5402         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5403         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5404         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5405         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5406         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5407         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5408         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5409         pom1=(sumene3*sint2tab(i+1)+sumene1)
5410      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5411         pom2=(sumene4*cost2tab(i+1)+sumene2)
5412      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5413         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5414         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5415      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5416      &  +x(40)*yy*zz
5417         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5418         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5419      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5420      &  +x(60)*yy*zz
5421         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5422      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5423      &        +(pom1+pom2)*pom_dx
5424 #ifdef DEBUG
5425         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5426 #endif
5427 C
5428         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5429         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5430      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5431      &  +x(40)*xx*zz
5432         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5433         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5434      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5435      &  +x(59)*zz**2 +x(60)*xx*zz
5436         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5437      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5438      &        +(pom1-pom2)*pom_dy
5439 #ifdef DEBUG
5440         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5441 #endif
5442 C
5443         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5444      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5445      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5446      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5447      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5448      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5449      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5450      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5451 #ifdef DEBUG
5452         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5453 #endif
5454 C
5455         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5456      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5457      &  +pom1*pom_dt1+pom2*pom_dt2
5458 #ifdef DEBUG
5459         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5460 #endif
5461 c#undef DEBUG
5462 c
5463 C
5464        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5465        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5466        cosfac2xx=cosfac2*xx
5467        sinfac2yy=sinfac2*yy
5468        do k = 1,3
5469          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5470      &      vbld_inv(i+1)
5471          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5472      &      vbld_inv(i)
5473          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5474          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5475 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5476 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5477 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5478 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5479          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5480          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5481          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5482          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5483          dZZ_Ci1(k)=0.0d0
5484          dZZ_Ci(k)=0.0d0
5485          do j=1,3
5486            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5487      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5488            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5489      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5490          enddo
5491
5492          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5493          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5494          dZZ_XYZ(k)=vbld_inv(i+nres)*
5495      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5496 c
5497          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5498          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5499        enddo
5500
5501        do k=1,3
5502          dXX_Ctab(k,i)=dXX_Ci(k)
5503          dXX_C1tab(k,i)=dXX_Ci1(k)
5504          dYY_Ctab(k,i)=dYY_Ci(k)
5505          dYY_C1tab(k,i)=dYY_Ci1(k)
5506          dZZ_Ctab(k,i)=dZZ_Ci(k)
5507          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5508          dXX_XYZtab(k,i)=dXX_XYZ(k)
5509          dYY_XYZtab(k,i)=dYY_XYZ(k)
5510          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5511        enddo
5512
5513        do k = 1,3
5514 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5515 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5516 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5517 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5518 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5519 c     &    dt_dci(k)
5520 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5521 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5522          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5523      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5524          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5525      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5526          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5527      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5528        enddo
5529 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5530 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5531
5532 C to check gradient call subroutine check_grad
5533
5534     1 continue
5535       enddo
5536       return
5537       end
5538 c------------------------------------------------------------------------------
5539       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5540       implicit none
5541       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5542      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5543       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5544      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5545      &   + x(10)*yy*zz
5546       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5547      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5548      & + x(20)*yy*zz
5549       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5550      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5551      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5552      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5553      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5554      &  +x(40)*xx*yy*zz
5555       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5556      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5557      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5558      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5559      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5560      &  +x(60)*xx*yy*zz
5561       dsc_i   = 0.743d0+x(61)
5562       dp2_i   = 1.9d0+x(62)
5563       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5564      &          *(xx*cost2+yy*sint2))
5565       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5566      &          *(xx*cost2-yy*sint2))
5567       s1=(1+x(63))/(0.1d0 + dscp1)
5568       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5569       s2=(1+x(65))/(0.1d0 + dscp2)
5570       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5571       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5572      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5573       enesc=sumene
5574       return
5575       end
5576 #endif
5577 c------------------------------------------------------------------------------
5578       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5579 C
5580 C This procedure calculates two-body contact function g(rij) and its derivative:
5581 C
5582 C           eps0ij                                     !       x < -1
5583 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5584 C            0                                         !       x > 1
5585 C
5586 C where x=(rij-r0ij)/delta
5587 C
5588 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5589 C
5590       implicit none
5591       double precision rij,r0ij,eps0ij,fcont,fprimcont
5592       double precision x,x2,x4,delta
5593 c     delta=0.02D0*r0ij
5594 c      delta=0.2D0*r0ij
5595       x=(rij-r0ij)/delta
5596       if (x.lt.-1.0D0) then
5597         fcont=eps0ij
5598         fprimcont=0.0D0
5599       else if (x.le.1.0D0) then
5600         x2=x*x
5601         x4=x2*x2
5602         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5603         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5604       else
5605         fcont=0.0D0
5606         fprimcont=0.0D0
5607       endif
5608       return
5609       end
5610 c------------------------------------------------------------------------------
5611       subroutine splinthet(theti,delta,ss,ssder)
5612       implicit real*8 (a-h,o-z)
5613       include 'DIMENSIONS'
5614       include 'COMMON.VAR'
5615       include 'COMMON.GEO'
5616       thetup=pi-delta
5617       thetlow=delta
5618       if (theti.gt.pipol) then
5619         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5620       else
5621         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5622         ssder=-ssder
5623       endif
5624       return
5625       end
5626 c------------------------------------------------------------------------------
5627       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5628       implicit none
5629       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5630       double precision ksi,ksi2,ksi3,a1,a2,a3
5631       a1=fprim0*delta/(f1-f0)
5632       a2=3.0d0-2.0d0*a1
5633       a3=a1-2.0d0
5634       ksi=(x-x0)/delta
5635       ksi2=ksi*ksi
5636       ksi3=ksi2*ksi
5637       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5638       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5639       return
5640       end
5641 c------------------------------------------------------------------------------
5642       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5643       implicit none
5644       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5645       double precision ksi,ksi2,ksi3,a1,a2,a3
5646       ksi=(x-x0)/delta
5647       ksi2=ksi*ksi
5648       ksi3=ksi2*ksi
5649       a1=fprim0x*delta
5650       a2=3*(f1x-f0x)-2*fprim0x*delta
5651       a3=fprim0x*delta-2*(f1x-f0x)
5652       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5653       return
5654       end
5655 C-----------------------------------------------------------------------------
5656 #ifdef CRYST_TOR
5657 C-----------------------------------------------------------------------------
5658       subroutine etor(etors,edihcnstr)
5659       implicit real*8 (a-h,o-z)
5660       include 'DIMENSIONS'
5661       include 'COMMON.VAR'
5662       include 'COMMON.GEO'
5663       include 'COMMON.LOCAL'
5664       include 'COMMON.TORSION'
5665       include 'COMMON.INTERACT'
5666       include 'COMMON.DERIV'
5667       include 'COMMON.CHAIN'
5668       include 'COMMON.NAMES'
5669       include 'COMMON.IOUNITS'
5670       include 'COMMON.FFIELD'
5671       include 'COMMON.TORCNSTR'
5672       include 'COMMON.CONTROL'
5673       logical lprn
5674 C Set lprn=.true. for debugging
5675       lprn=.false.
5676 c      lprn=.true.
5677       etors=0.0D0
5678       do i=iphi_start,iphi_end
5679       etors_ii=0.0D0
5680         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5681      &      .or. itype(i).eq.ntyp1) cycle
5682         itori=itortyp(itype(i-2))
5683         itori1=itortyp(itype(i-1))
5684         phii=phi(i)
5685         gloci=0.0D0
5686 C Proline-Proline pair is a special case...
5687         if (itori.eq.3 .and. itori1.eq.3) then
5688           if (phii.gt.-dwapi3) then
5689             cosphi=dcos(3*phii)
5690             fac=1.0D0/(1.0D0-cosphi)
5691             etorsi=v1(1,3,3)*fac
5692             etorsi=etorsi+etorsi
5693             etors=etors+etorsi-v1(1,3,3)
5694             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5695             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5696           endif
5697           do j=1,3
5698             v1ij=v1(j+1,itori,itori1)
5699             v2ij=v2(j+1,itori,itori1)
5700             cosphi=dcos(j*phii)
5701             sinphi=dsin(j*phii)
5702             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5703             if (energy_dec) etors_ii=etors_ii+
5704      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5705             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5706           enddo
5707         else
5708           do j=1,nterm_old
5709             v1ij=v1(j,itori,itori1)
5710             v2ij=v2(j,itori,itori1)
5711             cosphi=dcos(j*phii)
5712             sinphi=dsin(j*phii)
5713             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5714             if (energy_dec) etors_ii=etors_ii+
5715      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5716             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5717           enddo
5718         endif
5719         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5720              'etor',i,etors_ii
5721         if (lprn)
5722      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5723      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5724      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5725         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5726 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5727       enddo
5728 ! 6/20/98 - dihedral angle constraints
5729       edihcnstr=0.0d0
5730       do i=1,ndih_constr
5731         itori=idih_constr(i)
5732         phii=phi(itori)
5733         difi=phii-phi0(i)
5734         if (difi.gt.drange(i)) then
5735           difi=difi-drange(i)
5736           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5737           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5738         else if (difi.lt.-drange(i)) then
5739           difi=difi+drange(i)
5740           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
5741           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5742         endif
5743 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5744 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5745       enddo
5746 !      write (iout,*) 'edihcnstr',edihcnstr
5747       return
5748       end
5749 c------------------------------------------------------------------------------
5750       subroutine etor_d(etors_d)
5751       etors_d=0.0d0
5752       return
5753       end
5754 c----------------------------------------------------------------------------
5755 #else
5756       subroutine etor(etors,edihcnstr)
5757       implicit real*8 (a-h,o-z)
5758       include 'DIMENSIONS'
5759       include 'COMMON.VAR'
5760       include 'COMMON.GEO'
5761       include 'COMMON.LOCAL'
5762       include 'COMMON.TORSION'
5763       include 'COMMON.INTERACT'
5764       include 'COMMON.DERIV'
5765       include 'COMMON.CHAIN'
5766       include 'COMMON.NAMES'
5767       include 'COMMON.IOUNITS'
5768       include 'COMMON.FFIELD'
5769       include 'COMMON.TORCNSTR'
5770       include 'COMMON.CONTROL'
5771       logical lprn
5772 C Set lprn=.true. for debugging
5773       lprn=.false.
5774 c     lprn=.true.
5775       etors=0.0D0
5776       do i=iphi_start,iphi_end
5777         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5778      &       .or. itype(i).eq.ntyp1) cycle
5779         etors_ii=0.0D0
5780          if (iabs(itype(i)).eq.20) then
5781          iblock=2
5782          else
5783          iblock=1
5784          endif
5785         itori=itortyp(itype(i-2))
5786         itori1=itortyp(itype(i-1))
5787         phii=phi(i)
5788         gloci=0.0D0
5789 C Regular cosine and sine terms
5790         do j=1,nterm(itori,itori1,iblock)
5791           v1ij=v1(j,itori,itori1,iblock)
5792           v2ij=v2(j,itori,itori1,iblock)
5793           cosphi=dcos(j*phii)
5794           sinphi=dsin(j*phii)
5795           etors=etors+v1ij*cosphi+v2ij*sinphi
5796           if (energy_dec) etors_ii=etors_ii+
5797      &                v1ij*cosphi+v2ij*sinphi
5798           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5799         enddo
5800 C Lorentz terms
5801 C                         v1
5802 C  E = SUM ----------------------------------- - v1
5803 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5804 C
5805         cosphi=dcos(0.5d0*phii)
5806         sinphi=dsin(0.5d0*phii)
5807         do j=1,nlor(itori,itori1,iblock)
5808           vl1ij=vlor1(j,itori,itori1)
5809           vl2ij=vlor2(j,itori,itori1)
5810           vl3ij=vlor3(j,itori,itori1)
5811           pom=vl2ij*cosphi+vl3ij*sinphi
5812           pom1=1.0d0/(pom*pom+1.0d0)
5813           etors=etors+vl1ij*pom1
5814           if (energy_dec) etors_ii=etors_ii+
5815      &                vl1ij*pom1
5816           pom=-pom*pom1*pom1
5817           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5818         enddo
5819 C Subtract the constant term
5820         etors=etors-v0(itori,itori1,iblock)
5821           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5822      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5823         if (lprn)
5824      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5825      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5826      &  (v1(j,itori,itori1,iblock),j=1,6),
5827      &  (v2(j,itori,itori1,iblock),j=1,6)
5828         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5829 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5830       enddo
5831 ! 6/20/98 - dihedral angle constraints
5832       edihcnstr=0.0d0
5833 c      do i=1,ndih_constr
5834       do i=idihconstr_start,idihconstr_end
5835         itori=idih_constr(i)
5836         phii=phi(itori)
5837         difi=pinorm(phii-phi0(i))
5838         if (difi.gt.drange(i)) then
5839           difi=difi-drange(i)
5840           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5841           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5842         else if (difi.lt.-drange(i)) then
5843           difi=difi+drange(i)
5844           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5845           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5846         else
5847           difi=0.0
5848         endif
5849        if (energy_dec) then
5850         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
5851      &    i,itori,rad2deg*phii,
5852      &    rad2deg*phi0(i),  rad2deg*drange(i),
5853      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5854         endif
5855       enddo
5856 cd       write (iout,*) 'edihcnstr',edihcnstr
5857       return
5858       end
5859 c----------------------------------------------------------------------------
5860       subroutine etor_d(etors_d)
5861 C 6/23/01 Compute double torsional energy
5862       implicit real*8 (a-h,o-z)
5863       include 'DIMENSIONS'
5864       include 'COMMON.VAR'
5865       include 'COMMON.GEO'
5866       include 'COMMON.LOCAL'
5867       include 'COMMON.TORSION'
5868       include 'COMMON.INTERACT'
5869       include 'COMMON.DERIV'
5870       include 'COMMON.CHAIN'
5871       include 'COMMON.NAMES'
5872       include 'COMMON.IOUNITS'
5873       include 'COMMON.FFIELD'
5874       include 'COMMON.TORCNSTR'
5875       logical lprn
5876 C Set lprn=.true. for debugging
5877       lprn=.false.
5878 c     lprn=.true.
5879       etors_d=0.0D0
5880 c      write(iout,*) "a tu??"
5881       do i=iphid_start,iphid_end
5882         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5883      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5884         itori=itortyp(itype(i-2))
5885         itori1=itortyp(itype(i-1))
5886         itori2=itortyp(itype(i))
5887         phii=phi(i)
5888         phii1=phi(i+1)
5889         gloci1=0.0D0
5890         gloci2=0.0D0
5891         iblock=1
5892         if (iabs(itype(i+1)).eq.20) iblock=2
5893
5894 C Regular cosine and sine terms
5895         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5896           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5897           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5898           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5899           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5900           cosphi1=dcos(j*phii)
5901           sinphi1=dsin(j*phii)
5902           cosphi2=dcos(j*phii1)
5903           sinphi2=dsin(j*phii1)
5904           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5905      &     v2cij*cosphi2+v2sij*sinphi2
5906           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5907           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5908         enddo
5909         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5910           do l=1,k-1
5911             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5912             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5913             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5914             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5915             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5916             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5917             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5918             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5919             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5920      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5921             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5922      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5923             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5924      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5925           enddo
5926         enddo
5927         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5928         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5929       enddo
5930       return
5931       end
5932 #endif
5933 c------------------------------------------------------------------------------
5934       subroutine eback_sc_corr(esccor)
5935 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5936 c        conformational states; temporarily implemented as differences
5937 c        between UNRES torsional potentials (dependent on three types of
5938 c        residues) and the torsional potentials dependent on all 20 types
5939 c        of residues computed from AM1  energy surfaces of terminally-blocked
5940 c        amino-acid residues.
5941       implicit real*8 (a-h,o-z)
5942       include 'DIMENSIONS'
5943       include 'COMMON.VAR'
5944       include 'COMMON.GEO'
5945       include 'COMMON.LOCAL'
5946       include 'COMMON.TORSION'
5947       include 'COMMON.SCCOR'
5948       include 'COMMON.INTERACT'
5949       include 'COMMON.DERIV'
5950       include 'COMMON.CHAIN'
5951       include 'COMMON.NAMES'
5952       include 'COMMON.IOUNITS'
5953       include 'COMMON.FFIELD'
5954       include 'COMMON.CONTROL'
5955       logical lprn
5956 C Set lprn=.true. for debugging
5957       lprn=.false.
5958 c      lprn=.true.
5959 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5960       esccor=0.0D0
5961       do i=itau_start,itau_end
5962         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5963         esccor_ii=0.0D0
5964         isccori=isccortyp(itype(i-2))
5965         isccori1=isccortyp(itype(i-1))
5966 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5967         phii=phi(i)
5968         do intertyp=1,3 !intertyp
5969 cc Added 09 May 2012 (Adasko)
5970 cc  Intertyp means interaction type of backbone mainchain correlation:
5971 c   1 = SC...Ca...Ca...Ca
5972 c   2 = Ca...Ca...Ca...SC
5973 c   3 = SC...Ca...Ca...SCi
5974         gloci=0.0D0
5975         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5976      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5977      &      (itype(i-1).eq.ntyp1)))
5978      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5979      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5980      &     .or.(itype(i).eq.ntyp1)))
5981      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5982      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5983      &      (itype(i-3).eq.ntyp1)))) cycle
5984         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5985         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5986      & cycle
5987        do j=1,nterm_sccor(isccori,isccori1)
5988           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5989           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5990           cosphi=dcos(j*tauangle(intertyp,i))
5991           sinphi=dsin(j*tauangle(intertyp,i))
5992           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5993           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5994         enddo
5995 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5996         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5997         if (lprn)
5998      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5999      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6000      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6001      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6002         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6003        enddo !intertyp
6004       enddo
6005
6006       return
6007       end
6008 c----------------------------------------------------------------------------
6009       subroutine multibody(ecorr)
6010 C This subroutine calculates multi-body contributions to energy following
6011 C the idea of Skolnick et al. If side chains I and J make a contact and
6012 C at the same time side chains I+1 and J+1 make a contact, an extra
6013 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6014       implicit real*8 (a-h,o-z)
6015       include 'DIMENSIONS'
6016       include 'COMMON.IOUNITS'
6017       include 'COMMON.DERIV'
6018       include 'COMMON.INTERACT'
6019       include 'COMMON.CONTACTS'
6020       double precision gx(3),gx1(3)
6021       logical lprn
6022
6023 C Set lprn=.true. for debugging
6024       lprn=.false.
6025
6026       if (lprn) then
6027         write (iout,'(a)') 'Contact function values:'
6028         do i=nnt,nct-2
6029           write (iout,'(i2,20(1x,i2,f10.5))')
6030      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6031         enddo
6032       endif
6033       ecorr=0.0D0
6034       do i=nnt,nct
6035         do j=1,3
6036           gradcorr(j,i)=0.0D0
6037           gradxorr(j,i)=0.0D0
6038         enddo
6039       enddo
6040       do i=nnt,nct-2
6041
6042         DO ISHIFT = 3,4
6043
6044         i1=i+ishift
6045         num_conti=num_cont(i)
6046         num_conti1=num_cont(i1)
6047         do jj=1,num_conti
6048           j=jcont(jj,i)
6049           do kk=1,num_conti1
6050             j1=jcont(kk,i1)
6051             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6052 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6053 cd   &                   ' ishift=',ishift
6054 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6055 C The system gains extra energy.
6056               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6057             endif   ! j1==j+-ishift
6058           enddo     ! kk
6059         enddo       ! jj
6060
6061         ENDDO ! ISHIFT
6062
6063       enddo         ! i
6064       return
6065       end
6066 c------------------------------------------------------------------------------
6067       double precision function esccorr(i,j,k,l,jj,kk)
6068       implicit real*8 (a-h,o-z)
6069       include 'DIMENSIONS'
6070       include 'COMMON.IOUNITS'
6071       include 'COMMON.DERIV'
6072       include 'COMMON.INTERACT'
6073       include 'COMMON.CONTACTS'
6074       double precision gx(3),gx1(3)
6075       logical lprn
6076       lprn=.false.
6077       eij=facont(jj,i)
6078       ekl=facont(kk,k)
6079 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6080 C Calculate the multi-body contribution to energy.
6081 C Calculate multi-body contributions to the gradient.
6082 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6083 cd   & k,l,(gacont(m,kk,k),m=1,3)
6084       do m=1,3
6085         gx(m) =ekl*gacont(m,jj,i)
6086         gx1(m)=eij*gacont(m,kk,k)
6087         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6088         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6089         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6090         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6091       enddo
6092       do m=i,j-1
6093         do ll=1,3
6094           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6095         enddo
6096       enddo
6097       do m=k,l-1
6098         do ll=1,3
6099           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6100         enddo
6101       enddo
6102       esccorr=-eij*ekl
6103       return
6104       end
6105 c------------------------------------------------------------------------------
6106       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6107 C This subroutine calculates multi-body contributions to hydrogen-bonding
6108       implicit real*8 (a-h,o-z)
6109       include 'DIMENSIONS'
6110       include 'COMMON.IOUNITS'
6111 #ifdef MPI
6112       include "mpif.h"
6113       parameter (max_cont=maxconts)
6114       parameter (max_dim=26)
6115       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6116       double precision zapas(max_dim,maxconts,max_fg_procs),
6117      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6118       common /przechowalnia/ zapas
6119       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6120      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6121 #endif
6122       include 'COMMON.SETUP'
6123       include 'COMMON.FFIELD'
6124       include 'COMMON.DERIV'
6125       include 'COMMON.INTERACT'
6126       include 'COMMON.CONTACTS'
6127       include 'COMMON.CONTROL'
6128       include 'COMMON.LOCAL'
6129       double precision gx(3),gx1(3),time00
6130       logical lprn,ldone
6131
6132 C Set lprn=.true. for debugging
6133       lprn=.false.
6134 #ifdef MPI
6135       n_corr=0
6136       n_corr1=0
6137       if (nfgtasks.le.1) goto 30
6138       if (lprn) then
6139         write (iout,'(a)') 'Contact function values before RECEIVE:'
6140         do i=nnt,nct-2
6141           write (iout,'(2i3,50(1x,i2,f5.2))')
6142      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6143      &    j=1,num_cont_hb(i))
6144         enddo
6145       endif
6146       call flush(iout)
6147       do i=1,ntask_cont_from
6148         ncont_recv(i)=0
6149       enddo
6150       do i=1,ntask_cont_to
6151         ncont_sent(i)=0
6152       enddo
6153 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6154 c     & ntask_cont_to
6155 C Make the list of contacts to send to send to other procesors
6156 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6157 c      call flush(iout)
6158       do i=iturn3_start,iturn3_end
6159 c        write (iout,*) "make contact list turn3",i," num_cont",
6160 c     &    num_cont_hb(i)
6161         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6162       enddo
6163       do i=iturn4_start,iturn4_end
6164 c        write (iout,*) "make contact list turn4",i," num_cont",
6165 c     &   num_cont_hb(i)
6166         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6167       enddo
6168       do ii=1,nat_sent
6169         i=iat_sent(ii)
6170 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6171 c     &    num_cont_hb(i)
6172         do j=1,num_cont_hb(i)
6173         do k=1,4
6174           jjc=jcont_hb(j,i)
6175           iproc=iint_sent_local(k,jjc,ii)
6176 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6177           if (iproc.gt.0) then
6178             ncont_sent(iproc)=ncont_sent(iproc)+1
6179             nn=ncont_sent(iproc)
6180             zapas(1,nn,iproc)=i
6181             zapas(2,nn,iproc)=jjc
6182             zapas(3,nn,iproc)=facont_hb(j,i)
6183             zapas(4,nn,iproc)=ees0p(j,i)
6184             zapas(5,nn,iproc)=ees0m(j,i)
6185             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6186             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6187             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6188             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6189             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6190             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6191             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6192             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6193             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6194             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6195             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6196             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6197             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6198             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6199             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6200             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6201             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6202             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6203             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6204             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6205             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6206           endif
6207         enddo
6208         enddo
6209       enddo
6210       if (lprn) then
6211       write (iout,*)
6212      &  "Numbers of contacts to be sent to other processors",
6213      &  (ncont_sent(i),i=1,ntask_cont_to)
6214       write (iout,*) "Contacts sent"
6215       do ii=1,ntask_cont_to
6216         nn=ncont_sent(ii)
6217         iproc=itask_cont_to(ii)
6218         write (iout,*) nn," contacts to processor",iproc,
6219      &   " of CONT_TO_COMM group"
6220         do i=1,nn
6221           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6222         enddo
6223       enddo
6224       call flush(iout)
6225       endif
6226       CorrelType=477
6227       CorrelID=fg_rank+1
6228       CorrelType1=478
6229       CorrelID1=nfgtasks+fg_rank+1
6230       ireq=0
6231 C Receive the numbers of needed contacts from other processors
6232       do ii=1,ntask_cont_from
6233         iproc=itask_cont_from(ii)
6234         ireq=ireq+1
6235         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6236      &    FG_COMM,req(ireq),IERR)
6237       enddo
6238 c      write (iout,*) "IRECV ended"
6239 c      call flush(iout)
6240 C Send the number of contacts needed by other processors
6241       do ii=1,ntask_cont_to
6242         iproc=itask_cont_to(ii)
6243         ireq=ireq+1
6244         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6245      &    FG_COMM,req(ireq),IERR)
6246       enddo
6247 c      write (iout,*) "ISEND ended"
6248 c      write (iout,*) "number of requests (nn)",ireq
6249       call flush(iout)
6250       if (ireq.gt.0)
6251      &  call MPI_Waitall(ireq,req,status_array,ierr)
6252 c      write (iout,*)
6253 c     &  "Numbers of contacts to be received from other processors",
6254 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6255 c      call flush(iout)
6256 C Receive contacts
6257       ireq=0
6258       do ii=1,ntask_cont_from
6259         iproc=itask_cont_from(ii)
6260         nn=ncont_recv(ii)
6261 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6262 c     &   " of CONT_TO_COMM group"
6263         call flush(iout)
6264         if (nn.gt.0) then
6265           ireq=ireq+1
6266           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6267      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6268 c          write (iout,*) "ireq,req",ireq,req(ireq)
6269         endif
6270       enddo
6271 C Send the contacts to processors that need them
6272       do ii=1,ntask_cont_to
6273         iproc=itask_cont_to(ii)
6274         nn=ncont_sent(ii)
6275 c        write (iout,*) nn," contacts to processor",iproc,
6276 c     &   " of CONT_TO_COMM group"
6277         if (nn.gt.0) then
6278           ireq=ireq+1
6279           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6280      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6281 c          write (iout,*) "ireq,req",ireq,req(ireq)
6282 c          do i=1,nn
6283 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6284 c          enddo
6285         endif
6286       enddo
6287 c      write (iout,*) "number of requests (contacts)",ireq
6288 c      write (iout,*) "req",(req(i),i=1,4)
6289 c      call flush(iout)
6290       if (ireq.gt.0)
6291      & call MPI_Waitall(ireq,req,status_array,ierr)
6292       do iii=1,ntask_cont_from
6293         iproc=itask_cont_from(iii)
6294         nn=ncont_recv(iii)
6295         if (lprn) then
6296         write (iout,*) "Received",nn," contacts from processor",iproc,
6297      &   " of CONT_FROM_COMM group"
6298         call flush(iout)
6299         do i=1,nn
6300           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6301         enddo
6302         call flush(iout)
6303         endif
6304         do i=1,nn
6305           ii=zapas_recv(1,i,iii)
6306 c Flag the received contacts to prevent double-counting
6307           jj=-zapas_recv(2,i,iii)
6308 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6309 c          call flush(iout)
6310           nnn=num_cont_hb(ii)+1
6311           num_cont_hb(ii)=nnn
6312           jcont_hb(nnn,ii)=jj
6313           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6314           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6315           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6316           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6317           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6318           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6319           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6320           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6321           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6322           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6323           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6324           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6325           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6326           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6327           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6328           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6329           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6330           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6331           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6332           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6333           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6334           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6335           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6336           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6337         enddo
6338       enddo
6339       call flush(iout)
6340       if (lprn) then
6341         write (iout,'(a)') 'Contact function values after receive:'
6342         do i=nnt,nct-2
6343           write (iout,'(2i3,50(1x,i3,f5.2))')
6344      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6345      &    j=1,num_cont_hb(i))
6346         enddo
6347         call flush(iout)
6348       endif
6349    30 continue
6350 #endif
6351       if (lprn) then
6352         write (iout,'(a)') 'Contact function values:'
6353         do i=nnt,nct-2
6354           write (iout,'(2i3,50(1x,i3,f5.2))')
6355      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6356      &    j=1,num_cont_hb(i))
6357         enddo
6358       endif
6359       ecorr=0.0D0
6360 C Remove the loop below after debugging !!!
6361       do i=nnt,nct
6362         do j=1,3
6363           gradcorr(j,i)=0.0D0
6364           gradxorr(j,i)=0.0D0
6365         enddo
6366       enddo
6367 C Calculate the local-electrostatic correlation terms
6368       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6369         i1=i+1
6370         num_conti=num_cont_hb(i)
6371         num_conti1=num_cont_hb(i+1)
6372         do jj=1,num_conti
6373           j=jcont_hb(jj,i)
6374           jp=iabs(j)
6375           do kk=1,num_conti1
6376             j1=jcont_hb(kk,i1)
6377             jp1=iabs(j1)
6378 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6379 c     &         ' jj=',jj,' kk=',kk
6380             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6381      &          .or. j.lt.0 .and. j1.gt.0) .and.
6382      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6383 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6384 C The system gains extra energy.
6385               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6386               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6387      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6388               n_corr=n_corr+1
6389             else if (j1.eq.j) then
6390 C Contacts I-J and I-(J+1) occur simultaneously.
6391 C The system loses extra energy.
6392 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6393             endif
6394           enddo ! kk
6395           do kk=1,num_conti
6396             j1=jcont_hb(kk,i)
6397 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6398 c    &         ' jj=',jj,' kk=',kk
6399             if (j1.eq.j+1) then
6400 C Contacts I-J and (I+1)-J occur simultaneously.
6401 C The system loses extra energy.
6402 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6403             endif ! j1==j+1
6404           enddo ! kk
6405         enddo ! jj
6406       enddo ! i
6407       return
6408       end
6409 c------------------------------------------------------------------------------
6410       subroutine add_hb_contact(ii,jj,itask)
6411       implicit real*8 (a-h,o-z)
6412       include "DIMENSIONS"
6413       include "COMMON.IOUNITS"
6414       integer max_cont
6415       integer max_dim
6416       parameter (max_cont=maxconts)
6417       parameter (max_dim=26)
6418       include "COMMON.CONTACTS"
6419       double precision zapas(max_dim,maxconts,max_fg_procs),
6420      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6421       common /przechowalnia/ zapas
6422       integer i,j,ii,jj,iproc,itask(4),nn
6423 c      write (iout,*) "itask",itask
6424       do i=1,2
6425         iproc=itask(i)
6426         if (iproc.gt.0) then
6427           do j=1,num_cont_hb(ii)
6428             jjc=jcont_hb(j,ii)
6429 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6430             if (jjc.eq.jj) then
6431               ncont_sent(iproc)=ncont_sent(iproc)+1
6432               nn=ncont_sent(iproc)
6433               zapas(1,nn,iproc)=ii
6434               zapas(2,nn,iproc)=jjc
6435               zapas(3,nn,iproc)=facont_hb(j,ii)
6436               zapas(4,nn,iproc)=ees0p(j,ii)
6437               zapas(5,nn,iproc)=ees0m(j,ii)
6438               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6439               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6440               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6441               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6442               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6443               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6444               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6445               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6446               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6447               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6448               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6449               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6450               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6451               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6452               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6453               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6454               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6455               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6456               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6457               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6458               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6459               exit
6460             endif
6461           enddo
6462         endif
6463       enddo
6464       return
6465       end
6466 c------------------------------------------------------------------------------
6467       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6468      &  n_corr1)
6469 C This subroutine calculates multi-body contributions to hydrogen-bonding
6470       implicit real*8 (a-h,o-z)
6471       include 'DIMENSIONS'
6472       include 'COMMON.IOUNITS'
6473 #ifdef MPI
6474       include "mpif.h"
6475       parameter (max_cont=maxconts)
6476       parameter (max_dim=70)
6477       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6478       double precision zapas(max_dim,maxconts,max_fg_procs),
6479      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6480       common /przechowalnia/ zapas
6481       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6482      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6483 #endif
6484       include 'COMMON.SETUP'
6485       include 'COMMON.FFIELD'
6486       include 'COMMON.DERIV'
6487       include 'COMMON.LOCAL'
6488       include 'COMMON.INTERACT'
6489       include 'COMMON.CONTACTS'
6490       include 'COMMON.CHAIN'
6491       include 'COMMON.CONTROL'
6492       double precision gx(3),gx1(3)
6493       integer num_cont_hb_old(maxres)
6494       logical lprn,ldone
6495       double precision eello4,eello5,eelo6,eello_turn6
6496       external eello4,eello5,eello6,eello_turn6
6497 C Set lprn=.true. for debugging
6498       lprn=.false.
6499       eturn6=0.0d0
6500 #ifdef MPI
6501       do i=1,nres
6502         num_cont_hb_old(i)=num_cont_hb(i)
6503       enddo
6504       n_corr=0
6505       n_corr1=0
6506       if (nfgtasks.le.1) goto 30
6507       if (lprn) then
6508         write (iout,'(a)') 'Contact function values before RECEIVE:'
6509         do i=nnt,nct-2
6510           write (iout,'(2i3,50(1x,i2,f5.2))')
6511      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6512      &    j=1,num_cont_hb(i))
6513         enddo
6514       endif
6515       call flush(iout)
6516       do i=1,ntask_cont_from
6517         ncont_recv(i)=0
6518       enddo
6519       do i=1,ntask_cont_to
6520         ncont_sent(i)=0
6521       enddo
6522 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6523 c     & ntask_cont_to
6524 C Make the list of contacts to send to send to other procesors
6525       do i=iturn3_start,iturn3_end
6526 c        write (iout,*) "make contact list turn3",i," num_cont",
6527 c     &    num_cont_hb(i)
6528         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6529       enddo
6530       do i=iturn4_start,iturn4_end
6531 c        write (iout,*) "make contact list turn4",i," num_cont",
6532 c     &   num_cont_hb(i)
6533         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6534       enddo
6535       do ii=1,nat_sent
6536         i=iat_sent(ii)
6537 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6538 c     &    num_cont_hb(i)
6539         do j=1,num_cont_hb(i)
6540         do k=1,4
6541           jjc=jcont_hb(j,i)
6542           iproc=iint_sent_local(k,jjc,ii)
6543 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6544           if (iproc.ne.0) then
6545             ncont_sent(iproc)=ncont_sent(iproc)+1
6546             nn=ncont_sent(iproc)
6547             zapas(1,nn,iproc)=i
6548             zapas(2,nn,iproc)=jjc
6549             zapas(3,nn,iproc)=d_cont(j,i)
6550             ind=3
6551             do kk=1,3
6552               ind=ind+1
6553               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6554             enddo
6555             do kk=1,2
6556               do ll=1,2
6557                 ind=ind+1
6558                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6559               enddo
6560             enddo
6561             do jj=1,5
6562               do kk=1,3
6563                 do ll=1,2
6564                   do mm=1,2
6565                     ind=ind+1
6566                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6567                   enddo
6568                 enddo
6569               enddo
6570             enddo
6571           endif
6572         enddo
6573         enddo
6574       enddo
6575       if (lprn) then
6576       write (iout,*)
6577      &  "Numbers of contacts to be sent to other processors",
6578      &  (ncont_sent(i),i=1,ntask_cont_to)
6579       write (iout,*) "Contacts sent"
6580       do ii=1,ntask_cont_to
6581         nn=ncont_sent(ii)
6582         iproc=itask_cont_to(ii)
6583         write (iout,*) nn," contacts to processor",iproc,
6584      &   " of CONT_TO_COMM group"
6585         do i=1,nn
6586           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6587         enddo
6588       enddo
6589       call flush(iout)
6590       endif
6591       CorrelType=477
6592       CorrelID=fg_rank+1
6593       CorrelType1=478
6594       CorrelID1=nfgtasks+fg_rank+1
6595       ireq=0
6596 C Receive the numbers of needed contacts from other processors
6597       do ii=1,ntask_cont_from
6598         iproc=itask_cont_from(ii)
6599         ireq=ireq+1
6600         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6601      &    FG_COMM,req(ireq),IERR)
6602       enddo
6603 c      write (iout,*) "IRECV ended"
6604 c      call flush(iout)
6605 C Send the number of contacts needed by other processors
6606       do ii=1,ntask_cont_to
6607         iproc=itask_cont_to(ii)
6608         ireq=ireq+1
6609         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6610      &    FG_COMM,req(ireq),IERR)
6611       enddo
6612 c      write (iout,*) "ISEND ended"
6613 c      write (iout,*) "number of requests (nn)",ireq
6614       call flush(iout)
6615       if (ireq.gt.0)
6616      &  call MPI_Waitall(ireq,req,status_array,ierr)
6617 c      write (iout,*)
6618 c     &  "Numbers of contacts to be received from other processors",
6619 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6620 c      call flush(iout)
6621 C Receive contacts
6622       ireq=0
6623       do ii=1,ntask_cont_from
6624         iproc=itask_cont_from(ii)
6625         nn=ncont_recv(ii)
6626 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6627 c     &   " of CONT_TO_COMM group"
6628         call flush(iout)
6629         if (nn.gt.0) then
6630           ireq=ireq+1
6631           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6632      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6633 c          write (iout,*) "ireq,req",ireq,req(ireq)
6634         endif
6635       enddo
6636 C Send the contacts to processors that need them
6637       do ii=1,ntask_cont_to
6638         iproc=itask_cont_to(ii)
6639         nn=ncont_sent(ii)
6640 c        write (iout,*) nn," contacts to processor",iproc,
6641 c     &   " of CONT_TO_COMM group"
6642         if (nn.gt.0) then
6643           ireq=ireq+1
6644           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6645      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6646 c          write (iout,*) "ireq,req",ireq,req(ireq)
6647 c          do i=1,nn
6648 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6649 c          enddo
6650         endif
6651       enddo
6652 c      write (iout,*) "number of requests (contacts)",ireq
6653 c      write (iout,*) "req",(req(i),i=1,4)
6654 c      call flush(iout)
6655       if (ireq.gt.0)
6656      & call MPI_Waitall(ireq,req,status_array,ierr)
6657       do iii=1,ntask_cont_from
6658         iproc=itask_cont_from(iii)
6659         nn=ncont_recv(iii)
6660         if (lprn) then
6661         write (iout,*) "Received",nn," contacts from processor",iproc,
6662      &   " of CONT_FROM_COMM group"
6663         call flush(iout)
6664         do i=1,nn
6665           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6666         enddo
6667         call flush(iout)
6668         endif
6669         do i=1,nn
6670           ii=zapas_recv(1,i,iii)
6671 c Flag the received contacts to prevent double-counting
6672           jj=-zapas_recv(2,i,iii)
6673 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6674 c          call flush(iout)
6675           nnn=num_cont_hb(ii)+1
6676           num_cont_hb(ii)=nnn
6677           jcont_hb(nnn,ii)=jj
6678           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6679           ind=3
6680           do kk=1,3
6681             ind=ind+1
6682             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6683           enddo
6684           do kk=1,2
6685             do ll=1,2
6686               ind=ind+1
6687               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6688             enddo
6689           enddo
6690           do jj=1,5
6691             do kk=1,3
6692               do ll=1,2
6693                 do mm=1,2
6694                   ind=ind+1
6695                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6696                 enddo
6697               enddo
6698             enddo
6699           enddo
6700         enddo
6701       enddo
6702       call flush(iout)
6703       if (lprn) then
6704         write (iout,'(a)') 'Contact function values after receive:'
6705         do i=nnt,nct-2
6706           write (iout,'(2i3,50(1x,i3,5f6.3))')
6707      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6708      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6709         enddo
6710         call flush(iout)
6711       endif
6712    30 continue
6713 #endif
6714       if (lprn) then
6715         write (iout,'(a)') 'Contact function values:'
6716         do i=nnt,nct-2
6717           write (iout,'(2i3,50(1x,i2,5f6.3))')
6718      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6719      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6720         enddo
6721       endif
6722       ecorr=0.0D0
6723       ecorr5=0.0d0
6724       ecorr6=0.0d0
6725 C Remove the loop below after debugging !!!
6726       do i=nnt,nct
6727         do j=1,3
6728           gradcorr(j,i)=0.0D0
6729           gradxorr(j,i)=0.0D0
6730         enddo
6731       enddo
6732 C Calculate the dipole-dipole interaction energies
6733       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6734       do i=iatel_s,iatel_e+1
6735         num_conti=num_cont_hb(i)
6736         do jj=1,num_conti
6737           j=jcont_hb(jj,i)
6738 #ifdef MOMENT
6739           call dipole(i,j,jj)
6740 #endif
6741         enddo
6742       enddo
6743       endif
6744 C Calculate the local-electrostatic correlation terms
6745 c                write (iout,*) "gradcorr5 in eello5 before loop"
6746 c                do iii=1,nres
6747 c                  write (iout,'(i5,3f10.5)')
6748 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6749 c                enddo
6750       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6751 c        write (iout,*) "corr loop i",i
6752         i1=i+1
6753         num_conti=num_cont_hb(i)
6754         num_conti1=num_cont_hb(i+1)
6755         do jj=1,num_conti
6756           j=jcont_hb(jj,i)
6757           jp=iabs(j)
6758           do kk=1,num_conti1
6759             j1=jcont_hb(kk,i1)
6760             jp1=iabs(j1)
6761 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6762 c     &         ' jj=',jj,' kk=',kk
6763 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6764             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6765      &          .or. j.lt.0 .and. j1.gt.0) .and.
6766      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6767 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6768 C The system gains extra energy.
6769               n_corr=n_corr+1
6770               sqd1=dsqrt(d_cont(jj,i))
6771               sqd2=dsqrt(d_cont(kk,i1))
6772               sred_geom = sqd1*sqd2
6773               IF (sred_geom.lt.cutoff_corr) THEN
6774                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6775      &            ekont,fprimcont)
6776 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6777 cd     &         ' jj=',jj,' kk=',kk
6778                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6779                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6780                 do l=1,3
6781                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6782                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6783                 enddo
6784                 n_corr1=n_corr1+1
6785 cd               write (iout,*) 'sred_geom=',sred_geom,
6786 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6787 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6788 cd               write (iout,*) "g_contij",g_contij
6789 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6790 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6791                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6792                 if (wcorr4.gt.0.0d0)
6793      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6794                   if (energy_dec.and.wcorr4.gt.0.0d0)
6795      1                 write (iout,'(a6,4i5,0pf7.3)')
6796      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6797 c                write (iout,*) "gradcorr5 before eello5"
6798 c                do iii=1,nres
6799 c                  write (iout,'(i5,3f10.5)')
6800 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6801 c                enddo
6802                 if (wcorr5.gt.0.0d0)
6803      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6804 c                write (iout,*) "gradcorr5 after eello5"
6805 c                do iii=1,nres
6806 c                  write (iout,'(i5,3f10.5)')
6807 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6808 c                enddo
6809                   if (energy_dec.and.wcorr5.gt.0.0d0)
6810      1                 write (iout,'(a6,4i5,0pf7.3)')
6811      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6812 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6813 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6814                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6815      &               .or. wturn6.eq.0.0d0))then
6816 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6817                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6818                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6819      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6820 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6821 cd     &            'ecorr6=',ecorr6
6822 cd                write (iout,'(4e15.5)') sred_geom,
6823 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6824 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6825 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6826                 else if (wturn6.gt.0.0d0
6827      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6828 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6829                   eturn6=eturn6+eello_turn6(i,jj,kk)
6830                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6831      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6832 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6833                 endif
6834               ENDIF
6835 1111          continue
6836             endif
6837           enddo ! kk
6838         enddo ! jj
6839       enddo ! i
6840       do i=1,nres
6841         num_cont_hb(i)=num_cont_hb_old(i)
6842       enddo
6843 c                write (iout,*) "gradcorr5 in eello5"
6844 c                do iii=1,nres
6845 c                  write (iout,'(i5,3f10.5)')
6846 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6847 c                enddo
6848       return
6849       end
6850 c------------------------------------------------------------------------------
6851       subroutine add_hb_contact_eello(ii,jj,itask)
6852       implicit real*8 (a-h,o-z)
6853       include "DIMENSIONS"
6854       include "COMMON.IOUNITS"
6855       integer max_cont
6856       integer max_dim
6857       parameter (max_cont=maxconts)
6858       parameter (max_dim=70)
6859       include "COMMON.CONTACTS"
6860       double precision zapas(max_dim,maxconts,max_fg_procs),
6861      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6862       common /przechowalnia/ zapas
6863       integer i,j,ii,jj,iproc,itask(4),nn
6864 c      write (iout,*) "itask",itask
6865       do i=1,2
6866         iproc=itask(i)
6867         if (iproc.gt.0) then
6868           do j=1,num_cont_hb(ii)
6869             jjc=jcont_hb(j,ii)
6870 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6871             if (jjc.eq.jj) then
6872               ncont_sent(iproc)=ncont_sent(iproc)+1
6873               nn=ncont_sent(iproc)
6874               zapas(1,nn,iproc)=ii
6875               zapas(2,nn,iproc)=jjc
6876               zapas(3,nn,iproc)=d_cont(j,ii)
6877               ind=3
6878               do kk=1,3
6879                 ind=ind+1
6880                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6881               enddo
6882               do kk=1,2
6883                 do ll=1,2
6884                   ind=ind+1
6885                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6886                 enddo
6887               enddo
6888               do jj=1,5
6889                 do kk=1,3
6890                   do ll=1,2
6891                     do mm=1,2
6892                       ind=ind+1
6893                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6894                     enddo
6895                   enddo
6896                 enddo
6897               enddo
6898               exit
6899             endif
6900           enddo
6901         endif
6902       enddo
6903       return
6904       end
6905 c------------------------------------------------------------------------------
6906       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6907       implicit real*8 (a-h,o-z)
6908       include 'DIMENSIONS'
6909       include 'COMMON.IOUNITS'
6910       include 'COMMON.DERIV'
6911       include 'COMMON.INTERACT'
6912       include 'COMMON.CONTACTS'
6913       double precision gx(3),gx1(3)
6914       logical lprn
6915       lprn=.false.
6916       eij=facont_hb(jj,i)
6917       ekl=facont_hb(kk,k)
6918       ees0pij=ees0p(jj,i)
6919       ees0pkl=ees0p(kk,k)
6920       ees0mij=ees0m(jj,i)
6921       ees0mkl=ees0m(kk,k)
6922       ekont=eij*ekl
6923       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6924 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6925 C Following 4 lines for diagnostics.
6926 cd    ees0pkl=0.0D0
6927 cd    ees0pij=1.0D0
6928 cd    ees0mkl=0.0D0
6929 cd    ees0mij=1.0D0
6930 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6931 c     & 'Contacts ',i,j,
6932 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6933 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6934 c     & 'gradcorr_long'
6935 C Calculate the multi-body contribution to energy.
6936 c      ecorr=ecorr+ekont*ees
6937 C Calculate multi-body contributions to the gradient.
6938       coeffpees0pij=coeffp*ees0pij
6939       coeffmees0mij=coeffm*ees0mij
6940       coeffpees0pkl=coeffp*ees0pkl
6941       coeffmees0mkl=coeffm*ees0mkl
6942       do ll=1,3
6943 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6944         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6945      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6946      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6947         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6948      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6949      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6950 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6951         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6952      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6953      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6954         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6955      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6956      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6957         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6958      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6959      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6960         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6961         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6962         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6963      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6964      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6965         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6966         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6967 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6968       enddo
6969 c      write (iout,*)
6970 cgrad      do m=i+1,j-1
6971 cgrad        do ll=1,3
6972 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6973 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6974 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6975 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6976 cgrad        enddo
6977 cgrad      enddo
6978 cgrad      do m=k+1,l-1
6979 cgrad        do ll=1,3
6980 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6981 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6982 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6983 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6984 cgrad        enddo
6985 cgrad      enddo
6986 c      write (iout,*) "ehbcorr",ekont*ees
6987       ehbcorr=ekont*ees
6988       return
6989       end
6990 #ifdef MOMENT
6991 C---------------------------------------------------------------------------
6992       subroutine dipole(i,j,jj)
6993       implicit real*8 (a-h,o-z)
6994       include 'DIMENSIONS'
6995       include 'COMMON.IOUNITS'
6996       include 'COMMON.CHAIN'
6997       include 'COMMON.FFIELD'
6998       include 'COMMON.DERIV'
6999       include 'COMMON.INTERACT'
7000       include 'COMMON.CONTACTS'
7001       include 'COMMON.TORSION'
7002       include 'COMMON.VAR'
7003       include 'COMMON.GEO'
7004       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7005      &  auxmat(2,2)
7006       iti1 = itortyp(itype(i+1))
7007       if (j.lt.nres-1) then
7008         itj1 = itortyp(itype(j+1))
7009       else
7010         itj1=ntortyp+1
7011       endif
7012       do iii=1,2
7013         dipi(iii,1)=Ub2(iii,i)
7014         dipderi(iii)=Ub2der(iii,i)
7015         dipi(iii,2)=b1(iii,iti1)
7016         dipj(iii,1)=Ub2(iii,j)
7017         dipderj(iii)=Ub2der(iii,j)
7018         dipj(iii,2)=b1(iii,itj1)
7019       enddo
7020       kkk=0
7021       do iii=1,2
7022         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7023         do jjj=1,2
7024           kkk=kkk+1
7025           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7026         enddo
7027       enddo
7028       do kkk=1,5
7029         do lll=1,3
7030           mmm=0
7031           do iii=1,2
7032             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7033      &        auxvec(1))
7034             do jjj=1,2
7035               mmm=mmm+1
7036               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7037             enddo
7038           enddo
7039         enddo
7040       enddo
7041       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7042       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7043       do iii=1,2
7044         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7045       enddo
7046       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7047       do iii=1,2
7048         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7049       enddo
7050       return
7051       end
7052 #endif
7053 C---------------------------------------------------------------------------
7054       subroutine calc_eello(i,j,k,l,jj,kk)
7055 C
7056 C This subroutine computes matrices and vectors needed to calculate
7057 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7058 C
7059       implicit real*8 (a-h,o-z)
7060       include 'DIMENSIONS'
7061       include 'COMMON.IOUNITS'
7062       include 'COMMON.CHAIN'
7063       include 'COMMON.DERIV'
7064       include 'COMMON.INTERACT'
7065       include 'COMMON.CONTACTS'
7066       include 'COMMON.TORSION'
7067       include 'COMMON.VAR'
7068       include 'COMMON.GEO'
7069       include 'COMMON.FFIELD'
7070       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7071      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7072       logical lprn
7073       common /kutas/ lprn
7074 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7075 cd     & ' jj=',jj,' kk=',kk
7076 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7077 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7078 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7079       do iii=1,2
7080         do jjj=1,2
7081           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7082           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7083         enddo
7084       enddo
7085       call transpose2(aa1(1,1),aa1t(1,1))
7086       call transpose2(aa2(1,1),aa2t(1,1))
7087       do kkk=1,5
7088         do lll=1,3
7089           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7090      &      aa1tder(1,1,lll,kkk))
7091           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7092      &      aa2tder(1,1,lll,kkk))
7093         enddo
7094       enddo
7095       if (l.eq.j+1) then
7096 C parallel orientation of the two CA-CA-CA frames.
7097         if (i.gt.1) then
7098           iti=itortyp(itype(i))
7099         else
7100           iti=ntortyp+1
7101         endif
7102         itk1=itortyp(itype(k+1))
7103         itj=itortyp(itype(j))
7104         if (l.lt.nres-1) then
7105           itl1=itortyp(itype(l+1))
7106         else
7107           itl1=ntortyp+1
7108         endif
7109 C A1 kernel(j+1) A2T
7110 cd        do iii=1,2
7111 cd          write (iout,'(3f10.5,5x,3f10.5)')
7112 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7113 cd        enddo
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7116      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7117 C Following matrices are needed only for 6-th order cumulants
7118         IF (wcorr6.gt.0.0d0) THEN
7119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7120      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7121      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7122         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7123      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7124      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7125      &   ADtEAderx(1,1,1,1,1,1))
7126         lprn=.false.
7127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7128      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7129      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7130      &   ADtEA1derx(1,1,1,1,1,1))
7131         ENDIF
7132 C End 6-th order cumulants
7133 cd        lprn=.false.
7134 cd        if (lprn) then
7135 cd        write (2,*) 'In calc_eello6'
7136 cd        do iii=1,2
7137 cd          write (2,*) 'iii=',iii
7138 cd          do kkk=1,5
7139 cd            write (2,*) 'kkk=',kkk
7140 cd            do jjj=1,2
7141 cd              write (2,'(3(2f10.5),5x)')
7142 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7143 cd            enddo
7144 cd          enddo
7145 cd        enddo
7146 cd        endif
7147         call transpose2(EUgder(1,1,k),auxmat(1,1))
7148         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7149         call transpose2(EUg(1,1,k),auxmat(1,1))
7150         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7151         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7156      &          EAEAderx(1,1,lll,kkk,iii,1))
7157             enddo
7158           enddo
7159         enddo
7160 C A1T kernel(i+1) A2
7161         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7162      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7163      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7164 C Following matrices are needed only for 6-th order cumulants
7165         IF (wcorr6.gt.0.0d0) THEN
7166         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7167      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7168      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7170      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7171      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7172      &   ADtEAderx(1,1,1,1,1,2))
7173         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7174      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7175      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7176      &   ADtEA1derx(1,1,1,1,1,2))
7177         ENDIF
7178 C End 6-th order cumulants
7179         call transpose2(EUgder(1,1,l),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7181         call transpose2(EUg(1,1,l),auxmat(1,1))
7182         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7183         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7184         do iii=1,2
7185           do kkk=1,5
7186             do lll=1,3
7187               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7188      &          EAEAderx(1,1,lll,kkk,iii,2))
7189             enddo
7190           enddo
7191         enddo
7192 C AEAb1 and AEAb2
7193 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7194 C They are needed only when the fifth- or the sixth-order cumulants are
7195 C indluded.
7196         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7197         call transpose2(AEA(1,1,1),auxmat(1,1))
7198         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7200         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7201         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7202         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7203         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7204         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7205         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7206         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7207         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7208         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7209         call transpose2(AEA(1,1,2),auxmat(1,1))
7210         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7212         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7213         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7214         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7215         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7216         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7217         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7218         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7219         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7220         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7221 C Calculate the Cartesian derivatives of the vectors.
7222         do iii=1,2
7223           do kkk=1,5
7224             do lll=1,3
7225               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7226               call matvec2(auxmat(1,1),b1(1,iti),
7227      &          AEAb1derx(1,lll,kkk,iii,1,1))
7228               call matvec2(auxmat(1,1),Ub2(1,i),
7229      &          AEAb2derx(1,lll,kkk,iii,1,1))
7230               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7231      &          AEAb1derx(1,lll,kkk,iii,2,1))
7232               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7233      &          AEAb2derx(1,lll,kkk,iii,2,1))
7234               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7235               call matvec2(auxmat(1,1),b1(1,itj),
7236      &          AEAb1derx(1,lll,kkk,iii,1,2))
7237               call matvec2(auxmat(1,1),Ub2(1,j),
7238      &          AEAb2derx(1,lll,kkk,iii,1,2))
7239               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7240      &          AEAb1derx(1,lll,kkk,iii,2,2))
7241               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7242      &          AEAb2derx(1,lll,kkk,iii,2,2))
7243             enddo
7244           enddo
7245         enddo
7246         ENDIF
7247 C End vectors
7248       else
7249 C Antiparallel orientation of the two CA-CA-CA frames.
7250         if (i.gt.1) then
7251           iti=itortyp(itype(i))
7252         else
7253           iti=ntortyp+1
7254         endif
7255         itk1=itortyp(itype(k+1))
7256         itl=itortyp(itype(l))
7257         itj=itortyp(itype(j))
7258         if (j.lt.nres-1) then
7259           itj1=itortyp(itype(j+1))
7260         else
7261           itj1=ntortyp+1
7262         endif
7263 C A2 kernel(j-1)T A1T
7264         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7265      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7266      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7267 C Following matrices are needed only for 6-th order cumulants
7268         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7269      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7270         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7271      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7272      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7273         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7274      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7275      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7276      &   ADtEAderx(1,1,1,1,1,1))
7277         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7278      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7279      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7280      &   ADtEA1derx(1,1,1,1,1,1))
7281         ENDIF
7282 C End 6-th order cumulants
7283         call transpose2(EUgder(1,1,k),auxmat(1,1))
7284         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7285         call transpose2(EUg(1,1,k),auxmat(1,1))
7286         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7287         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7288         do iii=1,2
7289           do kkk=1,5
7290             do lll=1,3
7291               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7292      &          EAEAderx(1,1,lll,kkk,iii,1))
7293             enddo
7294           enddo
7295         enddo
7296 C A2T kernel(i+1)T A1
7297         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7298      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7299      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7300 C Following matrices are needed only for 6-th order cumulants
7301         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7302      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7303         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7304      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7305      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7307      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7308      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7309      &   ADtEAderx(1,1,1,1,1,2))
7310         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7311      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7312      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7313      &   ADtEA1derx(1,1,1,1,1,2))
7314         ENDIF
7315 C End 6-th order cumulants
7316         call transpose2(EUgder(1,1,j),auxmat(1,1))
7317         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7318         call transpose2(EUg(1,1,j),auxmat(1,1))
7319         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7320         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7321         do iii=1,2
7322           do kkk=1,5
7323             do lll=1,3
7324               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7325      &          EAEAderx(1,1,lll,kkk,iii,2))
7326             enddo
7327           enddo
7328         enddo
7329 C AEAb1 and AEAb2
7330 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7331 C They are needed only when the fifth- or the sixth-order cumulants are
7332 C indluded.
7333         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7334      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7335         call transpose2(AEA(1,1,1),auxmat(1,1))
7336         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7337         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7338         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7339         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7340         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7341         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7342         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7343         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7344         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7345         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7346         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7347         call transpose2(AEA(1,1,2),auxmat(1,1))
7348         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7349         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7350         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7351         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7352         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7353         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7354         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7355         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7356         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7357         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7358         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7359 C Calculate the Cartesian derivatives of the vectors.
7360         do iii=1,2
7361           do kkk=1,5
7362             do lll=1,3
7363               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7364               call matvec2(auxmat(1,1),b1(1,iti),
7365      &          AEAb1derx(1,lll,kkk,iii,1,1))
7366               call matvec2(auxmat(1,1),Ub2(1,i),
7367      &          AEAb2derx(1,lll,kkk,iii,1,1))
7368               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7369      &          AEAb1derx(1,lll,kkk,iii,2,1))
7370               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7371      &          AEAb2derx(1,lll,kkk,iii,2,1))
7372               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7373               call matvec2(auxmat(1,1),b1(1,itl),
7374      &          AEAb1derx(1,lll,kkk,iii,1,2))
7375               call matvec2(auxmat(1,1),Ub2(1,l),
7376      &          AEAb2derx(1,lll,kkk,iii,1,2))
7377               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7378      &          AEAb1derx(1,lll,kkk,iii,2,2))
7379               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7380      &          AEAb2derx(1,lll,kkk,iii,2,2))
7381             enddo
7382           enddo
7383         enddo
7384         ENDIF
7385 C End vectors
7386       endif
7387       return
7388       end
7389 C---------------------------------------------------------------------------
7390       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7391      &  KK,KKderg,AKA,AKAderg,AKAderx)
7392       implicit none
7393       integer nderg
7394       logical transp
7395       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7396      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7397      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7398       integer iii,kkk,lll
7399       integer jjj,mmm
7400       logical lprn
7401       common /kutas/ lprn
7402       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7403       do iii=1,nderg
7404         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7405      &    AKAderg(1,1,iii))
7406       enddo
7407 cd      if (lprn) write (2,*) 'In kernel'
7408       do kkk=1,5
7409 cd        if (lprn) write (2,*) 'kkk=',kkk
7410         do lll=1,3
7411           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7412      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7413 cd          if (lprn) then
7414 cd            write (2,*) 'lll=',lll
7415 cd            write (2,*) 'iii=1'
7416 cd            do jjj=1,2
7417 cd              write (2,'(3(2f10.5),5x)')
7418 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7419 cd            enddo
7420 cd          endif
7421           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7422      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7423 cd          if (lprn) then
7424 cd            write (2,*) 'lll=',lll
7425 cd            write (2,*) 'iii=2'
7426 cd            do jjj=1,2
7427 cd              write (2,'(3(2f10.5),5x)')
7428 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7429 cd            enddo
7430 cd          endif
7431         enddo
7432       enddo
7433       return
7434       end
7435 C---------------------------------------------------------------------------
7436       double precision function eello4(i,j,k,l,jj,kk)
7437       implicit real*8 (a-h,o-z)
7438       include 'DIMENSIONS'
7439       include 'COMMON.IOUNITS'
7440       include 'COMMON.CHAIN'
7441       include 'COMMON.DERIV'
7442       include 'COMMON.INTERACT'
7443       include 'COMMON.CONTACTS'
7444       include 'COMMON.TORSION'
7445       include 'COMMON.VAR'
7446       include 'COMMON.GEO'
7447       double precision pizda(2,2),ggg1(3),ggg2(3)
7448 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7449 cd        eello4=0.0d0
7450 cd        return
7451 cd      endif
7452 cd      print *,'eello4:',i,j,k,l,jj,kk
7453 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7454 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7455 cold      eij=facont_hb(jj,i)
7456 cold      ekl=facont_hb(kk,k)
7457 cold      ekont=eij*ekl
7458       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7459 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7460       gcorr_loc(k-1)=gcorr_loc(k-1)
7461      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7462       if (l.eq.j+1) then
7463         gcorr_loc(l-1)=gcorr_loc(l-1)
7464      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7465       else
7466         gcorr_loc(j-1)=gcorr_loc(j-1)
7467      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7468       endif
7469       do iii=1,2
7470         do kkk=1,5
7471           do lll=1,3
7472             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7473      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7474 cd            derx(lll,kkk,iii)=0.0d0
7475           enddo
7476         enddo
7477       enddo
7478 cd      gcorr_loc(l-1)=0.0d0
7479 cd      gcorr_loc(j-1)=0.0d0
7480 cd      gcorr_loc(k-1)=0.0d0
7481 cd      eel4=1.0d0
7482 cd      write (iout,*)'Contacts have occurred for peptide groups',
7483 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7484 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7485       if (j.lt.nres-1) then
7486         j1=j+1
7487         j2=j-1
7488       else
7489         j1=j-1
7490         j2=j-2
7491       endif
7492       if (l.lt.nres-1) then
7493         l1=l+1
7494         l2=l-1
7495       else
7496         l1=l-1
7497         l2=l-2
7498       endif
7499       do ll=1,3
7500 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7501 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7502         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7503         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7504 cgrad        ghalf=0.5d0*ggg1(ll)
7505         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7506         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7507         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7508         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7509         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7510         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7511 cgrad        ghalf=0.5d0*ggg2(ll)
7512         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7513         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7514         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7515         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7516         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7517         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7518       enddo
7519 cgrad      do m=i+1,j-1
7520 cgrad        do ll=1,3
7521 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7522 cgrad        enddo
7523 cgrad      enddo
7524 cgrad      do m=k+1,l-1
7525 cgrad        do ll=1,3
7526 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7527 cgrad        enddo
7528 cgrad      enddo
7529 cgrad      do m=i+2,j2
7530 cgrad        do ll=1,3
7531 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7532 cgrad        enddo
7533 cgrad      enddo
7534 cgrad      do m=k+2,l2
7535 cgrad        do ll=1,3
7536 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7537 cgrad        enddo
7538 cgrad      enddo
7539 cd      do iii=1,nres-3
7540 cd        write (2,*) iii,gcorr_loc(iii)
7541 cd      enddo
7542       eello4=ekont*eel4
7543 cd      write (2,*) 'ekont',ekont
7544 cd      write (iout,*) 'eello4',ekont*eel4
7545       return
7546       end
7547 C---------------------------------------------------------------------------
7548       double precision function eello5(i,j,k,l,jj,kk)
7549       implicit real*8 (a-h,o-z)
7550       include 'DIMENSIONS'
7551       include 'COMMON.IOUNITS'
7552       include 'COMMON.CHAIN'
7553       include 'COMMON.DERIV'
7554       include 'COMMON.INTERACT'
7555       include 'COMMON.CONTACTS'
7556       include 'COMMON.TORSION'
7557       include 'COMMON.VAR'
7558       include 'COMMON.GEO'
7559       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7560       double precision ggg1(3),ggg2(3)
7561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7562 C                                                                              C
7563 C                            Parallel chains                                   C
7564 C                                                                              C
7565 C          o             o                   o             o                   C
7566 C         /l\           / \             \   / \           / \   /              C
7567 C        /   \         /   \             \ /   \         /   \ /               C
7568 C       j| o |l1       | o |              o| o |         | o |o                C
7569 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7570 C      \i/   \         /   \ /             /   \         /   \                 C
7571 C       o    k1             o                                                  C
7572 C         (I)          (II)                (III)          (IV)                 C
7573 C                                                                              C
7574 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7575 C                                                                              C
7576 C                            Antiparallel chains                               C
7577 C                                                                              C
7578 C          o             o                   o             o                   C
7579 C         /j\           / \             \   / \           / \   /              C
7580 C        /   \         /   \             \ /   \         /   \ /               C
7581 C      j1| o |l        | o |              o| o |         | o |o                C
7582 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7583 C      \i/   \         /   \ /             /   \         /   \                 C
7584 C       o     k1            o                                                  C
7585 C         (I)          (II)                (III)          (IV)                 C
7586 C                                                                              C
7587 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7588 C                                                                              C
7589 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7590 C                                                                              C
7591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7592 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7593 cd        eello5=0.0d0
7594 cd        return
7595 cd      endif
7596 cd      write (iout,*)
7597 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7598 cd     &   ' and',k,l
7599       itk=itortyp(itype(k))
7600       itl=itortyp(itype(l))
7601       itj=itortyp(itype(j))
7602       eello5_1=0.0d0
7603       eello5_2=0.0d0
7604       eello5_3=0.0d0
7605       eello5_4=0.0d0
7606 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7607 cd     &   eel5_3_num,eel5_4_num)
7608       do iii=1,2
7609         do kkk=1,5
7610           do lll=1,3
7611             derx(lll,kkk,iii)=0.0d0
7612           enddo
7613         enddo
7614       enddo
7615 cd      eij=facont_hb(jj,i)
7616 cd      ekl=facont_hb(kk,k)
7617 cd      ekont=eij*ekl
7618 cd      write (iout,*)'Contacts have occurred for peptide groups',
7619 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7620 cd      goto 1111
7621 C Contribution from the graph I.
7622 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7623 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7624       call transpose2(EUg(1,1,k),auxmat(1,1))
7625       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7626       vv(1)=pizda(1,1)-pizda(2,2)
7627       vv(2)=pizda(1,2)+pizda(2,1)
7628       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7629      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7630 C Explicit gradient in virtual-dihedral angles.
7631       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7632      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7633      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7634       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7635       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7636       vv(1)=pizda(1,1)-pizda(2,2)
7637       vv(2)=pizda(1,2)+pizda(2,1)
7638       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7639      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7640      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7641       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7642       vv(1)=pizda(1,1)-pizda(2,2)
7643       vv(2)=pizda(1,2)+pizda(2,1)
7644       if (l.eq.j+1) then
7645         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7646      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7647      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7648       else
7649         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7650      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7651      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7652       endif
7653 C Cartesian gradient
7654       do iii=1,2
7655         do kkk=1,5
7656           do lll=1,3
7657             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7658      &        pizda(1,1))
7659             vv(1)=pizda(1,1)-pizda(2,2)
7660             vv(2)=pizda(1,2)+pizda(2,1)
7661             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7662      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7663      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7664           enddo
7665         enddo
7666       enddo
7667 c      goto 1112
7668 c1111  continue
7669 C Contribution from graph II
7670       call transpose2(EE(1,1,itk),auxmat(1,1))
7671       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)+pizda(2,2)
7673       vv(2)=pizda(2,1)-pizda(1,2)
7674       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7675      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7676 C Explicit gradient in virtual-dihedral angles.
7677       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7678      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7679       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7680       vv(1)=pizda(1,1)+pizda(2,2)
7681       vv(2)=pizda(2,1)-pizda(1,2)
7682       if (l.eq.j+1) then
7683         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7684      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7685      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7686       else
7687         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7688      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7689      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7690       endif
7691 C Cartesian gradient
7692       do iii=1,2
7693         do kkk=1,5
7694           do lll=1,3
7695             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7696      &        pizda(1,1))
7697             vv(1)=pizda(1,1)+pizda(2,2)
7698             vv(2)=pizda(2,1)-pizda(1,2)
7699             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7700      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7701      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7702           enddo
7703         enddo
7704       enddo
7705 cd      goto 1112
7706 cd1111  continue
7707       if (l.eq.j+1) then
7708 cd        goto 1110
7709 C Parallel orientation
7710 C Contribution from graph III
7711         call transpose2(EUg(1,1,l),auxmat(1,1))
7712         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7713         vv(1)=pizda(1,1)-pizda(2,2)
7714         vv(2)=pizda(1,2)+pizda(2,1)
7715         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7717 C Explicit gradient in virtual-dihedral angles.
7718         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7719      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7721         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7722         vv(1)=pizda(1,1)-pizda(2,2)
7723         vv(2)=pizda(1,2)+pizda(2,1)
7724         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7725      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7727         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7728         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7729         vv(1)=pizda(1,1)-pizda(2,2)
7730         vv(2)=pizda(1,2)+pizda(2,1)
7731         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7732      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7734 C Cartesian gradient
7735         do iii=1,2
7736           do kkk=1,5
7737             do lll=1,3
7738               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7739      &          pizda(1,1))
7740               vv(1)=pizda(1,1)-pizda(2,2)
7741               vv(2)=pizda(1,2)+pizda(2,1)
7742               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7743      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7744      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7745             enddo
7746           enddo
7747         enddo
7748 cd        goto 1112
7749 C Contribution from graph IV
7750 cd1110    continue
7751         call transpose2(EE(1,1,itl),auxmat(1,1))
7752         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7756      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7757 C Explicit gradient in virtual-dihedral angles.
7758         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7759      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7760         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7761         vv(1)=pizda(1,1)+pizda(2,2)
7762         vv(2)=pizda(2,1)-pizda(1,2)
7763         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7764      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7765      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7766 C Cartesian gradient
7767         do iii=1,2
7768           do kkk=1,5
7769             do lll=1,3
7770               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7771      &          pizda(1,1))
7772               vv(1)=pizda(1,1)+pizda(2,2)
7773               vv(2)=pizda(2,1)-pizda(1,2)
7774               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7775      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7776      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7777             enddo
7778           enddo
7779         enddo
7780       else
7781 C Antiparallel orientation
7782 C Contribution from graph III
7783 c        goto 1110
7784         call transpose2(EUg(1,1,j),auxmat(1,1))
7785         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7786         vv(1)=pizda(1,1)-pizda(2,2)
7787         vv(2)=pizda(1,2)+pizda(2,1)
7788         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7789      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7790 C Explicit gradient in virtual-dihedral angles.
7791         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7792      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7793      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7794         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7795         vv(1)=pizda(1,1)-pizda(2,2)
7796         vv(2)=pizda(1,2)+pizda(2,1)
7797         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7798      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7799      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7800         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7801         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7802         vv(1)=pizda(1,1)-pizda(2,2)
7803         vv(2)=pizda(1,2)+pizda(2,1)
7804         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7805      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7806      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7807 C Cartesian gradient
7808         do iii=1,2
7809           do kkk=1,5
7810             do lll=1,3
7811               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7812      &          pizda(1,1))
7813               vv(1)=pizda(1,1)-pizda(2,2)
7814               vv(2)=pizda(1,2)+pizda(2,1)
7815               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7816      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7817      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7818             enddo
7819           enddo
7820         enddo
7821 cd        goto 1112
7822 C Contribution from graph IV
7823 1110    continue
7824         call transpose2(EE(1,1,itj),auxmat(1,1))
7825         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7826         vv(1)=pizda(1,1)+pizda(2,2)
7827         vv(2)=pizda(2,1)-pizda(1,2)
7828         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7829      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7830 C Explicit gradient in virtual-dihedral angles.
7831         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7832      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7833         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7834         vv(1)=pizda(1,1)+pizda(2,2)
7835         vv(2)=pizda(2,1)-pizda(1,2)
7836         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7837      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7838      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7839 C Cartesian gradient
7840         do iii=1,2
7841           do kkk=1,5
7842             do lll=1,3
7843               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7844      &          pizda(1,1))
7845               vv(1)=pizda(1,1)+pizda(2,2)
7846               vv(2)=pizda(2,1)-pizda(1,2)
7847               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7848      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7849      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7850             enddo
7851           enddo
7852         enddo
7853       endif
7854 1112  continue
7855       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7856 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7857 cd        write (2,*) 'ijkl',i,j,k,l
7858 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7859 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7860 cd      endif
7861 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7862 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7863 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7864 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7865       if (j.lt.nres-1) then
7866         j1=j+1
7867         j2=j-1
7868       else
7869         j1=j-1
7870         j2=j-2
7871       endif
7872       if (l.lt.nres-1) then
7873         l1=l+1
7874         l2=l-1
7875       else
7876         l1=l-1
7877         l2=l-2
7878       endif
7879 cd      eij=1.0d0
7880 cd      ekl=1.0d0
7881 cd      ekont=1.0d0
7882 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7883 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7884 C        summed up outside the subrouine as for the other subroutines
7885 C        handling long-range interactions. The old code is commented out
7886 C        with "cgrad" to keep track of changes.
7887       do ll=1,3
7888 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7889 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7890         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7891         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7892 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7893 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7894 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7895 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7896 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7897 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7898 c     &   gradcorr5ij,
7899 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7900 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7901 cgrad        ghalf=0.5d0*ggg1(ll)
7902 cd        ghalf=0.0d0
7903         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7904         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7905         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7906         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7907         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7908         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7909 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7910 cgrad        ghalf=0.5d0*ggg2(ll)
7911 cd        ghalf=0.0d0
7912         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7913         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7914         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7915         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7916         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7917         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7918       enddo
7919 cd      goto 1112
7920 cgrad      do m=i+1,j-1
7921 cgrad        do ll=1,3
7922 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7923 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7924 cgrad        enddo
7925 cgrad      enddo
7926 cgrad      do m=k+1,l-1
7927 cgrad        do ll=1,3
7928 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7929 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7930 cgrad        enddo
7931 cgrad      enddo
7932 c1112  continue
7933 cgrad      do m=i+2,j2
7934 cgrad        do ll=1,3
7935 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7936 cgrad        enddo
7937 cgrad      enddo
7938 cgrad      do m=k+2,l2
7939 cgrad        do ll=1,3
7940 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7941 cgrad        enddo
7942 cgrad      enddo
7943 cd      do iii=1,nres-3
7944 cd        write (2,*) iii,g_corr5_loc(iii)
7945 cd      enddo
7946       eello5=ekont*eel5
7947 cd      write (2,*) 'ekont',ekont
7948 cd      write (iout,*) 'eello5',ekont*eel5
7949       return
7950       end
7951 c--------------------------------------------------------------------------
7952       double precision function eello6(i,j,k,l,jj,kk)
7953       implicit real*8 (a-h,o-z)
7954       include 'DIMENSIONS'
7955       include 'COMMON.IOUNITS'
7956       include 'COMMON.CHAIN'
7957       include 'COMMON.DERIV'
7958       include 'COMMON.INTERACT'
7959       include 'COMMON.CONTACTS'
7960       include 'COMMON.TORSION'
7961       include 'COMMON.VAR'
7962       include 'COMMON.GEO'
7963       include 'COMMON.FFIELD'
7964       double precision ggg1(3),ggg2(3)
7965 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7966 cd        eello6=0.0d0
7967 cd        return
7968 cd      endif
7969 cd      write (iout,*)
7970 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7971 cd     &   ' and',k,l
7972       eello6_1=0.0d0
7973       eello6_2=0.0d0
7974       eello6_3=0.0d0
7975       eello6_4=0.0d0
7976       eello6_5=0.0d0
7977       eello6_6=0.0d0
7978 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7979 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7980       do iii=1,2
7981         do kkk=1,5
7982           do lll=1,3
7983             derx(lll,kkk,iii)=0.0d0
7984           enddo
7985         enddo
7986       enddo
7987 cd      eij=facont_hb(jj,i)
7988 cd      ekl=facont_hb(kk,k)
7989 cd      ekont=eij*ekl
7990 cd      eij=1.0d0
7991 cd      ekl=1.0d0
7992 cd      ekont=1.0d0
7993       if (l.eq.j+1) then
7994         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7995         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7996         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7997         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7998         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7999         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8000       else
8001         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8002         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8003         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8004         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8005         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8006           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8007         else
8008           eello6_5=0.0d0
8009         endif
8010         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8011       endif
8012 C If turn contributions are considered, they will be handled separately.
8013       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8014 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8015 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8016 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8017 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8018 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8019 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8020 cd      goto 1112
8021       if (j.lt.nres-1) then
8022         j1=j+1
8023         j2=j-1
8024       else
8025         j1=j-1
8026         j2=j-2
8027       endif
8028       if (l.lt.nres-1) then
8029         l1=l+1
8030         l2=l-1
8031       else
8032         l1=l-1
8033         l2=l-2
8034       endif
8035       do ll=1,3
8036 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8037 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8038 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8039 cgrad        ghalf=0.5d0*ggg1(ll)
8040 cd        ghalf=0.0d0
8041         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8042         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8043         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8044         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8045         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8046         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8047         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8048         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8049 cgrad        ghalf=0.5d0*ggg2(ll)
8050 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8051 cd        ghalf=0.0d0
8052         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8053         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8054         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8055         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8056         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8057         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8058       enddo
8059 cd      goto 1112
8060 cgrad      do m=i+1,j-1
8061 cgrad        do ll=1,3
8062 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8063 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8064 cgrad        enddo
8065 cgrad      enddo
8066 cgrad      do m=k+1,l-1
8067 cgrad        do ll=1,3
8068 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8069 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8070 cgrad        enddo
8071 cgrad      enddo
8072 cgrad1112  continue
8073 cgrad      do m=i+2,j2
8074 cgrad        do ll=1,3
8075 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8076 cgrad        enddo
8077 cgrad      enddo
8078 cgrad      do m=k+2,l2
8079 cgrad        do ll=1,3
8080 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8081 cgrad        enddo
8082 cgrad      enddo
8083 cd      do iii=1,nres-3
8084 cd        write (2,*) iii,g_corr6_loc(iii)
8085 cd      enddo
8086       eello6=ekont*eel6
8087 cd      write (2,*) 'ekont',ekont
8088 cd      write (iout,*) 'eello6',ekont*eel6
8089       return
8090       end
8091 c--------------------------------------------------------------------------
8092       double precision function eello6_graph1(i,j,k,l,imat,swap)
8093       implicit real*8 (a-h,o-z)
8094       include 'DIMENSIONS'
8095       include 'COMMON.IOUNITS'
8096       include 'COMMON.CHAIN'
8097       include 'COMMON.DERIV'
8098       include 'COMMON.INTERACT'
8099       include 'COMMON.CONTACTS'
8100       include 'COMMON.TORSION'
8101       include 'COMMON.VAR'
8102       include 'COMMON.GEO'
8103       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8104       logical swap
8105       logical lprn
8106       common /kutas/ lprn
8107 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8108 C                                                                              C
8109 C      Parallel       Antiparallel                                             C
8110 C                                                                              C
8111 C          o             o                                                     C
8112 C         /l\           /j\                                                    C
8113 C        /   \         /   \                                                   C
8114 C       /| o |         | o |\                                                  C
8115 C     \ j|/k\|  /   \  |/k\|l /                                                C
8116 C      \ /   \ /     \ /   \ /                                                 C
8117 C       o     o       o     o                                                  C
8118 C       i             i                                                        C
8119 C                                                                              C
8120 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8121       itk=itortyp(itype(k))
8122       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8123       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8124       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8125       call transpose2(EUgC(1,1,k),auxmat(1,1))
8126       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8127       vv1(1)=pizda1(1,1)-pizda1(2,2)
8128       vv1(2)=pizda1(1,2)+pizda1(2,1)
8129       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8130       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8131       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8132       s5=scalar2(vv(1),Dtobr2(1,i))
8133 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8134       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8135       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8136      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8137      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8138      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8139      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8140      & +scalar2(vv(1),Dtobr2der(1,i)))
8141       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8142       vv1(1)=pizda1(1,1)-pizda1(2,2)
8143       vv1(2)=pizda1(1,2)+pizda1(2,1)
8144       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8145       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8146       if (l.eq.j+1) then
8147         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8148      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8149      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8150      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8151      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8152       else
8153         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8154      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8155      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8156      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8157      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8158       endif
8159       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8160       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8161       vv1(1)=pizda1(1,1)-pizda1(2,2)
8162       vv1(2)=pizda1(1,2)+pizda1(2,1)
8163       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8164      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8165      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8166      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8167       do iii=1,2
8168         if (swap) then
8169           ind=3-iii
8170         else
8171           ind=iii
8172         endif
8173         do kkk=1,5
8174           do lll=1,3
8175             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8176             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8177             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8178             call transpose2(EUgC(1,1,k),auxmat(1,1))
8179             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8180      &        pizda1(1,1))
8181             vv1(1)=pizda1(1,1)-pizda1(2,2)
8182             vv1(2)=pizda1(1,2)+pizda1(2,1)
8183             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8184             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8185      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8186             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8187      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8188             s5=scalar2(vv(1),Dtobr2(1,i))
8189             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8190           enddo
8191         enddo
8192       enddo
8193       return
8194       end
8195 c----------------------------------------------------------------------------
8196       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8197       implicit real*8 (a-h,o-z)
8198       include 'DIMENSIONS'
8199       include 'COMMON.IOUNITS'
8200       include 'COMMON.CHAIN'
8201       include 'COMMON.DERIV'
8202       include 'COMMON.INTERACT'
8203       include 'COMMON.CONTACTS'
8204       include 'COMMON.TORSION'
8205       include 'COMMON.VAR'
8206       include 'COMMON.GEO'
8207       logical swap
8208       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8209      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8210       logical lprn
8211       common /kutas/ lprn
8212 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8213 C                                                                              C
8214 C      Parallel       Antiparallel                                             C
8215 C                                                                              C
8216 C          o             o                                                     C
8217 C     \   /l\           /j\   /                                                C
8218 C      \ /   \         /   \ /                                                 C
8219 C       o| o |         | o |o                                                  C
8220 C     \ j|/k\|      \  |/k\|l                                                  C
8221 C      \ /   \       \ /   \                                                   C
8222 C       o             o                                                        C
8223 C       i             i                                                        C
8224 C                                                                              C
8225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8226 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8227 C AL 7/4/01 s1 would occur in the sixth-order moment,
8228 C           but not in a cluster cumulant
8229 #ifdef MOMENT
8230       s1=dip(1,jj,i)*dip(1,kk,k)
8231 #endif
8232       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8233       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8234       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8235       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8236       call transpose2(EUg(1,1,k),auxmat(1,1))
8237       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8238       vv(1)=pizda(1,1)-pizda(2,2)
8239       vv(2)=pizda(1,2)+pizda(2,1)
8240       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8241 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8242 #ifdef MOMENT
8243       eello6_graph2=-(s1+s2+s3+s4)
8244 #else
8245       eello6_graph2=-(s2+s3+s4)
8246 #endif
8247 c      eello6_graph2=-s3
8248 C Derivatives in gamma(i-1)
8249       if (i.gt.1) then
8250 #ifdef MOMENT
8251         s1=dipderg(1,jj,i)*dip(1,kk,k)
8252 #endif
8253         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8254         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8255         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8256         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8257 #ifdef MOMENT
8258         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8259 #else
8260         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8261 #endif
8262 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8263       endif
8264 C Derivatives in gamma(k-1)
8265 #ifdef MOMENT
8266       s1=dip(1,jj,i)*dipderg(1,kk,k)
8267 #endif
8268       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8269       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8270       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8271       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8272       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8273       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8274       vv(1)=pizda(1,1)-pizda(2,2)
8275       vv(2)=pizda(1,2)+pizda(2,1)
8276       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8277 #ifdef MOMENT
8278       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8279 #else
8280       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8281 #endif
8282 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8283 C Derivatives in gamma(j-1) or gamma(l-1)
8284       if (j.gt.1) then
8285 #ifdef MOMENT
8286         s1=dipderg(3,jj,i)*dip(1,kk,k)
8287 #endif
8288         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8289         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8290         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8291         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8292         vv(1)=pizda(1,1)-pizda(2,2)
8293         vv(2)=pizda(1,2)+pizda(2,1)
8294         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8295 #ifdef MOMENT
8296         if (swap) then
8297           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8298         else
8299           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8300         endif
8301 #endif
8302         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8303 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8304       endif
8305 C Derivatives in gamma(l-1) or gamma(j-1)
8306       if (l.gt.1) then
8307 #ifdef MOMENT
8308         s1=dip(1,jj,i)*dipderg(3,kk,k)
8309 #endif
8310         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8311         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8312         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8313         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8314         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8315         vv(1)=pizda(1,1)-pizda(2,2)
8316         vv(2)=pizda(1,2)+pizda(2,1)
8317         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8318 #ifdef MOMENT
8319         if (swap) then
8320           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8321         else
8322           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8323         endif
8324 #endif
8325         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8326 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8327       endif
8328 C Cartesian derivatives.
8329       if (lprn) then
8330         write (2,*) 'In eello6_graph2'
8331         do iii=1,2
8332           write (2,*) 'iii=',iii
8333           do kkk=1,5
8334             write (2,*) 'kkk=',kkk
8335             do jjj=1,2
8336               write (2,'(3(2f10.5),5x)')
8337      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8338             enddo
8339           enddo
8340         enddo
8341       endif
8342       do iii=1,2
8343         do kkk=1,5
8344           do lll=1,3
8345 #ifdef MOMENT
8346             if (iii.eq.1) then
8347               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8348             else
8349               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8350             endif
8351 #endif
8352             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8353      &        auxvec(1))
8354             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8355             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8356      &        auxvec(1))
8357             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8358             call transpose2(EUg(1,1,k),auxmat(1,1))
8359             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8360      &        pizda(1,1))
8361             vv(1)=pizda(1,1)-pizda(2,2)
8362             vv(2)=pizda(1,2)+pizda(2,1)
8363             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8364 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8365 #ifdef MOMENT
8366             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8367 #else
8368             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8369 #endif
8370             if (swap) then
8371               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8372             else
8373               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8374             endif
8375           enddo
8376         enddo
8377       enddo
8378       return
8379       end
8380 c----------------------------------------------------------------------------
8381       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8382       implicit real*8 (a-h,o-z)
8383       include 'DIMENSIONS'
8384       include 'COMMON.IOUNITS'
8385       include 'COMMON.CHAIN'
8386       include 'COMMON.DERIV'
8387       include 'COMMON.INTERACT'
8388       include 'COMMON.CONTACTS'
8389       include 'COMMON.TORSION'
8390       include 'COMMON.VAR'
8391       include 'COMMON.GEO'
8392       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8393       logical swap
8394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8395 C                                                                              C
8396 C      Parallel       Antiparallel                                             C
8397 C                                                                              C
8398 C          o             o                                                     C
8399 C         /l\   /   \   /j\                                                    C
8400 C        /   \ /     \ /   \                                                   C
8401 C       /| o |o       o| o |\                                                  C
8402 C       j|/k\|  /      |/k\|l /                                                C
8403 C        /   \ /       /   \ /                                                 C
8404 C       /     o       /     o                                                  C
8405 C       i             i                                                        C
8406 C                                                                              C
8407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8408 C
8409 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8410 C           energy moment and not to the cluster cumulant.
8411       iti=itortyp(itype(i))
8412       if (j.lt.nres-1) then
8413         itj1=itortyp(itype(j+1))
8414       else
8415         itj1=ntortyp+1
8416       endif
8417       itk=itortyp(itype(k))
8418       itk1=itortyp(itype(k+1))
8419       if (l.lt.nres-1) then
8420         itl1=itortyp(itype(l+1))
8421       else
8422         itl1=ntortyp+1
8423       endif
8424 #ifdef MOMENT
8425       s1=dip(4,jj,i)*dip(4,kk,k)
8426 #endif
8427       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8428       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8429       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8430       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8431       call transpose2(EE(1,1,itk),auxmat(1,1))
8432       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8433       vv(1)=pizda(1,1)+pizda(2,2)
8434       vv(2)=pizda(2,1)-pizda(1,2)
8435       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8436 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8437 cd     & "sum",-(s2+s3+s4)
8438 #ifdef MOMENT
8439       eello6_graph3=-(s1+s2+s3+s4)
8440 #else
8441       eello6_graph3=-(s2+s3+s4)
8442 #endif
8443 c      eello6_graph3=-s4
8444 C Derivatives in gamma(k-1)
8445       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8446       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8447       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8448       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8449 C Derivatives in gamma(l-1)
8450       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8451       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8452       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8453       vv(1)=pizda(1,1)+pizda(2,2)
8454       vv(2)=pizda(2,1)-pizda(1,2)
8455       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8456       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8457 C Cartesian derivatives.
8458       do iii=1,2
8459         do kkk=1,5
8460           do lll=1,3
8461 #ifdef MOMENT
8462             if (iii.eq.1) then
8463               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8464             else
8465               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8466             endif
8467 #endif
8468             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8469      &        auxvec(1))
8470             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8471             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8472      &        auxvec(1))
8473             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8474             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8475      &        pizda(1,1))
8476             vv(1)=pizda(1,1)+pizda(2,2)
8477             vv(2)=pizda(2,1)-pizda(1,2)
8478             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8479 #ifdef MOMENT
8480             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8481 #else
8482             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8483 #endif
8484             if (swap) then
8485               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8486             else
8487               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8488             endif
8489 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8490           enddo
8491         enddo
8492       enddo
8493       return
8494       end
8495 c----------------------------------------------------------------------------
8496       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8497       implicit real*8 (a-h,o-z)
8498       include 'DIMENSIONS'
8499       include 'COMMON.IOUNITS'
8500       include 'COMMON.CHAIN'
8501       include 'COMMON.DERIV'
8502       include 'COMMON.INTERACT'
8503       include 'COMMON.CONTACTS'
8504       include 'COMMON.TORSION'
8505       include 'COMMON.VAR'
8506       include 'COMMON.GEO'
8507       include 'COMMON.FFIELD'
8508       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8509      & auxvec1(2),auxmat1(2,2)
8510       logical swap
8511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8512 C                                                                              C
8513 C      Parallel       Antiparallel                                             C
8514 C                                                                              C
8515 C          o             o                                                     C
8516 C         /l\   /   \   /j\                                                    C
8517 C        /   \ /     \ /   \                                                   C
8518 C       /| o |o       o| o |\                                                  C
8519 C     \ j|/k\|      \  |/k\|l                                                  C
8520 C      \ /   \       \ /   \                                                   C
8521 C       o     \       o     \                                                  C
8522 C       i             i                                                        C
8523 C                                                                              C
8524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8525 C
8526 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8527 C           energy moment and not to the cluster cumulant.
8528 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8529       iti=itortyp(itype(i))
8530       itj=itortyp(itype(j))
8531       if (j.lt.nres-1) then
8532         itj1=itortyp(itype(j+1))
8533       else
8534         itj1=ntortyp+1
8535       endif
8536       itk=itortyp(itype(k))
8537       if (k.lt.nres-1) then
8538         itk1=itortyp(itype(k+1))
8539       else
8540         itk1=ntortyp+1
8541       endif
8542       itl=itortyp(itype(l))
8543       if (l.lt.nres-1) then
8544         itl1=itortyp(itype(l+1))
8545       else
8546         itl1=ntortyp+1
8547       endif
8548 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8549 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8550 cd     & ' itl',itl,' itl1',itl1
8551 #ifdef MOMENT
8552       if (imat.eq.1) then
8553         s1=dip(3,jj,i)*dip(3,kk,k)
8554       else
8555         s1=dip(2,jj,j)*dip(2,kk,l)
8556       endif
8557 #endif
8558       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8559       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8560       if (j.eq.l+1) then
8561         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8562         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8563       else
8564         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8566       endif
8567       call transpose2(EUg(1,1,k),auxmat(1,1))
8568       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8569       vv(1)=pizda(1,1)-pizda(2,2)
8570       vv(2)=pizda(2,1)+pizda(1,2)
8571       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8572 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8573 #ifdef MOMENT
8574       eello6_graph4=-(s1+s2+s3+s4)
8575 #else
8576       eello6_graph4=-(s2+s3+s4)
8577 #endif
8578 C Derivatives in gamma(i-1)
8579       if (i.gt.1) then
8580 #ifdef MOMENT
8581         if (imat.eq.1) then
8582           s1=dipderg(2,jj,i)*dip(3,kk,k)
8583         else
8584           s1=dipderg(4,jj,j)*dip(2,kk,l)
8585         endif
8586 #endif
8587         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8588         if (j.eq.l+1) then
8589           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8590           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8591         else
8592           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8593           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8594         endif
8595         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8596         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8597 cd          write (2,*) 'turn6 derivatives'
8598 #ifdef MOMENT
8599           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8600 #else
8601           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8602 #endif
8603         else
8604 #ifdef MOMENT
8605           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8606 #else
8607           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8608 #endif
8609         endif
8610       endif
8611 C Derivatives in gamma(k-1)
8612 #ifdef MOMENT
8613       if (imat.eq.1) then
8614         s1=dip(3,jj,i)*dipderg(2,kk,k)
8615       else
8616         s1=dip(2,jj,j)*dipderg(4,kk,l)
8617       endif
8618 #endif
8619       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8620       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8621       if (j.eq.l+1) then
8622         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8623         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8624       else
8625         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8626         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8627       endif
8628       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8629       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8630       vv(1)=pizda(1,1)-pizda(2,2)
8631       vv(2)=pizda(2,1)+pizda(1,2)
8632       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8633       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8634 #ifdef MOMENT
8635         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8636 #else
8637         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8638 #endif
8639       else
8640 #ifdef MOMENT
8641         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8642 #else
8643         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8644 #endif
8645       endif
8646 C Derivatives in gamma(j-1) or gamma(l-1)
8647       if (l.eq.j+1 .and. l.gt.1) then
8648         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8649         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8650         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8651         vv(1)=pizda(1,1)-pizda(2,2)
8652         vv(2)=pizda(2,1)+pizda(1,2)
8653         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8654         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8655       else if (j.gt.1) then
8656         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8657         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8658         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8659         vv(1)=pizda(1,1)-pizda(2,2)
8660         vv(2)=pizda(2,1)+pizda(1,2)
8661         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8662         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8663           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8664         else
8665           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8666         endif
8667       endif
8668 C Cartesian derivatives.
8669       do iii=1,2
8670         do kkk=1,5
8671           do lll=1,3
8672 #ifdef MOMENT
8673             if (iii.eq.1) then
8674               if (imat.eq.1) then
8675                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8676               else
8677                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8678               endif
8679             else
8680               if (imat.eq.1) then
8681                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8682               else
8683                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8684               endif
8685             endif
8686 #endif
8687             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8688      &        auxvec(1))
8689             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8690             if (j.eq.l+1) then
8691               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8692      &          b1(1,itj1),auxvec(1))
8693               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8694             else
8695               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8696      &          b1(1,itl1),auxvec(1))
8697               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8698             endif
8699             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8700      &        pizda(1,1))
8701             vv(1)=pizda(1,1)-pizda(2,2)
8702             vv(2)=pizda(2,1)+pizda(1,2)
8703             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8704             if (swap) then
8705               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8706 #ifdef MOMENT
8707                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8708      &             -(s1+s2+s4)
8709 #else
8710                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8711      &             -(s2+s4)
8712 #endif
8713                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8714               else
8715 #ifdef MOMENT
8716                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8717 #else
8718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8719 #endif
8720                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8721               endif
8722             else
8723 #ifdef MOMENT
8724               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8725 #else
8726               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8727 #endif
8728               if (l.eq.j+1) then
8729                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8730               else
8731                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8732               endif
8733             endif
8734           enddo
8735         enddo
8736       enddo
8737       return
8738       end
8739 c----------------------------------------------------------------------------
8740       double precision function eello_turn6(i,jj,kk)
8741       implicit real*8 (a-h,o-z)
8742       include 'DIMENSIONS'
8743       include 'COMMON.IOUNITS'
8744       include 'COMMON.CHAIN'
8745       include 'COMMON.DERIV'
8746       include 'COMMON.INTERACT'
8747       include 'COMMON.CONTACTS'
8748       include 'COMMON.TORSION'
8749       include 'COMMON.VAR'
8750       include 'COMMON.GEO'
8751       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8752      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8753      &  ggg1(3),ggg2(3)
8754       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8755      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8756 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8757 C           the respective energy moment and not to the cluster cumulant.
8758       s1=0.0d0
8759       s8=0.0d0
8760       s13=0.0d0
8761 c
8762       eello_turn6=0.0d0
8763       j=i+4
8764       k=i+1
8765       l=i+3
8766       iti=itortyp(itype(i))
8767       itk=itortyp(itype(k))
8768       itk1=itortyp(itype(k+1))
8769       itl=itortyp(itype(l))
8770       itj=itortyp(itype(j))
8771 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8772 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8773 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8774 cd        eello6=0.0d0
8775 cd        return
8776 cd      endif
8777 cd      write (iout,*)
8778 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8779 cd     &   ' and',k,l
8780 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8781       do iii=1,2
8782         do kkk=1,5
8783           do lll=1,3
8784             derx_turn(lll,kkk,iii)=0.0d0
8785           enddo
8786         enddo
8787       enddo
8788 cd      eij=1.0d0
8789 cd      ekl=1.0d0
8790 cd      ekont=1.0d0
8791       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8792 cd      eello6_5=0.0d0
8793 cd      write (2,*) 'eello6_5',eello6_5
8794 #ifdef MOMENT
8795       call transpose2(AEA(1,1,1),auxmat(1,1))
8796       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8797       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8798       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8799 #endif
8800       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8801       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8802       s2 = scalar2(b1(1,itk),vtemp1(1))
8803 #ifdef MOMENT
8804       call transpose2(AEA(1,1,2),atemp(1,1))
8805       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8806       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8807       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8808 #endif
8809       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8810       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8811       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8812 #ifdef MOMENT
8813       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8814       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8815       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8816       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8817       ss13 = scalar2(b1(1,itk),vtemp4(1))
8818       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8819 #endif
8820 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8821 c      s1=0.0d0
8822 c      s2=0.0d0
8823 c      s8=0.0d0
8824 c      s12=0.0d0
8825 c      s13=0.0d0
8826       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8827 C Derivatives in gamma(i+2)
8828       s1d =0.0d0
8829       s8d =0.0d0
8830 #ifdef MOMENT
8831       call transpose2(AEA(1,1,1),auxmatd(1,1))
8832       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8833       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8834       call transpose2(AEAderg(1,1,2),atempd(1,1))
8835       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8836       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8837 #endif
8838       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8839       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8840       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8841 c      s1d=0.0d0
8842 c      s2d=0.0d0
8843 c      s8d=0.0d0
8844 c      s12d=0.0d0
8845 c      s13d=0.0d0
8846       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8847 C Derivatives in gamma(i+3)
8848 #ifdef MOMENT
8849       call transpose2(AEA(1,1,1),auxmatd(1,1))
8850       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8851       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8852       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8853 #endif
8854       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8855       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8856       s2d = scalar2(b1(1,itk),vtemp1d(1))
8857 #ifdef MOMENT
8858       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8859       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8860 #endif
8861       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8862 #ifdef MOMENT
8863       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8864       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8865       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8866 #endif
8867 c      s1d=0.0d0
8868 c      s2d=0.0d0
8869 c      s8d=0.0d0
8870 c      s12d=0.0d0
8871 c      s13d=0.0d0
8872 #ifdef MOMENT
8873       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8874      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8875 #else
8876       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8877      &               -0.5d0*ekont*(s2d+s12d)
8878 #endif
8879 C Derivatives in gamma(i+4)
8880       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8881       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8882       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8883 #ifdef MOMENT
8884       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8885       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8886       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8887 #endif
8888 c      s1d=0.0d0
8889 c      s2d=0.0d0
8890 c      s8d=0.0d0
8891 C      s12d=0.0d0
8892 c      s13d=0.0d0
8893 #ifdef MOMENT
8894       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8895 #else
8896       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8897 #endif
8898 C Derivatives in gamma(i+5)
8899 #ifdef MOMENT
8900       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8901       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8902       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8903 #endif
8904       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8905       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8906       s2d = scalar2(b1(1,itk),vtemp1d(1))
8907 #ifdef MOMENT
8908       call transpose2(AEA(1,1,2),atempd(1,1))
8909       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8910       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8911 #endif
8912       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8913       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8914 #ifdef MOMENT
8915       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8916       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8917       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8918 #endif
8919 c      s1d=0.0d0
8920 c      s2d=0.0d0
8921 c      s8d=0.0d0
8922 c      s12d=0.0d0
8923 c      s13d=0.0d0
8924 #ifdef MOMENT
8925       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8926      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8927 #else
8928       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8929      &               -0.5d0*ekont*(s2d+s12d)
8930 #endif
8931 C Cartesian derivatives
8932       do iii=1,2
8933         do kkk=1,5
8934           do lll=1,3
8935 #ifdef MOMENT
8936             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8937             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8938             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8939 #endif
8940             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8941             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8942      &          vtemp1d(1))
8943             s2d = scalar2(b1(1,itk),vtemp1d(1))
8944 #ifdef MOMENT
8945             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8946             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8947             s8d = -(atempd(1,1)+atempd(2,2))*
8948      &           scalar2(cc(1,1,itl),vtemp2(1))
8949 #endif
8950             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8951      &           auxmatd(1,1))
8952             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8953             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8954 c      s1d=0.0d0
8955 c      s2d=0.0d0
8956 c      s8d=0.0d0
8957 c      s12d=0.0d0
8958 c      s13d=0.0d0
8959 #ifdef MOMENT
8960             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8961      &        - 0.5d0*(s1d+s2d)
8962 #else
8963             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8964      &        - 0.5d0*s2d
8965 #endif
8966 #ifdef MOMENT
8967             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8968      &        - 0.5d0*(s8d+s12d)
8969 #else
8970             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8971      &        - 0.5d0*s12d
8972 #endif
8973           enddo
8974         enddo
8975       enddo
8976 #ifdef MOMENT
8977       do kkk=1,5
8978         do lll=1,3
8979           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8980      &      achuj_tempd(1,1))
8981           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8982           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8983           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8984           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8985           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8986      &      vtemp4d(1))
8987           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8988           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8989           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8990         enddo
8991       enddo
8992 #endif
8993 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8994 cd     &  16*eel_turn6_num
8995 cd      goto 1112
8996       if (j.lt.nres-1) then
8997         j1=j+1
8998         j2=j-1
8999       else
9000         j1=j-1
9001         j2=j-2
9002       endif
9003       if (l.lt.nres-1) then
9004         l1=l+1
9005         l2=l-1
9006       else
9007         l1=l-1
9008         l2=l-2
9009       endif
9010       do ll=1,3
9011 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9012 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9013 cgrad        ghalf=0.5d0*ggg1(ll)
9014 cd        ghalf=0.0d0
9015         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9016         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9017         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9018      &    +ekont*derx_turn(ll,2,1)
9019         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9020         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9021      &    +ekont*derx_turn(ll,4,1)
9022         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9023         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9024         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9025 cgrad        ghalf=0.5d0*ggg2(ll)
9026 cd        ghalf=0.0d0
9027         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9028      &    +ekont*derx_turn(ll,2,2)
9029         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9030         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9031      &    +ekont*derx_turn(ll,4,2)
9032         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9033         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9034         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9035       enddo
9036 cd      goto 1112
9037 cgrad      do m=i+1,j-1
9038 cgrad        do ll=1,3
9039 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9040 cgrad        enddo
9041 cgrad      enddo
9042 cgrad      do m=k+1,l-1
9043 cgrad        do ll=1,3
9044 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9045 cgrad        enddo
9046 cgrad      enddo
9047 cgrad1112  continue
9048 cgrad      do m=i+2,j2
9049 cgrad        do ll=1,3
9050 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9051 cgrad        enddo
9052 cgrad      enddo
9053 cgrad      do m=k+2,l2
9054 cgrad        do ll=1,3
9055 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9056 cgrad        enddo
9057 cgrad      enddo
9058 cd      do iii=1,nres-3
9059 cd        write (2,*) iii,g_corr6_loc(iii)
9060 cd      enddo
9061       eello_turn6=ekont*eel_turn6
9062 cd      write (2,*) 'ekont',ekont
9063 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9064       return
9065       end
9066
9067 C-----------------------------------------------------------------------------
9068       double precision function scalar(u,v)
9069 !DIR$ INLINEALWAYS scalar
9070 #ifndef OSF
9071 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9072 #endif
9073       implicit none
9074       double precision u(3),v(3)
9075 cd      double precision sc
9076 cd      integer i
9077 cd      sc=0.0d0
9078 cd      do i=1,3
9079 cd        sc=sc+u(i)*v(i)
9080 cd      enddo
9081 cd      scalar=sc
9082
9083       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9084       return
9085       end
9086 crc-------------------------------------------------
9087       SUBROUTINE MATVEC2(A1,V1,V2)
9088 !DIR$ INLINEALWAYS MATVEC2
9089 #ifndef OSF
9090 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9091 #endif
9092       implicit real*8 (a-h,o-z)
9093       include 'DIMENSIONS'
9094       DIMENSION A1(2,2),V1(2),V2(2)
9095 c      DO 1 I=1,2
9096 c        VI=0.0
9097 c        DO 3 K=1,2
9098 c    3     VI=VI+A1(I,K)*V1(K)
9099 c        Vaux(I)=VI
9100 c    1 CONTINUE
9101
9102       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9103       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9104
9105       v2(1)=vaux1
9106       v2(2)=vaux2
9107       END
9108 C---------------------------------------
9109       SUBROUTINE MATMAT2(A1,A2,A3)
9110 #ifndef OSF
9111 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9112 #endif
9113       implicit real*8 (a-h,o-z)
9114       include 'DIMENSIONS'
9115       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9116 c      DIMENSION AI3(2,2)
9117 c        DO  J=1,2
9118 c          A3IJ=0.0
9119 c          DO K=1,2
9120 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9121 c          enddo
9122 c          A3(I,J)=A3IJ
9123 c       enddo
9124 c      enddo
9125
9126       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9127       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9128       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9129       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9130
9131       A3(1,1)=AI3_11
9132       A3(2,1)=AI3_21
9133       A3(1,2)=AI3_12
9134       A3(2,2)=AI3_22
9135       END
9136
9137 c-------------------------------------------------------------------------
9138       double precision function scalar2(u,v)
9139 !DIR$ INLINEALWAYS scalar2
9140       implicit none
9141       double precision u(2),v(2)
9142       double precision sc
9143       integer i
9144       scalar2=u(1)*v(1)+u(2)*v(2)
9145       return
9146       end
9147
9148 C-----------------------------------------------------------------------------
9149
9150       subroutine transpose2(a,at)
9151 !DIR$ INLINEALWAYS transpose2
9152 #ifndef OSF
9153 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9154 #endif
9155       implicit none
9156       double precision a(2,2),at(2,2)
9157       at(1,1)=a(1,1)
9158       at(1,2)=a(2,1)
9159       at(2,1)=a(1,2)
9160       at(2,2)=a(2,2)
9161       return
9162       end
9163 c--------------------------------------------------------------------------
9164       subroutine transpose(n,a,at)
9165       implicit none
9166       integer n,i,j
9167       double precision a(n,n),at(n,n)
9168       do i=1,n
9169         do j=1,n
9170           at(j,i)=a(i,j)
9171         enddo
9172       enddo
9173       return
9174       end
9175 C---------------------------------------------------------------------------
9176       subroutine prodmat3(a1,a2,kk,transp,prod)
9177 !DIR$ INLINEALWAYS prodmat3
9178 #ifndef OSF
9179 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9180 #endif
9181       implicit none
9182       integer i,j
9183       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9184       logical transp
9185 crc      double precision auxmat(2,2),prod_(2,2)
9186
9187       if (transp) then
9188 crc        call transpose2(kk(1,1),auxmat(1,1))
9189 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9190 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9191
9192            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9193      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9194            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9195      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9196            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9197      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9198            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9199      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9200
9201       else
9202 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9203 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9204
9205            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9206      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9207            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9208      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9209            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9210      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9211            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9212      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9213
9214       endif
9215 c      call transpose2(a2(1,1),a2t(1,1))
9216
9217 crc      print *,transp
9218 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9219 crc      print *,((prod(i,j),i=1,2),j=1,2)
9220
9221       return
9222       end
9223