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 c           write(iout,*) "DISULFIDY:", i,j,evdwij
1471               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1472      &                        'evdw',i,j,evdwij,' ss'
1473 C triple bond artifac removal
1474 C MODIFIED j+1 to j+2 TO AVOID EBERGY BARRIER FOR X-Cys-Cys-X situations
1475              do k=j+1,iend(i,iint)
1476 C search over all next residues
1477               if (dyn_ss_mask(k)) then
1478 C check if they are cysteins
1479 C              write(iout,*) 'k=',k
1480
1481 c              write(iout,*) "PRZED TRI", evdwij
1482                evdwij_przed_tri=evdwij
1483               call triple_ssbond_ene(i,j,k,evdwij)
1484 c           write(iout,*) "TRISULFIDY:", i,j,k,evdwij
1485 c               if(evdwij_przed_tri.ne.evdwij) then
1486 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1487 c               endif
1488
1489 c              write(iout,*) "PO TRI", evdwij
1490 C call the energy function that removes the artifical triple disulfide
1491 C bond the soubroutine is located in ssMD.F
1492               evdw=evdw+evdwij
1493               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1494      &                        'evdw',i,j,evdwij,'tss'
1495               endif!dyn_ss_mask(k)
1496              enddo! k
1497             ELSE
1498             ind=ind+1
1499             itypj=iabs(itype(j))
1500             if (itypj.eq.ntyp1) cycle
1501 c            dscj_inv=dsc_inv(itypj)
1502             dscj_inv=vbld_inv(j+nres)
1503 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1504 c     &       1.0d0/vbld(j+nres)
1505 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1506             sig0ij=sigma(itypi,itypj)
1507             chi1=chi(itypi,itypj)
1508             chi2=chi(itypj,itypi)
1509             chi12=chi1*chi2
1510             chip1=chip(itypi)
1511             chip2=chip(itypj)
1512             chip12=chip1*chip2
1513             alf1=alp(itypi)
1514             alf2=alp(itypj)
1515             alf12=0.5D0*(alf1+alf2)
1516 C For diagnostics only!!!
1517 c           chi1=0.0D0
1518 c           chi2=0.0D0
1519 c           chi12=0.0D0
1520 c           chip1=0.0D0
1521 c           chip2=0.0D0
1522 c           chip12=0.0D0
1523 c           alf1=0.0D0
1524 c           alf2=0.0D0
1525 c           alf12=0.0D0
1526             xj=c(1,nres+j)-xi
1527             yj=c(2,nres+j)-yi
1528             zj=c(3,nres+j)-zi
1529             dxj=dc_norm(1,nres+j)
1530             dyj=dc_norm(2,nres+j)
1531             dzj=dc_norm(3,nres+j)
1532 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1533 c            write (iout,*) "j",j," dc_norm",
1534 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1535             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1536             rij=dsqrt(rrij)
1537 C Calculate angle-dependent terms of energy and contributions to their
1538 C derivatives.
1539             call sc_angular
1540             sigsq=1.0D0/sigsq
1541             sig=sig0ij*dsqrt(sigsq)
1542             rij_shift=1.0D0/rij-sig+sig0ij
1543 c for diagnostics; uncomment
1544 c            rij_shift=1.2*sig0ij
1545 C I hate to put IF's in the loops, but here don't have another choice!!!!
1546             if (rij_shift.le.0.0D0) then
1547               evdw=1.0D20
1548 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1549 cd     &        restyp(itypi),i,restyp(itypj),j,
1550 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1551               return
1552             endif
1553             sigder=-sig*sigsq
1554 c---------------------------------------------------------------
1555             rij_shift=1.0D0/rij_shift
1556             fac=rij_shift**expon
1557             e1=fac*fac*aa(itypi,itypj)
1558             e2=fac*bb(itypi,itypj)
1559             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1560             eps2der=evdwij*eps3rt
1561             eps3der=evdwij*eps2rt
1562 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1563 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1564             evdwij=evdwij*eps2rt*eps3rt
1565             evdw=evdw+evdwij
1566             if (lprn) then
1567             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1568             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1569             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1570      &        restyp(itypi),i,restyp(itypj),j,
1571      &        epsi,sigm,chi1,chi2,chip1,chip2,
1572      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1573      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1574      &        evdwij
1575             endif
1576
1577             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1578      &                        'evdw',i,j,evdwij
1579
1580 C Calculate gradient components.
1581             e1=e1*eps1*eps2rt**2*eps3rt**2
1582             fac=-expon*(e1+evdwij)*rij_shift
1583             sigder=fac*sigder
1584             fac=rij*fac
1585 c            fac=0.0d0
1586 C Calculate the radial part of the gradient
1587             gg(1)=xj*fac
1588             gg(2)=yj*fac
1589             gg(3)=zj*fac
1590 C Calculate angular part of the gradient.
1591             call sc_grad
1592             ENDIF    ! dyn_ss
1593           enddo      ! j
1594         enddo        ! iint
1595       enddo          ! i
1596 c      write (iout,*) "Number of loop steps in EGB:",ind
1597 cccc      energy_dec=.false.
1598       return
1599       end
1600 C-----------------------------------------------------------------------------
1601       subroutine egbv(evdw)
1602 C
1603 C This subroutine calculates the interaction energy of nonbonded side chains
1604 C assuming the Gay-Berne-Vorobjev potential of interaction.
1605 C
1606       implicit real*8 (a-h,o-z)
1607       include 'DIMENSIONS'
1608       include 'COMMON.GEO'
1609       include 'COMMON.VAR'
1610       include 'COMMON.LOCAL'
1611       include 'COMMON.CHAIN'
1612       include 'COMMON.DERIV'
1613       include 'COMMON.NAMES'
1614       include 'COMMON.INTERACT'
1615       include 'COMMON.IOUNITS'
1616       include 'COMMON.CALC'
1617       common /srutu/ icall
1618       logical lprn
1619       evdw=0.0D0
1620 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1621       evdw=0.0D0
1622       lprn=.false.
1623 c     if (icall.eq.0) lprn=.true.
1624       ind=0
1625       do i=iatsc_s,iatsc_e
1626         itypi=iabs(itype(i))
1627         if (itypi.eq.ntyp1) cycle
1628         itypi1=iabs(itype(i+1))
1629         xi=c(1,nres+i)
1630         yi=c(2,nres+i)
1631         zi=c(3,nres+i)
1632         dxi=dc_norm(1,nres+i)
1633         dyi=dc_norm(2,nres+i)
1634         dzi=dc_norm(3,nres+i)
1635 c        dsci_inv=dsc_inv(itypi)
1636         dsci_inv=vbld_inv(i+nres)
1637 C
1638 C Calculate SC interaction energy.
1639 C
1640         do iint=1,nint_gr(i)
1641           do j=istart(i,iint),iend(i,iint)
1642             ind=ind+1
1643             itypj=iabs(itype(j))
1644             if (itypj.eq.ntyp1) cycle
1645 c            dscj_inv=dsc_inv(itypj)
1646             dscj_inv=vbld_inv(j+nres)
1647             sig0ij=sigma(itypi,itypj)
1648             r0ij=r0(itypi,itypj)
1649             chi1=chi(itypi,itypj)
1650             chi2=chi(itypj,itypi)
1651             chi12=chi1*chi2
1652             chip1=chip(itypi)
1653             chip2=chip(itypj)
1654             chip12=chip1*chip2
1655             alf1=alp(itypi)
1656             alf2=alp(itypj)
1657             alf12=0.5D0*(alf1+alf2)
1658 C For diagnostics only!!!
1659 c           chi1=0.0D0
1660 c           chi2=0.0D0
1661 c           chi12=0.0D0
1662 c           chip1=0.0D0
1663 c           chip2=0.0D0
1664 c           chip12=0.0D0
1665 c           alf1=0.0D0
1666 c           alf2=0.0D0
1667 c           alf12=0.0D0
1668             xj=c(1,nres+j)-xi
1669             yj=c(2,nres+j)-yi
1670             zj=c(3,nres+j)-zi
1671             dxj=dc_norm(1,nres+j)
1672             dyj=dc_norm(2,nres+j)
1673             dzj=dc_norm(3,nres+j)
1674             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1675             rij=dsqrt(rrij)
1676 C Calculate angle-dependent terms of energy and contributions to their
1677 C derivatives.
1678             call sc_angular
1679             sigsq=1.0D0/sigsq
1680             sig=sig0ij*dsqrt(sigsq)
1681             rij_shift=1.0D0/rij-sig+r0ij
1682 C I hate to put IF's in the loops, but here don't have another choice!!!!
1683             if (rij_shift.le.0.0D0) then
1684               evdw=1.0D20
1685               return
1686             endif
1687             sigder=-sig*sigsq
1688 c---------------------------------------------------------------
1689             rij_shift=1.0D0/rij_shift
1690             fac=rij_shift**expon
1691             e1=fac*fac*aa(itypi,itypj)
1692             e2=fac*bb(itypi,itypj)
1693             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1694             eps2der=evdwij*eps3rt
1695             eps3der=evdwij*eps2rt
1696             fac_augm=rrij**expon
1697             e_augm=augm(itypi,itypj)*fac_augm
1698             evdwij=evdwij*eps2rt*eps3rt
1699             evdw=evdw+evdwij+e_augm
1700             if (lprn) then
1701             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1702             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1703             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1704      &        restyp(itypi),i,restyp(itypj),j,
1705      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1706      &        chi1,chi2,chip1,chip2,
1707      &        eps1,eps2rt**2,eps3rt**2,
1708      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1709      &        evdwij+e_augm
1710             endif
1711 C Calculate gradient components.
1712             e1=e1*eps1*eps2rt**2*eps3rt**2
1713             fac=-expon*(e1+evdwij)*rij_shift
1714             sigder=fac*sigder
1715             fac=rij*fac-2*expon*rrij*e_augm
1716 C Calculate the radial part of the gradient
1717             gg(1)=xj*fac
1718             gg(2)=yj*fac
1719             gg(3)=zj*fac
1720 C Calculate angular part of the gradient.
1721             call sc_grad
1722           enddo      ! j
1723         enddo        ! iint
1724       enddo          ! i
1725       end
1726 C-----------------------------------------------------------------------------
1727       subroutine sc_angular
1728 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1729 C om12. Called by ebp, egb, and egbv.
1730       implicit none
1731       include 'COMMON.CALC'
1732       include 'COMMON.IOUNITS'
1733       erij(1)=xj*rij
1734       erij(2)=yj*rij
1735       erij(3)=zj*rij
1736       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1737       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1738       om12=dxi*dxj+dyi*dyj+dzi*dzj
1739       chiom12=chi12*om12
1740 C Calculate eps1(om12) and its derivative in om12
1741       faceps1=1.0D0-om12*chiom12
1742       faceps1_inv=1.0D0/faceps1
1743       eps1=dsqrt(faceps1_inv)
1744 C Following variable is eps1*deps1/dom12
1745       eps1_om12=faceps1_inv*chiom12
1746 c diagnostics only
1747 c      faceps1_inv=om12
1748 c      eps1=om12
1749 c      eps1_om12=1.0d0
1750 c      write (iout,*) "om12",om12," eps1",eps1
1751 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1752 C and om12.
1753       om1om2=om1*om2
1754       chiom1=chi1*om1
1755       chiom2=chi2*om2
1756       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1757       sigsq=1.0D0-facsig*faceps1_inv
1758       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1759       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1760       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1761 c diagnostics only
1762 c      sigsq=1.0d0
1763 c      sigsq_om1=0.0d0
1764 c      sigsq_om2=0.0d0
1765 c      sigsq_om12=0.0d0
1766 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1767 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1768 c     &    " eps1",eps1
1769 C Calculate eps2 and its derivatives in om1, om2, and om12.
1770       chipom1=chip1*om1
1771       chipom2=chip2*om2
1772       chipom12=chip12*om12
1773       facp=1.0D0-om12*chipom12
1774       facp_inv=1.0D0/facp
1775       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1776 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1777 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1778 C Following variable is the square root of eps2
1779       eps2rt=1.0D0-facp1*facp_inv
1780 C Following three variables are the derivatives of the square root of eps
1781 C in om1, om2, and om12.
1782       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1783       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1784       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1785 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1786       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1787 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1788 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1789 c     &  " eps2rt_om12",eps2rt_om12
1790 C Calculate whole angle-dependent part of epsilon and contributions
1791 C to its derivatives
1792       return
1793       end
1794 C----------------------------------------------------------------------------
1795       subroutine sc_grad
1796       implicit real*8 (a-h,o-z)
1797       include 'DIMENSIONS'
1798       include 'COMMON.CHAIN'
1799       include 'COMMON.DERIV'
1800       include 'COMMON.CALC'
1801       include 'COMMON.IOUNITS'
1802       double precision dcosom1(3),dcosom2(3)
1803       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1804       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1805       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1806      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1807 c diagnostics only
1808 c      eom1=0.0d0
1809 c      eom2=0.0d0
1810 c      eom12=evdwij*eps1_om12
1811 c end diagnostics
1812 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1813 c     &  " sigder",sigder
1814 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1815 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1816       do k=1,3
1817         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1818         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1819       enddo
1820       do k=1,3
1821         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1822       enddo
1823 c      write (iout,*) "gg",(gg(k),k=1,3)
1824       do k=1,3
1825         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1826      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1827      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1828         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1829      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1830      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1831 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1832 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1833 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1834 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1835       enddo
1836 C
1837 C Calculate the components of the gradient in DC and X
1838 C
1839 cgrad      do k=i,j-1
1840 cgrad        do l=1,3
1841 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1842 cgrad        enddo
1843 cgrad      enddo
1844       do l=1,3
1845         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1846         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1847       enddo
1848       return
1849       end
1850 C-----------------------------------------------------------------------
1851       subroutine e_softsphere(evdw)
1852 C
1853 C This subroutine calculates the interaction energy of nonbonded side chains
1854 C assuming the LJ potential of interaction.
1855 C
1856       implicit real*8 (a-h,o-z)
1857       include 'DIMENSIONS'
1858       parameter (accur=1.0d-10)
1859       include 'COMMON.GEO'
1860       include 'COMMON.VAR'
1861       include 'COMMON.LOCAL'
1862       include 'COMMON.CHAIN'
1863       include 'COMMON.DERIV'
1864       include 'COMMON.INTERACT'
1865       include 'COMMON.TORSION'
1866       include 'COMMON.SBRIDGE'
1867       include 'COMMON.NAMES'
1868       include 'COMMON.IOUNITS'
1869       include 'COMMON.CONTACTS'
1870       dimension gg(3)
1871 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1872       evdw=0.0D0
1873       do i=iatsc_s,iatsc_e
1874         itypi=iabs(itype(i))
1875         if (itypi.eq.ntyp1) cycle
1876         itypi1=iabs(itype(i+1))
1877         xi=c(1,nres+i)
1878         yi=c(2,nres+i)
1879         zi=c(3,nres+i)
1880 C
1881 C Calculate SC interaction energy.
1882 C
1883         do iint=1,nint_gr(i)
1884 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1885 cd   &                  'iend=',iend(i,iint)
1886           do j=istart(i,iint),iend(i,iint)
1887             itypj=iabs(itype(j))
1888             if (itypj.eq.ntyp1) cycle
1889             xj=c(1,nres+j)-xi
1890             yj=c(2,nres+j)-yi
1891             zj=c(3,nres+j)-zi
1892             rij=xj*xj+yj*yj+zj*zj
1893 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1894             r0ij=r0(itypi,itypj)
1895             r0ijsq=r0ij*r0ij
1896 c            print *,i,j,r0ij,dsqrt(rij)
1897             if (rij.lt.r0ijsq) then
1898               evdwij=0.25d0*(rij-r0ijsq)**2
1899               fac=rij-r0ijsq
1900             else
1901               evdwij=0.0d0
1902               fac=0.0d0
1903             endif
1904             evdw=evdw+evdwij
1905 C
1906 C Calculate the components of the gradient in DC and X
1907 C
1908             gg(1)=xj*fac
1909             gg(2)=yj*fac
1910             gg(3)=zj*fac
1911             do k=1,3
1912               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1913               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1914               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1915               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1916             enddo
1917 cgrad            do k=i,j-1
1918 cgrad              do l=1,3
1919 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1920 cgrad              enddo
1921 cgrad            enddo
1922           enddo ! j
1923         enddo ! iint
1924       enddo ! i
1925       return
1926       end
1927 C--------------------------------------------------------------------------
1928       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1929      &              eello_turn4)
1930 C
1931 C Soft-sphere potential of p-p interaction
1932 C
1933       implicit real*8 (a-h,o-z)
1934       include 'DIMENSIONS'
1935       include 'COMMON.CONTROL'
1936       include 'COMMON.IOUNITS'
1937       include 'COMMON.GEO'
1938       include 'COMMON.VAR'
1939       include 'COMMON.LOCAL'
1940       include 'COMMON.CHAIN'
1941       include 'COMMON.DERIV'
1942       include 'COMMON.INTERACT'
1943       include 'COMMON.CONTACTS'
1944       include 'COMMON.TORSION'
1945       include 'COMMON.VECTORS'
1946       include 'COMMON.FFIELD'
1947       dimension ggg(3)
1948 cd      write(iout,*) 'In EELEC_soft_sphere'
1949       ees=0.0D0
1950       evdw1=0.0D0
1951       eel_loc=0.0d0
1952       eello_turn3=0.0d0
1953       eello_turn4=0.0d0
1954       ind=0
1955       do i=iatel_s,iatel_e
1956         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1957         dxi=dc(1,i)
1958         dyi=dc(2,i)
1959         dzi=dc(3,i)
1960         xmedi=c(1,i)+0.5d0*dxi
1961         ymedi=c(2,i)+0.5d0*dyi
1962         zmedi=c(3,i)+0.5d0*dzi
1963         num_conti=0
1964 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1965         do j=ielstart(i),ielend(i)
1966           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1967           ind=ind+1
1968           iteli=itel(i)
1969           itelj=itel(j)
1970           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1971           r0ij=rpp(iteli,itelj)
1972           r0ijsq=r0ij*r0ij
1973           dxj=dc(1,j)
1974           dyj=dc(2,j)
1975           dzj=dc(3,j)
1976           xj=c(1,j)+0.5D0*dxj-xmedi
1977           yj=c(2,j)+0.5D0*dyj-ymedi
1978           zj=c(3,j)+0.5D0*dzj-zmedi
1979           rij=xj*xj+yj*yj+zj*zj
1980           if (rij.lt.r0ijsq) then
1981             evdw1ij=0.25d0*(rij-r0ijsq)**2
1982             fac=rij-r0ijsq
1983           else
1984             evdw1ij=0.0d0
1985             fac=0.0d0
1986           endif
1987           evdw1=evdw1+evdw1ij
1988 C
1989 C Calculate contributions to the Cartesian gradient.
1990 C
1991           ggg(1)=fac*xj
1992           ggg(2)=fac*yj
1993           ggg(3)=fac*zj
1994           do k=1,3
1995             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1996             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1997           enddo
1998 *
1999 * Loop over residues i+1 thru j-1.
2000 *
2001 cgrad          do k=i+1,j-1
2002 cgrad            do l=1,3
2003 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2004 cgrad            enddo
2005 cgrad          enddo
2006         enddo ! j
2007       enddo   ! i
2008 cgrad      do i=nnt,nct-1
2009 cgrad        do k=1,3
2010 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2011 cgrad        enddo
2012 cgrad        do j=i+1,nct-1
2013 cgrad          do k=1,3
2014 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2015 cgrad          enddo
2016 cgrad        enddo
2017 cgrad      enddo
2018       return
2019       end
2020 c------------------------------------------------------------------------------
2021       subroutine vec_and_deriv
2022       implicit real*8 (a-h,o-z)
2023       include 'DIMENSIONS'
2024 #ifdef MPI
2025       include 'mpif.h'
2026 #endif
2027       include 'COMMON.IOUNITS'
2028       include 'COMMON.GEO'
2029       include 'COMMON.VAR'
2030       include 'COMMON.LOCAL'
2031       include 'COMMON.CHAIN'
2032       include 'COMMON.VECTORS'
2033       include 'COMMON.SETUP'
2034       include 'COMMON.TIME1'
2035       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2036 C Compute the local reference systems. For reference system (i), the
2037 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2038 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2039 #ifdef PARVEC
2040       do i=ivec_start,ivec_end
2041 #else
2042       do i=1,nres-1
2043 #endif
2044           if (i.eq.nres-1) then
2045 C Case of the last full residue
2046 C Compute the Z-axis
2047             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2048             costh=dcos(pi-theta(nres))
2049             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2050             do k=1,3
2051               uz(k,i)=fac*uz(k,i)
2052             enddo
2053 C Compute the derivatives of uz
2054             uzder(1,1,1)= 0.0d0
2055             uzder(2,1,1)=-dc_norm(3,i-1)
2056             uzder(3,1,1)= dc_norm(2,i-1)
2057             uzder(1,2,1)= dc_norm(3,i-1)
2058             uzder(2,2,1)= 0.0d0
2059             uzder(3,2,1)=-dc_norm(1,i-1)
2060             uzder(1,3,1)=-dc_norm(2,i-1)
2061             uzder(2,3,1)= dc_norm(1,i-1)
2062             uzder(3,3,1)= 0.0d0
2063             uzder(1,1,2)= 0.0d0
2064             uzder(2,1,2)= dc_norm(3,i)
2065             uzder(3,1,2)=-dc_norm(2,i)
2066             uzder(1,2,2)=-dc_norm(3,i)
2067             uzder(2,2,2)= 0.0d0
2068             uzder(3,2,2)= dc_norm(1,i)
2069             uzder(1,3,2)= dc_norm(2,i)
2070             uzder(2,3,2)=-dc_norm(1,i)
2071             uzder(3,3,2)= 0.0d0
2072 C Compute the Y-axis
2073             facy=fac
2074             do k=1,3
2075               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2076             enddo
2077 C Compute the derivatives of uy
2078             do j=1,3
2079               do k=1,3
2080                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2081      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2082                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2083               enddo
2084               uyder(j,j,1)=uyder(j,j,1)-costh
2085               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2086             enddo
2087             do j=1,2
2088               do k=1,3
2089                 do l=1,3
2090                   uygrad(l,k,j,i)=uyder(l,k,j)
2091                   uzgrad(l,k,j,i)=uzder(l,k,j)
2092                 enddo
2093               enddo
2094             enddo
2095             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2096             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2097             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2098             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2099           else
2100 C Other residues
2101 C Compute the Z-axis
2102             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2103             costh=dcos(pi-theta(i+2))
2104             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2105             do k=1,3
2106               uz(k,i)=fac*uz(k,i)
2107             enddo
2108 C Compute the derivatives of uz
2109             uzder(1,1,1)= 0.0d0
2110             uzder(2,1,1)=-dc_norm(3,i+1)
2111             uzder(3,1,1)= dc_norm(2,i+1)
2112             uzder(1,2,1)= dc_norm(3,i+1)
2113             uzder(2,2,1)= 0.0d0
2114             uzder(3,2,1)=-dc_norm(1,i+1)
2115             uzder(1,3,1)=-dc_norm(2,i+1)
2116             uzder(2,3,1)= dc_norm(1,i+1)
2117             uzder(3,3,1)= 0.0d0
2118             uzder(1,1,2)= 0.0d0
2119             uzder(2,1,2)= dc_norm(3,i)
2120             uzder(3,1,2)=-dc_norm(2,i)
2121             uzder(1,2,2)=-dc_norm(3,i)
2122             uzder(2,2,2)= 0.0d0
2123             uzder(3,2,2)= dc_norm(1,i)
2124             uzder(1,3,2)= dc_norm(2,i)
2125             uzder(2,3,2)=-dc_norm(1,i)
2126             uzder(3,3,2)= 0.0d0
2127 C Compute the Y-axis
2128             facy=fac
2129             do k=1,3
2130               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2131             enddo
2132 C Compute the derivatives of uy
2133             do j=1,3
2134               do k=1,3
2135                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2136      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2137                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2138               enddo
2139               uyder(j,j,1)=uyder(j,j,1)-costh
2140               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2141             enddo
2142             do j=1,2
2143               do k=1,3
2144                 do l=1,3
2145                   uygrad(l,k,j,i)=uyder(l,k,j)
2146                   uzgrad(l,k,j,i)=uzder(l,k,j)
2147                 enddo
2148               enddo
2149             enddo
2150             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2151             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2152             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2153             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2154           endif
2155       enddo
2156       do i=1,nres-1
2157         vbld_inv_temp(1)=vbld_inv(i+1)
2158         if (i.lt.nres-1) then
2159           vbld_inv_temp(2)=vbld_inv(i+2)
2160           else
2161           vbld_inv_temp(2)=vbld_inv(i)
2162           endif
2163         do j=1,2
2164           do k=1,3
2165             do l=1,3
2166               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2167               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2168             enddo
2169           enddo
2170         enddo
2171       enddo
2172 #if defined(PARVEC) && defined(MPI)
2173       if (nfgtasks1.gt.1) then
2174         time00=MPI_Wtime()
2175 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2176 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2177 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2178         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2179      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2180      &   FG_COMM1,IERR)
2181         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2182      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2183      &   FG_COMM1,IERR)
2184         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2185      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2186      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2187         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2188      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2189      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2190         time_gather=time_gather+MPI_Wtime()-time00
2191       endif
2192 c      if (fg_rank.eq.0) then
2193 c        write (iout,*) "Arrays UY and UZ"
2194 c        do i=1,nres-1
2195 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2196 c     &     (uz(k,i),k=1,3)
2197 c        enddo
2198 c      endif
2199 #endif
2200       return
2201       end
2202 C-----------------------------------------------------------------------------
2203       subroutine check_vecgrad
2204       implicit real*8 (a-h,o-z)
2205       include 'DIMENSIONS'
2206       include 'COMMON.IOUNITS'
2207       include 'COMMON.GEO'
2208       include 'COMMON.VAR'
2209       include 'COMMON.LOCAL'
2210       include 'COMMON.CHAIN'
2211       include 'COMMON.VECTORS'
2212       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2213       dimension uyt(3,maxres),uzt(3,maxres)
2214       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2215       double precision delta /1.0d-7/
2216       call vec_and_deriv
2217 cd      do i=1,nres
2218 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2219 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2220 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2221 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2222 cd     &     (dc_norm(if90,i),if90=1,3)
2223 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2224 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2225 cd          write(iout,'(a)')
2226 cd      enddo
2227       do i=1,nres
2228         do j=1,2
2229           do k=1,3
2230             do l=1,3
2231               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2232               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2233             enddo
2234           enddo
2235         enddo
2236       enddo
2237       call vec_and_deriv
2238       do i=1,nres
2239         do j=1,3
2240           uyt(j,i)=uy(j,i)
2241           uzt(j,i)=uz(j,i)
2242         enddo
2243       enddo
2244       do i=1,nres
2245 cd        write (iout,*) 'i=',i
2246         do k=1,3
2247           erij(k)=dc_norm(k,i)
2248         enddo
2249         do j=1,3
2250           do k=1,3
2251             dc_norm(k,i)=erij(k)
2252           enddo
2253           dc_norm(j,i)=dc_norm(j,i)+delta
2254 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2255 c          do k=1,3
2256 c            dc_norm(k,i)=dc_norm(k,i)/fac
2257 c          enddo
2258 c          write (iout,*) (dc_norm(k,i),k=1,3)
2259 c          write (iout,*) (erij(k),k=1,3)
2260           call vec_and_deriv
2261           do k=1,3
2262             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2263             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2264             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2265             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2266           enddo
2267 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2268 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2269 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2270         enddo
2271         do k=1,3
2272           dc_norm(k,i)=erij(k)
2273         enddo
2274 cd        do k=1,3
2275 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2276 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2277 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2278 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2279 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2280 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2281 cd          write (iout,'(a)')
2282 cd        enddo
2283       enddo
2284       return
2285       end
2286 C--------------------------------------------------------------------------
2287       subroutine set_matrices
2288       implicit real*8 (a-h,o-z)
2289       include 'DIMENSIONS'
2290 #ifdef MPI
2291       include "mpif.h"
2292       include "COMMON.SETUP"
2293       integer IERR
2294       integer status(MPI_STATUS_SIZE)
2295 #endif
2296       include 'COMMON.IOUNITS'
2297       include 'COMMON.GEO'
2298       include 'COMMON.VAR'
2299       include 'COMMON.LOCAL'
2300       include 'COMMON.CHAIN'
2301       include 'COMMON.DERIV'
2302       include 'COMMON.INTERACT'
2303       include 'COMMON.CONTACTS'
2304       include 'COMMON.TORSION'
2305       include 'COMMON.VECTORS'
2306       include 'COMMON.FFIELD'
2307       double precision auxvec(2),auxmat(2,2)
2308 C
2309 C Compute the virtual-bond-torsional-angle dependent quantities needed
2310 C to calculate the el-loc multibody terms of various order.
2311 C
2312 #ifdef PARMAT
2313       do i=ivec_start+2,ivec_end+2
2314 #else
2315       do i=3,nres+1
2316 #endif
2317         if (i .lt. nres+1) then
2318           sin1=dsin(phi(i))
2319           cos1=dcos(phi(i))
2320           sintab(i-2)=sin1
2321           costab(i-2)=cos1
2322           obrot(1,i-2)=cos1
2323           obrot(2,i-2)=sin1
2324           sin2=dsin(2*phi(i))
2325           cos2=dcos(2*phi(i))
2326           sintab2(i-2)=sin2
2327           costab2(i-2)=cos2
2328           obrot2(1,i-2)=cos2
2329           obrot2(2,i-2)=sin2
2330           Ug(1,1,i-2)=-cos1
2331           Ug(1,2,i-2)=-sin1
2332           Ug(2,1,i-2)=-sin1
2333           Ug(2,2,i-2)= cos1
2334           Ug2(1,1,i-2)=-cos2
2335           Ug2(1,2,i-2)=-sin2
2336           Ug2(2,1,i-2)=-sin2
2337           Ug2(2,2,i-2)= cos2
2338         else
2339           costab(i-2)=1.0d0
2340           sintab(i-2)=0.0d0
2341           obrot(1,i-2)=1.0d0
2342           obrot(2,i-2)=0.0d0
2343           obrot2(1,i-2)=0.0d0
2344           obrot2(2,i-2)=0.0d0
2345           Ug(1,1,i-2)=1.0d0
2346           Ug(1,2,i-2)=0.0d0
2347           Ug(2,1,i-2)=0.0d0
2348           Ug(2,2,i-2)=1.0d0
2349           Ug2(1,1,i-2)=0.0d0
2350           Ug2(1,2,i-2)=0.0d0
2351           Ug2(2,1,i-2)=0.0d0
2352           Ug2(2,2,i-2)=0.0d0
2353         endif
2354         if (i .gt. 3 .and. i .lt. nres+1) then
2355           obrot_der(1,i-2)=-sin1
2356           obrot_der(2,i-2)= cos1
2357           Ugder(1,1,i-2)= sin1
2358           Ugder(1,2,i-2)=-cos1
2359           Ugder(2,1,i-2)=-cos1
2360           Ugder(2,2,i-2)=-sin1
2361           dwacos2=cos2+cos2
2362           dwasin2=sin2+sin2
2363           obrot2_der(1,i-2)=-dwasin2
2364           obrot2_der(2,i-2)= dwacos2
2365           Ug2der(1,1,i-2)= dwasin2
2366           Ug2der(1,2,i-2)=-dwacos2
2367           Ug2der(2,1,i-2)=-dwacos2
2368           Ug2der(2,2,i-2)=-dwasin2
2369         else
2370           obrot_der(1,i-2)=0.0d0
2371           obrot_der(2,i-2)=0.0d0
2372           Ugder(1,1,i-2)=0.0d0
2373           Ugder(1,2,i-2)=0.0d0
2374           Ugder(2,1,i-2)=0.0d0
2375           Ugder(2,2,i-2)=0.0d0
2376           obrot2_der(1,i-2)=0.0d0
2377           obrot2_der(2,i-2)=0.0d0
2378           Ug2der(1,1,i-2)=0.0d0
2379           Ug2der(1,2,i-2)=0.0d0
2380           Ug2der(2,1,i-2)=0.0d0
2381           Ug2der(2,2,i-2)=0.0d0
2382         endif
2383 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2384         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2385           iti = itortyp(itype(i-2))
2386         else
2387           iti=ntortyp+1
2388         endif
2389 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2390         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2391           iti1 = itortyp(itype(i-1))
2392         else
2393           iti1=ntortyp+1
2394         endif
2395 cd        write (iout,*) '*******i',i,' iti1',iti
2396 cd        write (iout,*) 'b1',b1(:,iti)
2397 cd        write (iout,*) 'b2',b2(:,iti)
2398 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2399 c        if (i .gt. iatel_s+2) then
2400         if (i .gt. nnt+2) then
2401           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2402           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2403           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2404      &    then
2405           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2406           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2407           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2408           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2409           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2410           endif
2411         else
2412           do k=1,2
2413             Ub2(k,i-2)=0.0d0
2414             Ctobr(k,i-2)=0.0d0
2415             Dtobr2(k,i-2)=0.0d0
2416             do l=1,2
2417               EUg(l,k,i-2)=0.0d0
2418               CUg(l,k,i-2)=0.0d0
2419               DUg(l,k,i-2)=0.0d0
2420               DtUg2(l,k,i-2)=0.0d0
2421             enddo
2422           enddo
2423         endif
2424         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2425         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2426         do k=1,2
2427           muder(k,i-2)=Ub2der(k,i-2)
2428         enddo
2429 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2430         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2431           if (itype(i-1).le.ntyp) then
2432             iti1 = itortyp(itype(i-1))
2433           else
2434             iti1=ntortyp+1
2435           endif
2436         else
2437           iti1=ntortyp+1
2438         endif
2439         do k=1,2
2440           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2441         enddo
2442 cd        write (iout,*) 'mu ',mu(:,i-2)
2443 cd        write (iout,*) 'mu1',mu1(:,i-2)
2444 cd        write (iout,*) 'mu2',mu2(:,i-2)
2445         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2446      &  then
2447         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2448         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2449         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2450         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2451         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2452 C Vectors and matrices dependent on a single virtual-bond dihedral.
2453         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2454         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2455         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2456         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2457         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2458         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2459         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2460         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2461         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2462         endif
2463       enddo
2464 C Matrices dependent on two consecutive virtual-bond dihedrals.
2465 C The order of matrices is from left to right.
2466       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2467      &then
2468 c      do i=max0(ivec_start,2),ivec_end
2469       do i=2,nres-1
2470         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2471         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2472         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2473         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2474         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2475         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2476         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2477         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2478       enddo
2479       endif
2480 #if defined(MPI) && defined(PARMAT)
2481 #ifdef DEBUG
2482 c      if (fg_rank.eq.0) then
2483         write (iout,*) "Arrays UG and UGDER before GATHER"
2484         do i=1,nres-1
2485           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2486      &     ((ug(l,k,i),l=1,2),k=1,2),
2487      &     ((ugder(l,k,i),l=1,2),k=1,2)
2488         enddo
2489         write (iout,*) "Arrays UG2 and UG2DER"
2490         do i=1,nres-1
2491           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2492      &     ((ug2(l,k,i),l=1,2),k=1,2),
2493      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2494         enddo
2495         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2496         do i=1,nres-1
2497           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2498      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2499      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2500         enddo
2501         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2502         do i=1,nres-1
2503           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2504      &     costab(i),sintab(i),costab2(i),sintab2(i)
2505         enddo
2506         write (iout,*) "Array MUDER"
2507         do i=1,nres-1
2508           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2509         enddo
2510 c      endif
2511 #endif
2512       if (nfgtasks.gt.1) then
2513         time00=MPI_Wtime()
2514 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2515 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2516 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2517 #ifdef MATGATHER
2518         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2534      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2535      &   FG_COMM1,IERR)
2536         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2537      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2538      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2539         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2540      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2541      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2542         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2543      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2544      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2545         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2546      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2547      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2548         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2549      &  then
2550         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2557      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2558      &   FG_COMM1,IERR)
2559        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2563      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2564      &   FG_COMM1,IERR)
2565         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2566      &   ivec_count(fg_rank1),
2567      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2568      &   FG_COMM1,IERR)
2569         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2573      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2574      &   FG_COMM1,IERR)
2575         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2576      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2577      &   FG_COMM1,IERR)
2578         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2579      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2582      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2583      &   FG_COMM1,IERR)
2584         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2589      &   FG_COMM1,IERR)
2590         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2591      &   ivec_count(fg_rank1),
2592      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2593      &   FG_COMM1,IERR)
2594         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2596      &   FG_COMM1,IERR)
2597        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2598      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2601      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2602      &   FG_COMM1,IERR)
2603        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2605      &   FG_COMM1,IERR)
2606         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2607      &   ivec_count(fg_rank1),
2608      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2609      &   FG_COMM1,IERR)
2610         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2611      &   ivec_count(fg_rank1),
2612      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2613      &   FG_COMM1,IERR)
2614         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2615      &   ivec_count(fg_rank1),
2616      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2617      &   MPI_MAT2,FG_COMM1,IERR)
2618         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2619      &   ivec_count(fg_rank1),
2620      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2621      &   MPI_MAT2,FG_COMM1,IERR)
2622         endif
2623 #else
2624 c Passes matrix info through the ring
2625       isend=fg_rank1
2626       irecv=fg_rank1-1
2627       if (irecv.lt.0) irecv=nfgtasks1-1
2628       iprev=irecv
2629       inext=fg_rank1+1
2630       if (inext.ge.nfgtasks1) inext=0
2631       do i=1,nfgtasks1-1
2632 c        write (iout,*) "isend",isend," irecv",irecv
2633 c        call flush(iout)
2634         lensend=lentyp(isend)
2635         lenrecv=lentyp(irecv)
2636 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2637 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2638 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2639 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2640 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2641 c        write (iout,*) "Gather ROTAT1"
2642 c        call flush(iout)
2643 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2644 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2645 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2646 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2647 c        write (iout,*) "Gather ROTAT2"
2648 c        call flush(iout)
2649         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2650      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2651      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2652      &   iprev,4400+irecv,FG_COMM,status,IERR)
2653 c        write (iout,*) "Gather ROTAT_OLD"
2654 c        call flush(iout)
2655         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2656      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2657      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2658      &   iprev,5500+irecv,FG_COMM,status,IERR)
2659 c        write (iout,*) "Gather PRECOMP11"
2660 c        call flush(iout)
2661         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2662      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2663      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2664      &   iprev,6600+irecv,FG_COMM,status,IERR)
2665 c        write (iout,*) "Gather PRECOMP12"
2666 c        call flush(iout)
2667         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2668      &  then
2669         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2670      &   MPI_ROTAT2(lensend),inext,7700+isend,
2671      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2672      &   iprev,7700+irecv,FG_COMM,status,IERR)
2673 c        write (iout,*) "Gather PRECOMP21"
2674 c        call flush(iout)
2675         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2676      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2677      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2678      &   iprev,8800+irecv,FG_COMM,status,IERR)
2679 c        write (iout,*) "Gather PRECOMP22"
2680 c        call flush(iout)
2681         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2682      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2683      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2684      &   MPI_PRECOMP23(lenrecv),
2685      &   iprev,9900+irecv,FG_COMM,status,IERR)
2686 c        write (iout,*) "Gather PRECOMP23"
2687 c        call flush(iout)
2688         endif
2689         isend=irecv
2690         irecv=irecv-1
2691         if (irecv.lt.0) irecv=nfgtasks1-1
2692       enddo
2693 #endif
2694         time_gather=time_gather+MPI_Wtime()-time00
2695       endif
2696 #ifdef DEBUG
2697 c      if (fg_rank.eq.0) then
2698         write (iout,*) "Arrays UG and UGDER"
2699         do i=1,nres-1
2700           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2701      &     ((ug(l,k,i),l=1,2),k=1,2),
2702      &     ((ugder(l,k,i),l=1,2),k=1,2)
2703         enddo
2704         write (iout,*) "Arrays UG2 and UG2DER"
2705         do i=1,nres-1
2706           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2707      &     ((ug2(l,k,i),l=1,2),k=1,2),
2708      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2709         enddo
2710         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2711         do i=1,nres-1
2712           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2713      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2714      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2715         enddo
2716         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2717         do i=1,nres-1
2718           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2719      &     costab(i),sintab(i),costab2(i),sintab2(i)
2720         enddo
2721         write (iout,*) "Array MUDER"
2722         do i=1,nres-1
2723           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2724         enddo
2725 c      endif
2726 #endif
2727 #endif
2728 cd      do i=1,nres
2729 cd        iti = itortyp(itype(i))
2730 cd        write (iout,*) i
2731 cd        do j=1,2
2732 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2733 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2734 cd        enddo
2735 cd      enddo
2736       return
2737       end
2738 C--------------------------------------------------------------------------
2739       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2740 C
2741 C This subroutine calculates the average interaction energy and its gradient
2742 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2743 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2744 C The potential depends both on the distance of peptide-group centers and on
2745 C the orientation of the CA-CA virtual bonds.
2746 C
2747       implicit real*8 (a-h,o-z)
2748 #ifdef MPI
2749       include 'mpif.h'
2750 #endif
2751       include 'DIMENSIONS'
2752       include 'COMMON.CONTROL'
2753       include 'COMMON.SETUP'
2754       include 'COMMON.IOUNITS'
2755       include 'COMMON.GEO'
2756       include 'COMMON.VAR'
2757       include 'COMMON.LOCAL'
2758       include 'COMMON.CHAIN'
2759       include 'COMMON.DERIV'
2760       include 'COMMON.INTERACT'
2761       include 'COMMON.CONTACTS'
2762       include 'COMMON.TORSION'
2763       include 'COMMON.VECTORS'
2764       include 'COMMON.FFIELD'
2765       include 'COMMON.TIME1'
2766       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2767      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2768       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2769      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2770       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2771      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2772      &    num_conti,j1,j2
2773 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2774 #ifdef MOMENT
2775       double precision scal_el /1.0d0/
2776 #else
2777       double precision scal_el /0.5d0/
2778 #endif
2779 C 12/13/98
2780 C 13-go grudnia roku pamietnego...
2781       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2782      &                   0.0d0,1.0d0,0.0d0,
2783      &                   0.0d0,0.0d0,1.0d0/
2784 cd      write(iout,*) 'In EELEC'
2785 cd      do i=1,nloctyp
2786 cd        write(iout,*) 'Type',i
2787 cd        write(iout,*) 'B1',B1(:,i)
2788 cd        write(iout,*) 'B2',B2(:,i)
2789 cd        write(iout,*) 'CC',CC(:,:,i)
2790 cd        write(iout,*) 'DD',DD(:,:,i)
2791 cd        write(iout,*) 'EE',EE(:,:,i)
2792 cd      enddo
2793 cd      call check_vecgrad
2794 cd      stop
2795       if (icheckgrad.eq.1) then
2796         do i=1,nres-1
2797           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2798           do k=1,3
2799             dc_norm(k,i)=dc(k,i)*fac
2800           enddo
2801 c          write (iout,*) 'i',i,' fac',fac
2802         enddo
2803       endif
2804       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2805      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2806      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2807 c        call vec_and_deriv
2808 #ifdef TIMING
2809         time01=MPI_Wtime()
2810 #endif
2811         call set_matrices
2812 #ifdef TIMING
2813         time_mat=time_mat+MPI_Wtime()-time01
2814 #endif
2815       endif
2816 cd      do i=1,nres-1
2817 cd        write (iout,*) 'i=',i
2818 cd        do k=1,3
2819 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2820 cd        enddo
2821 cd        do k=1,3
2822 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2823 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2824 cd        enddo
2825 cd      enddo
2826       t_eelecij=0.0d0
2827       ees=0.0D0
2828       evdw1=0.0D0
2829       eel_loc=0.0d0
2830       eello_turn3=0.0d0
2831       eello_turn4=0.0d0
2832       ind=0
2833       do i=1,nres
2834         num_cont_hb(i)=0
2835       enddo
2836 cd      print '(a)','Enter EELEC'
2837 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2838       do i=1,nres
2839         gel_loc_loc(i)=0.0d0
2840         gcorr_loc(i)=0.0d0
2841       enddo
2842 c
2843 c
2844 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2845 C
2846 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2847 C
2848       do i=iturn3_start,iturn3_end
2849         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2850      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2851         dxi=dc(1,i)
2852         dyi=dc(2,i)
2853         dzi=dc(3,i)
2854         dx_normi=dc_norm(1,i)
2855         dy_normi=dc_norm(2,i)
2856         dz_normi=dc_norm(3,i)
2857         xmedi=c(1,i)+0.5d0*dxi
2858         ymedi=c(2,i)+0.5d0*dyi
2859         zmedi=c(3,i)+0.5d0*dzi
2860         num_conti=0
2861         call eelecij(i,i+2,ees,evdw1,eel_loc)
2862         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2863         num_cont_hb(i)=num_conti
2864       enddo
2865       do i=iturn4_start,iturn4_end
2866         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2867      &    .or. itype(i+3).eq.ntyp1
2868      &    .or. itype(i+4).eq.ntyp1) cycle
2869         dxi=dc(1,i)
2870         dyi=dc(2,i)
2871         dzi=dc(3,i)
2872         dx_normi=dc_norm(1,i)
2873         dy_normi=dc_norm(2,i)
2874         dz_normi=dc_norm(3,i)
2875         xmedi=c(1,i)+0.5d0*dxi
2876         ymedi=c(2,i)+0.5d0*dyi
2877         zmedi=c(3,i)+0.5d0*dzi
2878         num_conti=num_cont_hb(i)
2879         call eelecij(i,i+3,ees,evdw1,eel_loc)
2880         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2881      &   call eturn4(i,eello_turn4)
2882         num_cont_hb(i)=num_conti
2883       enddo   ! i
2884 c
2885 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2886 c
2887       do i=iatel_s,iatel_e
2888         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2889         dxi=dc(1,i)
2890         dyi=dc(2,i)
2891         dzi=dc(3,i)
2892         dx_normi=dc_norm(1,i)
2893         dy_normi=dc_norm(2,i)
2894         dz_normi=dc_norm(3,i)
2895         xmedi=c(1,i)+0.5d0*dxi
2896         ymedi=c(2,i)+0.5d0*dyi
2897         zmedi=c(3,i)+0.5d0*dzi
2898 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2899         num_conti=num_cont_hb(i)
2900         do j=ielstart(i),ielend(i)
2901 c          write (iout,*) i,j,itype(i),itype(j)
2902           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2903           call eelecij(i,j,ees,evdw1,eel_loc)
2904         enddo ! j
2905         num_cont_hb(i)=num_conti
2906       enddo   ! i
2907 c      write (iout,*) "Number of loop steps in EELEC:",ind
2908 cd      do i=1,nres
2909 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2910 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2911 cd      enddo
2912 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2913 ccc      eel_loc=eel_loc+eello_turn3
2914 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2915       return
2916       end
2917 C-------------------------------------------------------------------------------
2918       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2919       implicit real*8 (a-h,o-z)
2920       include 'DIMENSIONS'
2921 #ifdef MPI
2922       include "mpif.h"
2923 #endif
2924       include 'COMMON.CONTROL'
2925       include 'COMMON.IOUNITS'
2926       include 'COMMON.GEO'
2927       include 'COMMON.VAR'
2928       include 'COMMON.LOCAL'
2929       include 'COMMON.CHAIN'
2930       include 'COMMON.DERIV'
2931       include 'COMMON.INTERACT'
2932       include 'COMMON.CONTACTS'
2933       include 'COMMON.TORSION'
2934       include 'COMMON.VECTORS'
2935       include 'COMMON.FFIELD'
2936       include 'COMMON.TIME1'
2937       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2938      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2939       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2940      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2941       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2942      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2943      &    num_conti,j1,j2
2944 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2945 #ifdef MOMENT
2946       double precision scal_el /1.0d0/
2947 #else
2948       double precision scal_el /0.5d0/
2949 #endif
2950 C 12/13/98
2951 C 13-go grudnia roku pamietnego...
2952       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2953      &                   0.0d0,1.0d0,0.0d0,
2954      &                   0.0d0,0.0d0,1.0d0/
2955 c          time00=MPI_Wtime()
2956 cd      write (iout,*) "eelecij",i,j
2957 c          ind=ind+1
2958           iteli=itel(i)
2959           itelj=itel(j)
2960           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2961           aaa=app(iteli,itelj)
2962           bbb=bpp(iteli,itelj)
2963           ael6i=ael6(iteli,itelj)
2964           ael3i=ael3(iteli,itelj)
2965           dxj=dc(1,j)
2966           dyj=dc(2,j)
2967           dzj=dc(3,j)
2968           dx_normj=dc_norm(1,j)
2969           dy_normj=dc_norm(2,j)
2970           dz_normj=dc_norm(3,j)
2971           xj=c(1,j)+0.5D0*dxj-xmedi
2972           yj=c(2,j)+0.5D0*dyj-ymedi
2973           zj=c(3,j)+0.5D0*dzj-zmedi
2974           rij=xj*xj+yj*yj+zj*zj
2975           rrmij=1.0D0/rij
2976           rij=dsqrt(rij)
2977           rmij=1.0D0/rij
2978           r3ij=rrmij*rmij
2979           r6ij=r3ij*r3ij
2980           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2981           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2982           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2983           fac=cosa-3.0D0*cosb*cosg
2984           ev1=aaa*r6ij*r6ij
2985 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2986           if (j.eq.i+2) ev1=scal_el*ev1
2987           ev2=bbb*r6ij
2988           fac3=ael6i*r6ij
2989           fac4=ael3i*r3ij
2990           evdwij=ev1+ev2
2991           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2992           el2=fac4*fac
2993           eesij=el1+el2
2994 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2995           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2996           ees=ees+eesij
2997           evdw1=evdw1+evdwij
2998 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2999 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3000 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3001 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3002
3003           if (energy_dec) then
3004               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3005      &'evdw1',i,j,evdwij
3006      &,iteli,itelj,aaa,evdw1
3007               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3008           endif
3009
3010 C
3011 C Calculate contributions to the Cartesian gradient.
3012 C
3013 #ifdef SPLITELE
3014           facvdw=-6*rrmij*(ev1+evdwij)
3015           facel=-3*rrmij*(el1+eesij)
3016           fac1=fac
3017           erij(1)=xj*rmij
3018           erij(2)=yj*rmij
3019           erij(3)=zj*rmij
3020 *
3021 * Radial derivatives. First process both termini of the fragment (i,j)
3022 *
3023           ggg(1)=facel*xj
3024           ggg(2)=facel*yj
3025           ggg(3)=facel*zj
3026 c          do k=1,3
3027 c            ghalf=0.5D0*ggg(k)
3028 c            gelc(k,i)=gelc(k,i)+ghalf
3029 c            gelc(k,j)=gelc(k,j)+ghalf
3030 c          enddo
3031 c 9/28/08 AL Gradient compotents will be summed only at the end
3032           do k=1,3
3033             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3034             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3035           enddo
3036 *
3037 * Loop over residues i+1 thru j-1.
3038 *
3039 cgrad          do k=i+1,j-1
3040 cgrad            do l=1,3
3041 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3042 cgrad            enddo
3043 cgrad          enddo
3044           ggg(1)=facvdw*xj
3045           ggg(2)=facvdw*yj
3046           ggg(3)=facvdw*zj
3047 c          do k=1,3
3048 c            ghalf=0.5D0*ggg(k)
3049 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3050 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3051 c          enddo
3052 c 9/28/08 AL Gradient compotents will be summed only at the end
3053           do k=1,3
3054             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3055             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3056           enddo
3057 *
3058 * Loop over residues i+1 thru j-1.
3059 *
3060 cgrad          do k=i+1,j-1
3061 cgrad            do l=1,3
3062 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3063 cgrad            enddo
3064 cgrad          enddo
3065 #else
3066           facvdw=ev1+evdwij
3067           facel=el1+eesij
3068           fac1=fac
3069           fac=-3*rrmij*(facvdw+facvdw+facel)
3070           erij(1)=xj*rmij
3071           erij(2)=yj*rmij
3072           erij(3)=zj*rmij
3073 *
3074 * Radial derivatives. First process both termini of the fragment (i,j)
3075 *
3076           ggg(1)=fac*xj
3077           ggg(2)=fac*yj
3078           ggg(3)=fac*zj
3079 c          do k=1,3
3080 c            ghalf=0.5D0*ggg(k)
3081 c            gelc(k,i)=gelc(k,i)+ghalf
3082 c            gelc(k,j)=gelc(k,j)+ghalf
3083 c          enddo
3084 c 9/28/08 AL Gradient compotents will be summed only at the end
3085           do k=1,3
3086             gelc_long(k,j)=gelc(k,j)+ggg(k)
3087             gelc_long(k,i)=gelc(k,i)-ggg(k)
3088           enddo
3089 *
3090 * Loop over residues i+1 thru j-1.
3091 *
3092 cgrad          do k=i+1,j-1
3093 cgrad            do l=1,3
3094 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3095 cgrad            enddo
3096 cgrad          enddo
3097 c 9/28/08 AL Gradient compotents will be summed only at the end
3098           ggg(1)=facvdw*xj
3099           ggg(2)=facvdw*yj
3100           ggg(3)=facvdw*zj
3101           do k=1,3
3102             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3103             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3104           enddo
3105 #endif
3106 *
3107 * Angular part
3108 *
3109           ecosa=2.0D0*fac3*fac1+fac4
3110           fac4=-3.0D0*fac4
3111           fac3=-6.0D0*fac3
3112           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3113           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3114           do k=1,3
3115             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3116             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3117           enddo
3118 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3119 cd   &          (dcosg(k),k=1,3)
3120           do k=1,3
3121             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3122           enddo
3123 c          do k=1,3
3124 c            ghalf=0.5D0*ggg(k)
3125 c            gelc(k,i)=gelc(k,i)+ghalf
3126 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3127 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3128 c            gelc(k,j)=gelc(k,j)+ghalf
3129 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3130 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3131 c          enddo
3132 cgrad          do k=i+1,j-1
3133 cgrad            do l=1,3
3134 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3135 cgrad            enddo
3136 cgrad          enddo
3137           do k=1,3
3138             gelc(k,i)=gelc(k,i)
3139      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3140      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3141             gelc(k,j)=gelc(k,j)
3142      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3143      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3144             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3145             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3146           enddo
3147           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3148      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3149      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3150 C
3151 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3152 C   energy of a peptide unit is assumed in the form of a second-order
3153 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3154 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3155 C   are computed for EVERY pair of non-contiguous peptide groups.
3156 C
3157           if (j.lt.nres-1) then
3158             j1=j+1
3159             j2=j-1
3160           else
3161             j1=j-1
3162             j2=j-2
3163           endif
3164           kkk=0
3165           do k=1,2
3166             do l=1,2
3167               kkk=kkk+1
3168               muij(kkk)=mu(k,i)*mu(l,j)
3169             enddo
3170           enddo
3171 cd         write (iout,*) 'EELEC: i',i,' j',j
3172 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3173 cd          write(iout,*) 'muij',muij
3174           ury=scalar(uy(1,i),erij)
3175           urz=scalar(uz(1,i),erij)
3176           vry=scalar(uy(1,j),erij)
3177           vrz=scalar(uz(1,j),erij)
3178           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3179           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3180           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3181           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3182           fac=dsqrt(-ael6i)*r3ij
3183           a22=a22*fac
3184           a23=a23*fac
3185           a32=a32*fac
3186           a33=a33*fac
3187 cd          write (iout,'(4i5,4f10.5)')
3188 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3189 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3190 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3191 cd     &      uy(:,j),uz(:,j)
3192 cd          write (iout,'(4f10.5)')
3193 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3194 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3195 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3196 cd           write (iout,'(9f10.5/)')
3197 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3198 C Derivatives of the elements of A in virtual-bond vectors
3199           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3200           do k=1,3
3201             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3202             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3203             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3204             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3205             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3206             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3207             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3208             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3209             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3210             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3211             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3212             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3213           enddo
3214 C Compute radial contributions to the gradient
3215           facr=-3.0d0*rrmij
3216           a22der=a22*facr
3217           a23der=a23*facr
3218           a32der=a32*facr
3219           a33der=a33*facr
3220           agg(1,1)=a22der*xj
3221           agg(2,1)=a22der*yj
3222           agg(3,1)=a22der*zj
3223           agg(1,2)=a23der*xj
3224           agg(2,2)=a23der*yj
3225           agg(3,2)=a23der*zj
3226           agg(1,3)=a32der*xj
3227           agg(2,3)=a32der*yj
3228           agg(3,3)=a32der*zj
3229           agg(1,4)=a33der*xj
3230           agg(2,4)=a33der*yj
3231           agg(3,4)=a33der*zj
3232 C Add the contributions coming from er
3233           fac3=-3.0d0*fac
3234           do k=1,3
3235             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3236             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3237             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3238             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3239           enddo
3240           do k=1,3
3241 C Derivatives in DC(i)
3242 cgrad            ghalf1=0.5d0*agg(k,1)
3243 cgrad            ghalf2=0.5d0*agg(k,2)
3244 cgrad            ghalf3=0.5d0*agg(k,3)
3245 cgrad            ghalf4=0.5d0*agg(k,4)
3246             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3247      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3248             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3249      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3250             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3251      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3252             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3253      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3254 C Derivatives in DC(i+1)
3255             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3256      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3257             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3258      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3259             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3260      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3261             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3262      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3263 C Derivatives in DC(j)
3264             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3265      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3266             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3267      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3268             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3269      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3270             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3271      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3272 C Derivatives in DC(j+1) or DC(nres-1)
3273             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3274      &      -3.0d0*vryg(k,3)*ury)
3275             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3276      &      -3.0d0*vrzg(k,3)*ury)
3277             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3278      &      -3.0d0*vryg(k,3)*urz)
3279             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3280      &      -3.0d0*vrzg(k,3)*urz)
3281 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3282 cgrad              do l=1,4
3283 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3284 cgrad              enddo
3285 cgrad            endif
3286           enddo
3287           acipa(1,1)=a22
3288           acipa(1,2)=a23
3289           acipa(2,1)=a32
3290           acipa(2,2)=a33
3291           a22=-a22
3292           a23=-a23
3293           do l=1,2
3294             do k=1,3
3295               agg(k,l)=-agg(k,l)
3296               aggi(k,l)=-aggi(k,l)
3297               aggi1(k,l)=-aggi1(k,l)
3298               aggj(k,l)=-aggj(k,l)
3299               aggj1(k,l)=-aggj1(k,l)
3300             enddo
3301           enddo
3302           if (j.lt.nres-1) then
3303             a22=-a22
3304             a32=-a32
3305             do l=1,3,2
3306               do k=1,3
3307                 agg(k,l)=-agg(k,l)
3308                 aggi(k,l)=-aggi(k,l)
3309                 aggi1(k,l)=-aggi1(k,l)
3310                 aggj(k,l)=-aggj(k,l)
3311                 aggj1(k,l)=-aggj1(k,l)
3312               enddo
3313             enddo
3314           else
3315             a22=-a22
3316             a23=-a23
3317             a32=-a32
3318             a33=-a33
3319             do l=1,4
3320               do k=1,3
3321                 agg(k,l)=-agg(k,l)
3322                 aggi(k,l)=-aggi(k,l)
3323                 aggi1(k,l)=-aggi1(k,l)
3324                 aggj(k,l)=-aggj(k,l)
3325                 aggj1(k,l)=-aggj1(k,l)
3326               enddo
3327             enddo
3328           endif
3329           ENDIF ! WCORR
3330           IF (wel_loc.gt.0.0d0) THEN
3331 C Contribution to the local-electrostatic energy coming from the i-j pair
3332           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3333      &     +a33*muij(4)
3334 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3335
3336           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3337      &            'eelloc',i,j,eel_loc_ij
3338 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3339
3340           eel_loc=eel_loc+eel_loc_ij
3341 C Partial derivatives in virtual-bond dihedral angles gamma
3342           if (i.gt.1)
3343      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3344      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3345      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3346           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3347      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3348      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3349 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3350           do l=1,3
3351             ggg(l)=agg(l,1)*muij(1)+
3352      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3353             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3354             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3355 cgrad            ghalf=0.5d0*ggg(l)
3356 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3357 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3358           enddo
3359 cgrad          do k=i+1,j2
3360 cgrad            do l=1,3
3361 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3362 cgrad            enddo
3363 cgrad          enddo
3364 C Remaining derivatives of eello
3365           do l=1,3
3366             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3367      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3368             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3369      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3370             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3371      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3372             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3373      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3374           enddo
3375           ENDIF
3376 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3377 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3378           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3379      &       .and. num_conti.le.maxconts) then
3380 c            write (iout,*) i,j," entered corr"
3381 C
3382 C Calculate the contact function. The ith column of the array JCONT will
3383 C contain the numbers of atoms that make contacts with the atom I (of numbers
3384 C greater than I). The arrays FACONT and GACONT will contain the values of
3385 C the contact function and its derivative.
3386 c           r0ij=1.02D0*rpp(iteli,itelj)
3387 c           r0ij=1.11D0*rpp(iteli,itelj)
3388             r0ij=2.20D0*rpp(iteli,itelj)
3389 c           r0ij=1.55D0*rpp(iteli,itelj)
3390             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3391             if (fcont.gt.0.0D0) then
3392               num_conti=num_conti+1
3393               if (num_conti.gt.maxconts) then
3394                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3395      &                         ' will skip next contacts for this conf.'
3396               else
3397                 jcont_hb(num_conti,i)=j
3398 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3399 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3400                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3401      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3402 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3403 C  terms.
3404                 d_cont(num_conti,i)=rij
3405 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3406 C     --- Electrostatic-interaction matrix ---
3407                 a_chuj(1,1,num_conti,i)=a22
3408                 a_chuj(1,2,num_conti,i)=a23
3409                 a_chuj(2,1,num_conti,i)=a32
3410                 a_chuj(2,2,num_conti,i)=a33
3411 C     --- Gradient of rij
3412                 do kkk=1,3
3413                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3414                 enddo
3415                 kkll=0
3416                 do k=1,2
3417                   do l=1,2
3418                     kkll=kkll+1
3419                     do m=1,3
3420                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3421                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3422                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3423                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3424                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3425                     enddo
3426                   enddo
3427                 enddo
3428                 ENDIF
3429                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3430 C Calculate contact energies
3431                 cosa4=4.0D0*cosa
3432                 wij=cosa-3.0D0*cosb*cosg
3433                 cosbg1=cosb+cosg
3434                 cosbg2=cosb-cosg
3435 c               fac3=dsqrt(-ael6i)/r0ij**3
3436                 fac3=dsqrt(-ael6i)*r3ij
3437 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3438                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3439                 if (ees0tmp.gt.0) then
3440                   ees0pij=dsqrt(ees0tmp)
3441                 else
3442                   ees0pij=0
3443                 endif
3444 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3445                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3446                 if (ees0tmp.gt.0) then
3447                   ees0mij=dsqrt(ees0tmp)
3448                 else
3449                   ees0mij=0
3450                 endif
3451 c               ees0mij=0.0D0
3452                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3453                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3454 C Diagnostics. Comment out or remove after debugging!
3455 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3456 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3457 c               ees0m(num_conti,i)=0.0D0
3458 C End diagnostics.
3459 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3460 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3461 C Angular derivatives of the contact function
3462                 ees0pij1=fac3/ees0pij
3463                 ees0mij1=fac3/ees0mij
3464                 fac3p=-3.0D0*fac3*rrmij
3465                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3466                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3467 c               ees0mij1=0.0D0
3468                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3469                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3470                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3471                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3472                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3473                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3474                 ecosap=ecosa1+ecosa2
3475                 ecosbp=ecosb1+ecosb2
3476                 ecosgp=ecosg1+ecosg2
3477                 ecosam=ecosa1-ecosa2
3478                 ecosbm=ecosb1-ecosb2
3479                 ecosgm=ecosg1-ecosg2
3480 C Diagnostics
3481 c               ecosap=ecosa1
3482 c               ecosbp=ecosb1
3483 c               ecosgp=ecosg1
3484 c               ecosam=0.0D0
3485 c               ecosbm=0.0D0
3486 c               ecosgm=0.0D0
3487 C End diagnostics
3488                 facont_hb(num_conti,i)=fcont
3489                 fprimcont=fprimcont/rij
3490 cd              facont_hb(num_conti,i)=1.0D0
3491 C Following line is for diagnostics.
3492 cd              fprimcont=0.0D0
3493                 do k=1,3
3494                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3495                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3496                 enddo
3497                 do k=1,3
3498                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3499                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3500                 enddo
3501                 gggp(1)=gggp(1)+ees0pijp*xj
3502                 gggp(2)=gggp(2)+ees0pijp*yj
3503                 gggp(3)=gggp(3)+ees0pijp*zj
3504                 gggm(1)=gggm(1)+ees0mijp*xj
3505                 gggm(2)=gggm(2)+ees0mijp*yj
3506                 gggm(3)=gggm(3)+ees0mijp*zj
3507 C Derivatives due to the contact function
3508                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3509                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3510                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3511                 do k=1,3
3512 c
3513 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3514 c          following the change of gradient-summation algorithm.
3515 c
3516 cgrad                  ghalfp=0.5D0*gggp(k)
3517 cgrad                  ghalfm=0.5D0*gggm(k)
3518                   gacontp_hb1(k,num_conti,i)=!ghalfp
3519      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3520      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3521                   gacontp_hb2(k,num_conti,i)=!ghalfp
3522      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3523      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3524                   gacontp_hb3(k,num_conti,i)=gggp(k)
3525                   gacontm_hb1(k,num_conti,i)=!ghalfm
3526      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3527      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3528                   gacontm_hb2(k,num_conti,i)=!ghalfm
3529      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3530      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3531                   gacontm_hb3(k,num_conti,i)=gggm(k)
3532                 enddo
3533 C Diagnostics. Comment out or remove after debugging!
3534 cdiag           do k=1,3
3535 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3536 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3537 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3538 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3539 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3540 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3541 cdiag           enddo
3542               ENDIF ! wcorr
3543               endif  ! num_conti.le.maxconts
3544             endif  ! fcont.gt.0
3545           endif    ! j.gt.i+1
3546           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3547             do k=1,4
3548               do l=1,3
3549                 ghalf=0.5d0*agg(l,k)
3550                 aggi(l,k)=aggi(l,k)+ghalf
3551                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3552                 aggj(l,k)=aggj(l,k)+ghalf
3553               enddo
3554             enddo
3555             if (j.eq.nres-1 .and. i.lt.j-2) then
3556               do k=1,4
3557                 do l=1,3
3558                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3559                 enddo
3560               enddo
3561             endif
3562           endif
3563 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3564       return
3565       end
3566 C-----------------------------------------------------------------------------
3567       subroutine eturn3(i,eello_turn3)
3568 C Third- and fourth-order contributions from turns
3569       implicit real*8 (a-h,o-z)
3570       include 'DIMENSIONS'
3571       include 'COMMON.IOUNITS'
3572       include 'COMMON.GEO'
3573       include 'COMMON.VAR'
3574       include 'COMMON.LOCAL'
3575       include 'COMMON.CHAIN'
3576       include 'COMMON.DERIV'
3577       include 'COMMON.INTERACT'
3578       include 'COMMON.CONTACTS'
3579       include 'COMMON.TORSION'
3580       include 'COMMON.VECTORS'
3581       include 'COMMON.FFIELD'
3582       include 'COMMON.CONTROL'
3583       dimension ggg(3)
3584       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3585      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3586      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3587       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3588      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3589       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3590      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3591      &    num_conti,j1,j2
3592       j=i+2
3593 c      write (iout,*) "eturn3",i,j,j1,j2
3594       a_temp(1,1)=a22
3595       a_temp(1,2)=a23
3596       a_temp(2,1)=a32
3597       a_temp(2,2)=a33
3598 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3599 C
3600 C               Third-order contributions
3601 C
3602 C                 (i+2)o----(i+3)
3603 C                      | |
3604 C                      | |
3605 C                 (i+1)o----i
3606 C
3607 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3608 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3609         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3610         call transpose2(auxmat(1,1),auxmat1(1,1))
3611         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3612         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3613         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3614      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3615 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3616 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3617 cd     &    ' eello_turn3_num',4*eello_turn3_num
3618 C Derivatives in gamma(i)
3619         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3620         call transpose2(auxmat2(1,1),auxmat3(1,1))
3621         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3622         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3623 C Derivatives in gamma(i+1)
3624         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3625         call transpose2(auxmat2(1,1),auxmat3(1,1))
3626         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3627         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3628      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3629 C Cartesian derivatives
3630         do l=1,3
3631 c            ghalf1=0.5d0*agg(l,1)
3632 c            ghalf2=0.5d0*agg(l,2)
3633 c            ghalf3=0.5d0*agg(l,3)
3634 c            ghalf4=0.5d0*agg(l,4)
3635           a_temp(1,1)=aggi(l,1)!+ghalf1
3636           a_temp(1,2)=aggi(l,2)!+ghalf2
3637           a_temp(2,1)=aggi(l,3)!+ghalf3
3638           a_temp(2,2)=aggi(l,4)!+ghalf4
3639           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3640           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3641      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3642           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3643           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3644           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3645           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3646           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3647           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3648      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3649           a_temp(1,1)=aggj(l,1)!+ghalf1
3650           a_temp(1,2)=aggj(l,2)!+ghalf2
3651           a_temp(2,1)=aggj(l,3)!+ghalf3
3652           a_temp(2,2)=aggj(l,4)!+ghalf4
3653           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3654           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3655      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3656           a_temp(1,1)=aggj1(l,1)
3657           a_temp(1,2)=aggj1(l,2)
3658           a_temp(2,1)=aggj1(l,3)
3659           a_temp(2,2)=aggj1(l,4)
3660           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3661           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3662      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3663         enddo
3664       return
3665       end
3666 C-------------------------------------------------------------------------------
3667       subroutine eturn4(i,eello_turn4)
3668 C Third- and fourth-order contributions from turns
3669       implicit real*8 (a-h,o-z)
3670       include 'DIMENSIONS'
3671       include 'COMMON.IOUNITS'
3672       include 'COMMON.GEO'
3673       include 'COMMON.VAR'
3674       include 'COMMON.LOCAL'
3675       include 'COMMON.CHAIN'
3676       include 'COMMON.DERIV'
3677       include 'COMMON.INTERACT'
3678       include 'COMMON.CONTACTS'
3679       include 'COMMON.TORSION'
3680       include 'COMMON.VECTORS'
3681       include 'COMMON.FFIELD'
3682       include 'COMMON.CONTROL'
3683       dimension ggg(3)
3684       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3685      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3686      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3687       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3688      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3689       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3690      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3691      &    num_conti,j1,j2
3692       j=i+3
3693 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3694 C
3695 C               Fourth-order contributions
3696 C
3697 C                 (i+3)o----(i+4)
3698 C                     /  |
3699 C               (i+2)o   |
3700 C                     \  |
3701 C                 (i+1)o----i
3702 C
3703 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3704 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3705 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3706         a_temp(1,1)=a22
3707         a_temp(1,2)=a23
3708         a_temp(2,1)=a32
3709         a_temp(2,2)=a33
3710         iti1=itortyp(itype(i+1))
3711         iti2=itortyp(itype(i+2))
3712         iti3=itortyp(itype(i+3))
3713 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3714         call transpose2(EUg(1,1,i+1),e1t(1,1))
3715         call transpose2(Eug(1,1,i+2),e2t(1,1))
3716         call transpose2(Eug(1,1,i+3),e3t(1,1))
3717         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3718         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3719         s1=scalar2(b1(1,iti2),auxvec(1))
3720         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3721         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3722         s2=scalar2(b1(1,iti1),auxvec(1))
3723         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3724         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3725         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3726         eello_turn4=eello_turn4-(s1+s2+s3)
3727         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3728      &      'eturn4',i,j,-(s1+s2+s3)
3729 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3730 cd     &    ' eello_turn4_num',8*eello_turn4_num
3731 C Derivatives in gamma(i)
3732         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3733         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3734         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3735         s1=scalar2(b1(1,iti2),auxvec(1))
3736         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3737         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3738         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3739 C Derivatives in gamma(i+1)
3740         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3741         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3742         s2=scalar2(b1(1,iti1),auxvec(1))
3743         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3744         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3745         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3746         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3747 C Derivatives in gamma(i+2)
3748         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3749         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3750         s1=scalar2(b1(1,iti2),auxvec(1))
3751         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3752         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3753         s2=scalar2(b1(1,iti1),auxvec(1))
3754         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3755         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3756         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3757         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3758 C Cartesian derivatives
3759 C Derivatives of this turn contributions in DC(i+2)
3760         if (j.lt.nres-1) then
3761           do l=1,3
3762             a_temp(1,1)=agg(l,1)
3763             a_temp(1,2)=agg(l,2)
3764             a_temp(2,1)=agg(l,3)
3765             a_temp(2,2)=agg(l,4)
3766             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3767             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3768             s1=scalar2(b1(1,iti2),auxvec(1))
3769             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3770             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3771             s2=scalar2(b1(1,iti1),auxvec(1))
3772             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3773             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3774             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3775             ggg(l)=-(s1+s2+s3)
3776             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3777           enddo
3778         endif
3779 C Remaining derivatives of this turn contribution
3780         do l=1,3
3781           a_temp(1,1)=aggi(l,1)
3782           a_temp(1,2)=aggi(l,2)
3783           a_temp(2,1)=aggi(l,3)
3784           a_temp(2,2)=aggi(l,4)
3785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787           s1=scalar2(b1(1,iti2),auxvec(1))
3788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790           s2=scalar2(b1(1,iti1),auxvec(1))
3791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3795           a_temp(1,1)=aggi1(l,1)
3796           a_temp(1,2)=aggi1(l,2)
3797           a_temp(2,1)=aggi1(l,3)
3798           a_temp(2,2)=aggi1(l,4)
3799           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3800           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3801           s1=scalar2(b1(1,iti2),auxvec(1))
3802           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3803           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3804           s2=scalar2(b1(1,iti1),auxvec(1))
3805           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3806           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3807           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3808           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3809           a_temp(1,1)=aggj(l,1)
3810           a_temp(1,2)=aggj(l,2)
3811           a_temp(2,1)=aggj(l,3)
3812           a_temp(2,2)=aggj(l,4)
3813           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3814           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3815           s1=scalar2(b1(1,iti2),auxvec(1))
3816           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3817           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3818           s2=scalar2(b1(1,iti1),auxvec(1))
3819           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3820           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3821           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3822           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3823           a_temp(1,1)=aggj1(l,1)
3824           a_temp(1,2)=aggj1(l,2)
3825           a_temp(2,1)=aggj1(l,3)
3826           a_temp(2,2)=aggj1(l,4)
3827           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3828           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3829           s1=scalar2(b1(1,iti2),auxvec(1))
3830           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3831           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3832           s2=scalar2(b1(1,iti1),auxvec(1))
3833           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3834           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3835           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3836 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3837           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3838         enddo
3839       return
3840       end
3841 C-----------------------------------------------------------------------------
3842       subroutine vecpr(u,v,w)
3843       implicit real*8(a-h,o-z)
3844       dimension u(3),v(3),w(3)
3845       w(1)=u(2)*v(3)-u(3)*v(2)
3846       w(2)=-u(1)*v(3)+u(3)*v(1)
3847       w(3)=u(1)*v(2)-u(2)*v(1)
3848       return
3849       end
3850 C-----------------------------------------------------------------------------
3851       subroutine unormderiv(u,ugrad,unorm,ungrad)
3852 C This subroutine computes the derivatives of a normalized vector u, given
3853 C the derivatives computed without normalization conditions, ugrad. Returns
3854 C ungrad.
3855       implicit none
3856       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3857       double precision vec(3)
3858       double precision scalar
3859       integer i,j
3860 c      write (2,*) 'ugrad',ugrad
3861 c      write (2,*) 'u',u
3862       do i=1,3
3863         vec(i)=scalar(ugrad(1,i),u(1))
3864       enddo
3865 c      write (2,*) 'vec',vec
3866       do i=1,3
3867         do j=1,3
3868           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3869         enddo
3870       enddo
3871 c      write (2,*) 'ungrad',ungrad
3872       return
3873       end
3874 C-----------------------------------------------------------------------------
3875       subroutine escp_soft_sphere(evdw2,evdw2_14)
3876 C
3877 C This subroutine calculates the excluded-volume interaction energy between
3878 C peptide-group centers and side chains and its gradient in virtual-bond and
3879 C side-chain vectors.
3880 C
3881       implicit real*8 (a-h,o-z)
3882       include 'DIMENSIONS'
3883       include 'COMMON.GEO'
3884       include 'COMMON.VAR'
3885       include 'COMMON.LOCAL'
3886       include 'COMMON.CHAIN'
3887       include 'COMMON.DERIV'
3888       include 'COMMON.INTERACT'
3889       include 'COMMON.FFIELD'
3890       include 'COMMON.IOUNITS'
3891       include 'COMMON.CONTROL'
3892       dimension ggg(3)
3893       evdw2=0.0D0
3894       evdw2_14=0.0d0
3895       r0_scp=4.5d0
3896 cd    print '(a)','Enter ESCP'
3897 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3898       do i=iatscp_s,iatscp_e
3899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3900         iteli=itel(i)
3901         xi=0.5D0*(c(1,i)+c(1,i+1))
3902         yi=0.5D0*(c(2,i)+c(2,i+1))
3903         zi=0.5D0*(c(3,i)+c(3,i+1))
3904
3905         do iint=1,nscp_gr(i)
3906
3907         do j=iscpstart(i,iint),iscpend(i,iint)
3908           if (itype(j).eq.ntyp1) cycle
3909           itypj=iabs(itype(j))
3910 C Uncomment following three lines for SC-p interactions
3911 c         xj=c(1,nres+j)-xi
3912 c         yj=c(2,nres+j)-yi
3913 c         zj=c(3,nres+j)-zi
3914 C Uncomment following three lines for Ca-p interactions
3915           xj=c(1,j)-xi
3916           yj=c(2,j)-yi
3917           zj=c(3,j)-zi
3918           rij=xj*xj+yj*yj+zj*zj
3919           r0ij=r0_scp
3920           r0ijsq=r0ij*r0ij
3921           if (rij.lt.r0ijsq) then
3922             evdwij=0.25d0*(rij-r0ijsq)**2
3923             fac=rij-r0ijsq
3924           else
3925             evdwij=0.0d0
3926             fac=0.0d0
3927           endif
3928           evdw2=evdw2+evdwij
3929 C
3930 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3931 C
3932           ggg(1)=xj*fac
3933           ggg(2)=yj*fac
3934           ggg(3)=zj*fac
3935 cgrad          if (j.lt.i) then
3936 cd          write (iout,*) 'j<i'
3937 C Uncomment following three lines for SC-p interactions
3938 c           do k=1,3
3939 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3940 c           enddo
3941 cgrad          else
3942 cd          write (iout,*) 'j>i'
3943 cgrad            do k=1,3
3944 cgrad              ggg(k)=-ggg(k)
3945 C Uncomment following line for SC-p interactions
3946 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3947 cgrad            enddo
3948 cgrad          endif
3949 cgrad          do k=1,3
3950 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3951 cgrad          enddo
3952 cgrad          kstart=min0(i+1,j)
3953 cgrad          kend=max0(i-1,j-1)
3954 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3955 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3956 cgrad          do k=kstart,kend
3957 cgrad            do l=1,3
3958 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3959 cgrad            enddo
3960 cgrad          enddo
3961           do k=1,3
3962             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3963             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3964           enddo
3965         enddo
3966
3967         enddo ! iint
3968       enddo ! i
3969       return
3970       end
3971 C-----------------------------------------------------------------------------
3972       subroutine escp(evdw2,evdw2_14)
3973 C
3974 C This subroutine calculates the excluded-volume interaction energy between
3975 C peptide-group centers and side chains and its gradient in virtual-bond and
3976 C side-chain vectors.
3977 C
3978       implicit real*8 (a-h,o-z)
3979       include 'DIMENSIONS'
3980       include 'COMMON.GEO'
3981       include 'COMMON.VAR'
3982       include 'COMMON.LOCAL'
3983       include 'COMMON.CHAIN'
3984       include 'COMMON.DERIV'
3985       include 'COMMON.INTERACT'
3986       include 'COMMON.FFIELD'
3987       include 'COMMON.IOUNITS'
3988       include 'COMMON.CONTROL'
3989       dimension ggg(3)
3990       evdw2=0.0D0
3991       evdw2_14=0.0d0
3992 cd    print '(a)','Enter ESCP'
3993 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3994       do i=iatscp_s,iatscp_e
3995         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3996         iteli=itel(i)
3997         xi=0.5D0*(c(1,i)+c(1,i+1))
3998         yi=0.5D0*(c(2,i)+c(2,i+1))
3999         zi=0.5D0*(c(3,i)+c(3,i+1))
4000
4001         do iint=1,nscp_gr(i)
4002
4003         do j=iscpstart(i,iint),iscpend(i,iint)
4004           itypj=iabs(itype(j))
4005           if (itypj.eq.ntyp1) cycle
4006 C Uncomment following three lines for SC-p interactions
4007 c         xj=c(1,nres+j)-xi
4008 c         yj=c(2,nres+j)-yi
4009 c         zj=c(3,nres+j)-zi
4010 C Uncomment following three lines for Ca-p interactions
4011           xj=c(1,j)-xi
4012           yj=c(2,j)-yi
4013           zj=c(3,j)-zi
4014           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4015           fac=rrij**expon2
4016           e1=fac*fac*aad(itypj,iteli)
4017           e2=fac*bad(itypj,iteli)
4018           if (iabs(j-i) .le. 2) then
4019             e1=scal14*e1
4020             e2=scal14*e2
4021             evdw2_14=evdw2_14+e1+e2
4022           endif
4023           evdwij=e1+e2
4024           evdw2=evdw2+evdwij
4025           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4026      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4027      &       bad(itypj,iteli)
4028 C
4029 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4030 C
4031           fac=-(evdwij+e1)*rrij
4032           ggg(1)=xj*fac
4033           ggg(2)=yj*fac
4034           ggg(3)=zj*fac
4035 cgrad          if (j.lt.i) then
4036 cd          write (iout,*) 'j<i'
4037 C Uncomment following three lines for SC-p interactions
4038 c           do k=1,3
4039 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4040 c           enddo
4041 cgrad          else
4042 cd          write (iout,*) 'j>i'
4043 cgrad            do k=1,3
4044 cgrad              ggg(k)=-ggg(k)
4045 C Uncomment following line for SC-p interactions
4046 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4047 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4048 cgrad            enddo
4049 cgrad          endif
4050 cgrad          do k=1,3
4051 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4052 cgrad          enddo
4053 cgrad          kstart=min0(i+1,j)
4054 cgrad          kend=max0(i-1,j-1)
4055 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4056 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4057 cgrad          do k=kstart,kend
4058 cgrad            do l=1,3
4059 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4060 cgrad            enddo
4061 cgrad          enddo
4062           do k=1,3
4063             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4064             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4065           enddo
4066         enddo
4067
4068         enddo ! iint
4069       enddo ! i
4070       do i=1,nct
4071         do j=1,3
4072           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4073           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4074           gradx_scp(j,i)=expon*gradx_scp(j,i)
4075         enddo
4076       enddo
4077 C******************************************************************************
4078 C
4079 C                              N O T E !!!
4080 C
4081 C To save time the factor EXPON has been extracted from ALL components
4082 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4083 C use!
4084 C
4085 C******************************************************************************
4086       return
4087       end
4088 C--------------------------------------------------------------------------
4089       subroutine edis(ehpb)
4090 C
4091 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4092 C
4093       implicit real*8 (a-h,o-z)
4094       include 'DIMENSIONS'
4095       include 'COMMON.SBRIDGE'
4096       include 'COMMON.CHAIN'
4097       include 'COMMON.DERIV'
4098       include 'COMMON.VAR'
4099       include 'COMMON.INTERACT'
4100       include 'COMMON.IOUNITS'
4101       include 'COMMON.CONTROL'
4102       dimension ggg(3)
4103       ehpb=0.0D0
4104       do i=1,3
4105        ggg(i)=0.0d0
4106       enddo
4107 C      write (iout,*) ,"link_end",link_end,constr_dist
4108 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4109 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4110       if (link_end.eq.0) return
4111       do i=link_start,link_end
4112 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4113 C CA-CA distance used in regularization of structure.
4114         ii=ihpb(i)
4115         jj=jhpb(i)
4116 C iii and jjj point to the residues for which the distance is assigned.
4117         if (ii.gt.nres) then
4118           iii=ii-nres
4119           jjj=jj-nres
4120         else
4121           iii=ii
4122           jjj=jj
4123         endif
4124 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4125 c     &    dhpb(i),dhpb1(i),forcon(i)
4126 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4127 C    distance and angle dependent SS bond potential.
4128 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4129 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4130         if (.not.dyn_ss .and. i.le.nss) then
4131 C 15/02/13 CC dynamic SSbond - additional check
4132          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4133      & iabs(itype(jjj)).eq.1) then
4134           call ssbond_ene(iii,jjj,eij)
4135           ehpb=ehpb+2*eij
4136          endif
4137 cd          write (iout,*) "eij",eij
4138 cd   &   ' waga=',waga,' fac=',fac
4139         else if (ii.gt.nres .and. jj.gt.nres) then
4140 c Restraints from contact prediction
4141           dd=dist(ii,jj)
4142           if (constr_dist.eq.11) then
4143             ehpb=ehpb+fordepth(i)**4.0d0
4144      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4145             fac=fordepth(i)**4.0d0
4146      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4147           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4148      &    ehpb,fordepth(i),dd
4149            else
4150           if (dhpb1(i).gt.0.0d0) then
4151             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4152             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4153 c            write (iout,*) "beta nmr",
4154 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4155           else
4156             dd=dist(ii,jj)
4157             rdis=dd-dhpb(i)
4158 C Get the force constant corresponding to this distance.
4159             waga=forcon(i)
4160 C Calculate the contribution to energy.
4161             ehpb=ehpb+waga*rdis*rdis
4162 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4163 C
4164 C Evaluate gradient.
4165 C
4166             fac=waga*rdis/dd
4167           endif
4168           endif
4169           do j=1,3
4170             ggg(j)=fac*(c(j,jj)-c(j,ii))
4171           enddo
4172           do j=1,3
4173             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4174             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4175           enddo
4176           do k=1,3
4177             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4178             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4179           enddo
4180         else
4181 C Calculate the distance between the two points and its difference from the
4182 C target distance.
4183           dd=dist(ii,jj)
4184           if (constr_dist.eq.11) then
4185             ehpb=ehpb+fordepth(i)**4.0d0
4186      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4187             fac=fordepth(i)**4.0d0
4188      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4189           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4190      &    ehpb,fordepth(i),dd
4191            else
4192           if (dhpb1(i).gt.0.0d0) then
4193             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4194             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4195 c            write (iout,*) "alph nmr",
4196 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4197           else
4198             rdis=dd-dhpb(i)
4199 C Get the force constant corresponding to this distance.
4200             waga=forcon(i)
4201 C Calculate the contribution to energy.
4202             ehpb=ehpb+waga*rdis*rdis
4203 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4204 C
4205 C Evaluate gradient.
4206 C
4207             fac=waga*rdis/dd
4208           endif
4209           endif
4210             do j=1,3
4211               ggg(j)=fac*(c(j,jj)-c(j,ii))
4212             enddo
4213 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4214 C If this is a SC-SC distance, we need to calculate the contributions to the
4215 C Cartesian gradient in the SC vectors (ghpbx).
4216           if (iii.lt.ii) then
4217           do j=1,3
4218             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4219             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4220           enddo
4221           endif
4222 cgrad        do j=iii,jjj-1
4223 cgrad          do k=1,3
4224 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4225 cgrad          enddo
4226 cgrad        enddo
4227           do k=1,3
4228             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4229             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4230           enddo
4231         endif
4232       enddo
4233       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4234       return
4235       end
4236 C--------------------------------------------------------------------------
4237       subroutine ssbond_ene(i,j,eij)
4238 C
4239 C Calculate the distance and angle dependent SS-bond potential energy
4240 C using a free-energy function derived based on RHF/6-31G** ab initio
4241 C calculations of diethyl disulfide.
4242 C
4243 C A. Liwo and U. Kozlowska, 11/24/03
4244 C
4245       implicit real*8 (a-h,o-z)
4246       include 'DIMENSIONS'
4247       include 'COMMON.SBRIDGE'
4248       include 'COMMON.CHAIN'
4249       include 'COMMON.DERIV'
4250       include 'COMMON.LOCAL'
4251       include 'COMMON.INTERACT'
4252       include 'COMMON.VAR'
4253       include 'COMMON.IOUNITS'
4254       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4255       itypi=iabs(itype(i))
4256       xi=c(1,nres+i)
4257       yi=c(2,nres+i)
4258       zi=c(3,nres+i)
4259       dxi=dc_norm(1,nres+i)
4260       dyi=dc_norm(2,nres+i)
4261       dzi=dc_norm(3,nres+i)
4262 c      dsci_inv=dsc_inv(itypi)
4263       dsci_inv=vbld_inv(nres+i)
4264       itypj=iabs(itype(j))
4265 c      dscj_inv=dsc_inv(itypj)
4266       dscj_inv=vbld_inv(nres+j)
4267       xj=c(1,nres+j)-xi
4268       yj=c(2,nres+j)-yi
4269       zj=c(3,nres+j)-zi
4270       dxj=dc_norm(1,nres+j)
4271       dyj=dc_norm(2,nres+j)
4272       dzj=dc_norm(3,nres+j)
4273       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4274       rij=dsqrt(rrij)
4275       erij(1)=xj*rij
4276       erij(2)=yj*rij
4277       erij(3)=zj*rij
4278       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4279       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4280       om12=dxi*dxj+dyi*dyj+dzi*dzj
4281       do k=1,3
4282         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4283         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4284       enddo
4285       rij=1.0d0/rij
4286       deltad=rij-d0cm
4287       deltat1=1.0d0-om1
4288       deltat2=1.0d0+om2
4289       deltat12=om2-om1+2.0d0
4290       cosphi=om12-om1*om2
4291       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4292      &  +akct*deltad*deltat12
4293      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4294 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4295 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4296 c     &  " deltat12",deltat12," eij",eij
4297       ed=2*akcm*deltad+akct*deltat12
4298       pom1=akct*deltad
4299       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4300       eom1=-2*akth*deltat1-pom1-om2*pom2
4301       eom2= 2*akth*deltat2+pom1-om1*pom2
4302       eom12=pom2
4303       do k=1,3
4304         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4305         ghpbx(k,i)=ghpbx(k,i)-ggk
4306      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4307      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4308         ghpbx(k,j)=ghpbx(k,j)+ggk
4309      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4310      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4311         ghpbc(k,i)=ghpbc(k,i)-ggk
4312         ghpbc(k,j)=ghpbc(k,j)+ggk
4313       enddo
4314 C
4315 C Calculate the components of the gradient in DC and X
4316 C
4317 cgrad      do k=i,j-1
4318 cgrad        do l=1,3
4319 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4320 cgrad        enddo
4321 cgrad      enddo
4322       return
4323       end
4324 C--------------------------------------------------------------------------
4325       subroutine ebond(estr)
4326 c
4327 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4328 c
4329       implicit real*8 (a-h,o-z)
4330       include 'DIMENSIONS'
4331       include 'COMMON.LOCAL'
4332       include 'COMMON.GEO'
4333       include 'COMMON.INTERACT'
4334       include 'COMMON.DERIV'
4335       include 'COMMON.VAR'
4336       include 'COMMON.CHAIN'
4337       include 'COMMON.IOUNITS'
4338       include 'COMMON.NAMES'
4339       include 'COMMON.FFIELD'
4340       include 'COMMON.CONTROL'
4341       include 'COMMON.SETUP'
4342       double precision u(3),ud(3)
4343       estr=0.0d0
4344       estr1=0.0d0
4345       do i=ibondp_start,ibondp_end
4346         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4347           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4348           do j=1,3
4349           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4350      &      *dc(j,i-1)/vbld(i)
4351           enddo
4352           if (energy_dec) write(iout,*)
4353      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4354         else
4355         diff = vbld(i)-vbldp0
4356         if (energy_dec) write (iout,*)
4357      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4358         estr=estr+diff*diff
4359         do j=1,3
4360           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4361         enddo
4362 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4363         endif
4364       enddo
4365       estr=0.5d0*AKP*estr+estr1
4366 c
4367 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4368 c
4369       do i=ibond_start,ibond_end
4370         iti=iabs(itype(i))
4371         if (iti.ne.10 .and. iti.ne.ntyp1) then
4372           nbi=nbondterm(iti)
4373           if (nbi.eq.1) then
4374             diff=vbld(i+nres)-vbldsc0(1,iti)
4375             if (energy_dec) write (iout,*)
4376      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4377      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4378             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4379             do j=1,3
4380               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4381             enddo
4382           else
4383             do j=1,nbi
4384               diff=vbld(i+nres)-vbldsc0(j,iti)
4385               ud(j)=aksc(j,iti)*diff
4386               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4387             enddo
4388             uprod=u(1)
4389             do j=2,nbi
4390               uprod=uprod*u(j)
4391             enddo
4392             usum=0.0d0
4393             usumsqder=0.0d0
4394             do j=1,nbi
4395               uprod1=1.0d0
4396               uprod2=1.0d0
4397               do k=1,nbi
4398                 if (k.ne.j) then
4399                   uprod1=uprod1*u(k)
4400                   uprod2=uprod2*u(k)*u(k)
4401                 endif
4402               enddo
4403               usum=usum+uprod1
4404               usumsqder=usumsqder+ud(j)*uprod2
4405             enddo
4406             estr=estr+uprod/usum
4407             do j=1,3
4408              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4409             enddo
4410           endif
4411         endif
4412       enddo
4413       return
4414       end
4415 #ifdef CRYST_THETA
4416 C--------------------------------------------------------------------------
4417       subroutine ebend(etheta,ethetacnstr)
4418 C
4419 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4420 C angles gamma and its derivatives in consecutive thetas and gammas.
4421 C
4422       implicit real*8 (a-h,o-z)
4423       include 'DIMENSIONS'
4424       include 'COMMON.LOCAL'
4425       include 'COMMON.GEO'
4426       include 'COMMON.INTERACT'
4427       include 'COMMON.DERIV'
4428       include 'COMMON.VAR'
4429       include 'COMMON.CHAIN'
4430       include 'COMMON.IOUNITS'
4431       include 'COMMON.NAMES'
4432       include 'COMMON.FFIELD'
4433       include 'COMMON.CONTROL'
4434       include 'COMMON.TORCNSTR'
4435       common /calcthet/ term1,term2,termm,diffak,ratak,
4436      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4437      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4438       double precision y(2),z(2)
4439       delta=0.02d0*pi
4440 c      time11=dexp(-2*time)
4441 c      time12=1.0d0
4442       etheta=0.0D0
4443 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4444       do i=ithet_start,ithet_end
4445         if (itype(i-1).eq.ntyp1) cycle
4446 C Zero the energy function and its derivative at 0 or pi.
4447         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4448         it=itype(i-1)
4449         ichir1=isign(1,itype(i-2))
4450         ichir2=isign(1,itype(i))
4451          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4452          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4453          if (itype(i-1).eq.10) then
4454           itype1=isign(10,itype(i-2))
4455           ichir11=isign(1,itype(i-2))
4456           ichir12=isign(1,itype(i-2))
4457           itype2=isign(10,itype(i))
4458           ichir21=isign(1,itype(i))
4459           ichir22=isign(1,itype(i))
4460          endif
4461
4462         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4463 #ifdef OSF
4464           phii=phi(i)
4465           if (phii.ne.phii) phii=150.0
4466 #else
4467           phii=phi(i)
4468 #endif
4469           y(1)=dcos(phii)
4470           y(2)=dsin(phii)
4471         else
4472           y(1)=0.0D0
4473           y(2)=0.0D0
4474         endif
4475         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4476 #ifdef OSF
4477           phii1=phi(i+1)
4478           if (phii1.ne.phii1) phii1=150.0
4479           phii1=pinorm(phii1)
4480           z(1)=cos(phii1)
4481 #else
4482           phii1=phi(i+1)
4483           z(1)=dcos(phii1)
4484 #endif
4485           z(2)=dsin(phii1)
4486         else
4487           z(1)=0.0D0
4488           z(2)=0.0D0
4489         endif
4490 C Calculate the "mean" value of theta from the part of the distribution
4491 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4492 C In following comments this theta will be referred to as t_c.
4493         thet_pred_mean=0.0d0
4494         do k=1,2
4495             athetk=athet(k,it,ichir1,ichir2)
4496             bthetk=bthet(k,it,ichir1,ichir2)
4497           if (it.eq.10) then
4498              athetk=athet(k,itype1,ichir11,ichir12)
4499              bthetk=bthet(k,itype2,ichir21,ichir22)
4500           endif
4501          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4502         enddo
4503         dthett=thet_pred_mean*ssd
4504         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4505 C Derivatives of the "mean" values in gamma1 and gamma2.
4506         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4507      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4508          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4509      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4510          if (it.eq.10) then
4511       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4512      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4513         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4514      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4515          endif
4516         if (theta(i).gt.pi-delta) then
4517           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4518      &         E_tc0)
4519           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4520           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4521           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4522      &        E_theta)
4523           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4524      &        E_tc)
4525         else if (theta(i).lt.delta) then
4526           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4527           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4528           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4529      &        E_theta)
4530           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4531           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4532      &        E_tc)
4533         else
4534           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4535      &        E_theta,E_tc)
4536         endif
4537         etheta=etheta+ethetai
4538         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4539      &      'ebend',i,ethetai
4540         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4541         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4542         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4543       enddo
4544       ethetacnstr=0.0d0
4545 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4546       do i=ithetaconstr_start,ithetaconstr_end
4547         itheta=itheta_constr(i)
4548         thetiii=theta(itheta)
4549         difi=pinorm(thetiii-theta_constr0(i))
4550         if (difi.gt.theta_drange(i)) then
4551           difi=difi-theta_drange(i)
4552           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4553           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4554      &    +for_thet_constr(i)*difi**3
4555         else if (difi.lt.-drange(i)) then
4556           difi=difi+drange(i)
4557           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4558           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4559      &    +for_thet_constr(i)*difi**3
4560         else
4561           difi=0.0
4562         endif
4563        if (energy_dec) then
4564         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4565      &    i,itheta,rad2deg*thetiii,
4566      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4567      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4568      &    gloc(itheta+nphi-2,icg)
4569         endif
4570       enddo
4571
4572 C Ufff.... We've done all this!!!
4573       return
4574       end
4575 C---------------------------------------------------------------------------
4576       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4577      &     E_tc)
4578       implicit real*8 (a-h,o-z)
4579       include 'DIMENSIONS'
4580       include 'COMMON.LOCAL'
4581       include 'COMMON.IOUNITS'
4582       common /calcthet/ term1,term2,termm,diffak,ratak,
4583      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4584      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4585 C Calculate the contributions to both Gaussian lobes.
4586 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4587 C The "polynomial part" of the "standard deviation" of this part of
4588 C the distribution.
4589         sig=polthet(3,it)
4590         do j=2,0,-1
4591           sig=sig*thet_pred_mean+polthet(j,it)
4592         enddo
4593 C Derivative of the "interior part" of the "standard deviation of the"
4594 C gamma-dependent Gaussian lobe in t_c.
4595         sigtc=3*polthet(3,it)
4596         do j=2,1,-1
4597           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4598         enddo
4599         sigtc=sig*sigtc
4600 C Set the parameters of both Gaussian lobes of the distribution.
4601 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4602         fac=sig*sig+sigc0(it)
4603         sigcsq=fac+fac
4604         sigc=1.0D0/sigcsq
4605 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4606         sigsqtc=-4.0D0*sigcsq*sigtc
4607 c       print *,i,sig,sigtc,sigsqtc
4608 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4609         sigtc=-sigtc/(fac*fac)
4610 C Following variable is sigma(t_c)**(-2)
4611         sigcsq=sigcsq*sigcsq
4612         sig0i=sig0(it)
4613         sig0inv=1.0D0/sig0i**2
4614         delthec=thetai-thet_pred_mean
4615         delthe0=thetai-theta0i
4616         term1=-0.5D0*sigcsq*delthec*delthec
4617         term2=-0.5D0*sig0inv*delthe0*delthe0
4618 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4619 C NaNs in taking the logarithm. We extract the largest exponent which is added
4620 C to the energy (this being the log of the distribution) at the end of energy
4621 C term evaluation for this virtual-bond angle.
4622         if (term1.gt.term2) then
4623           termm=term1
4624           term2=dexp(term2-termm)
4625           term1=1.0d0
4626         else
4627           termm=term2
4628           term1=dexp(term1-termm)
4629           term2=1.0d0
4630         endif
4631 C The ratio between the gamma-independent and gamma-dependent lobes of
4632 C the distribution is a Gaussian function of thet_pred_mean too.
4633         diffak=gthet(2,it)-thet_pred_mean
4634         ratak=diffak/gthet(3,it)**2
4635         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4636 C Let's differentiate it in thet_pred_mean NOW.
4637         aktc=ak*ratak
4638 C Now put together the distribution terms to make complete distribution.
4639         termexp=term1+ak*term2
4640         termpre=sigc+ak*sig0i
4641 C Contribution of the bending energy from this theta is just the -log of
4642 C the sum of the contributions from the two lobes and the pre-exponential
4643 C factor. Simple enough, isn't it?
4644         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4645 C NOW the derivatives!!!
4646 C 6/6/97 Take into account the deformation.
4647         E_theta=(delthec*sigcsq*term1
4648      &       +ak*delthe0*sig0inv*term2)/termexp
4649         E_tc=((sigtc+aktc*sig0i)/termpre
4650      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4651      &       aktc*term2)/termexp)
4652       return
4653       end
4654 c-----------------------------------------------------------------------------
4655       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4656       implicit real*8 (a-h,o-z)
4657       include 'DIMENSIONS'
4658       include 'COMMON.LOCAL'
4659       include 'COMMON.IOUNITS'
4660       common /calcthet/ term1,term2,termm,diffak,ratak,
4661      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4662      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4663       delthec=thetai-thet_pred_mean
4664       delthe0=thetai-theta0i
4665 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4666       t3 = thetai-thet_pred_mean
4667       t6 = t3**2
4668       t9 = term1
4669       t12 = t3*sigcsq
4670       t14 = t12+t6*sigsqtc
4671       t16 = 1.0d0
4672       t21 = thetai-theta0i
4673       t23 = t21**2
4674       t26 = term2
4675       t27 = t21*t26
4676       t32 = termexp
4677       t40 = t32**2
4678       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4679      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4680      & *(-t12*t9-ak*sig0inv*t27)
4681       return
4682       end
4683 #else
4684 C--------------------------------------------------------------------------
4685       subroutine ebend(etheta,ethetacnstr)
4686 C
4687 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4688 C angles gamma and its derivatives in consecutive thetas and gammas.
4689 C ab initio-derived potentials from
4690 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4691 C
4692       implicit real*8 (a-h,o-z)
4693       include 'DIMENSIONS'
4694       include 'COMMON.LOCAL'
4695       include 'COMMON.GEO'
4696       include 'COMMON.INTERACT'
4697       include 'COMMON.DERIV'
4698       include 'COMMON.VAR'
4699       include 'COMMON.CHAIN'
4700       include 'COMMON.IOUNITS'
4701       include 'COMMON.NAMES'
4702       include 'COMMON.FFIELD'
4703       include 'COMMON.CONTROL'
4704       include 'COMMON.TORCNSTR'
4705       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4706      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4707      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4708      & sinph1ph2(maxdouble,maxdouble)
4709       logical lprn /.false./, lprn1 /.false./
4710       etheta=0.0D0
4711       do i=ithet_start,ithet_end
4712         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4713      &(itype(i).eq.ntyp1)) cycle
4714 C        print *,i,theta(i)
4715         if (iabs(itype(i+1)).eq.20) iblock=2
4716         if (iabs(itype(i+1)).ne.20) iblock=1
4717         dethetai=0.0d0
4718         dephii=0.0d0
4719         dephii1=0.0d0
4720         theti2=0.5d0*theta(i)
4721         ityp2=ithetyp((itype(i-1)))
4722         do k=1,nntheterm
4723           coskt(k)=dcos(k*theti2)
4724           sinkt(k)=dsin(k*theti2)
4725         enddo
4726 C        print *,ethetai
4727
4728         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4729 #ifdef OSF
4730           phii=phi(i)
4731           if (phii.ne.phii) phii=150.0
4732 #else
4733           phii=phi(i)
4734 #endif
4735           ityp1=ithetyp((itype(i-2)))
4736 C propagation of chirality for glycine type
4737           do k=1,nsingle
4738             cosph1(k)=dcos(k*phii)
4739             sinph1(k)=dsin(k*phii)
4740           enddo
4741         else
4742           phii=0.0d0
4743           do k=1,nsingle
4744           ityp1=ithetyp((itype(i-2)))
4745             cosph1(k)=0.0d0
4746             sinph1(k)=0.0d0
4747           enddo
4748         endif
4749         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4750 #ifdef OSF
4751           phii1=phi(i+1)
4752           if (phii1.ne.phii1) phii1=150.0
4753           phii1=pinorm(phii1)
4754 #else
4755           phii1=phi(i+1)
4756 #endif
4757           ityp3=ithetyp((itype(i)))
4758           do k=1,nsingle
4759             cosph2(k)=dcos(k*phii1)
4760             sinph2(k)=dsin(k*phii1)
4761           enddo
4762         else
4763           phii1=0.0d0
4764           ityp3=ithetyp((itype(i)))
4765           do k=1,nsingle
4766             cosph2(k)=0.0d0
4767             sinph2(k)=0.0d0
4768           enddo
4769         endif
4770         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4771         do k=1,ndouble
4772           do l=1,k-1
4773             ccl=cosph1(l)*cosph2(k-l)
4774             ssl=sinph1(l)*sinph2(k-l)
4775             scl=sinph1(l)*cosph2(k-l)
4776             csl=cosph1(l)*sinph2(k-l)
4777             cosph1ph2(l,k)=ccl-ssl
4778             cosph1ph2(k,l)=ccl+ssl
4779             sinph1ph2(l,k)=scl+csl
4780             sinph1ph2(k,l)=scl-csl
4781           enddo
4782         enddo
4783         if (lprn) then
4784         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4785      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4786         write (iout,*) "coskt and sinkt"
4787         do k=1,nntheterm
4788           write (iout,*) k,coskt(k),sinkt(k)
4789         enddo
4790         endif
4791         do k=1,ntheterm
4792           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4793           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4794      &      *coskt(k)
4795           if (lprn)
4796      &    write (iout,*) "k",k,"
4797      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4798      &     " ethetai",ethetai
4799         enddo
4800         if (lprn) then
4801         write (iout,*) "cosph and sinph"
4802         do k=1,nsingle
4803           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4804         enddo
4805         write (iout,*) "cosph1ph2 and sinph2ph2"
4806         do k=2,ndouble
4807           do l=1,k-1
4808             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4809      &         sinph1ph2(l,k),sinph1ph2(k,l)
4810           enddo
4811         enddo
4812         write(iout,*) "ethetai",ethetai
4813         endif
4814 C       print *,ethetai
4815         do m=1,ntheterm2
4816           do k=1,nsingle
4817             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4818      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4819      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4820      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4821             ethetai=ethetai+sinkt(m)*aux
4822             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4823             dephii=dephii+k*sinkt(m)*(
4824      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4825      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4826             dephii1=dephii1+k*sinkt(m)*(
4827      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4828      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4829             if (lprn)
4830      &      write (iout,*) "m",m," k",k," bbthet",
4831      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4832      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4833      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4834      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4835 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4836           enddo
4837         enddo
4838 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4839 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4840 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4841 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4842         if (lprn)
4843      &  write(iout,*) "ethetai",ethetai
4844 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4845         do m=1,ntheterm3
4846           do k=2,ndouble
4847             do l=1,k-1
4848               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4849      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4850      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4851      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4852               ethetai=ethetai+sinkt(m)*aux
4853               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4854               dephii=dephii+l*sinkt(m)*(
4855      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4856      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4857      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4858      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4859               dephii1=dephii1+(k-l)*sinkt(m)*(
4860      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4861      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4862      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4863      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4864               if (lprn) then
4865               write (iout,*) "m",m," k",k," l",l," ffthet",
4866      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4867      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4868      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4869      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4870      &            " ethetai",ethetai
4871               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4872      &            cosph1ph2(k,l)*sinkt(m),
4873      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4874               endif
4875             enddo
4876           enddo
4877         enddo
4878 10      continue
4879 c        lprn1=.true.
4880 C        print *,ethetai
4881         if (lprn1)
4882      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4883      &   i,theta(i)*rad2deg,phii*rad2deg,
4884      &   phii1*rad2deg,ethetai
4885 c        lprn1=.false.
4886         etheta=etheta+ethetai
4887         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4888         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4889         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4890       enddo
4891 C now constrains
4892       ethetacnstr=0.0d0
4893 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4894       do i=ithetaconstr_start,ithetaconstr_end
4895         itheta=itheta_constr(i)
4896         thetiii=theta(itheta)
4897         difi=pinorm(thetiii-theta_constr0(i))
4898         if (difi.gt.theta_drange(i)) then
4899           difi=difi-theta_drange(i)
4900           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4901           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4902      &    +for_thet_constr(i)*difi**3
4903         else if (difi.lt.-drange(i)) then
4904           difi=difi+drange(i)
4905           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4906           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4907      &    +for_thet_constr(i)*difi**3
4908         else
4909           difi=0.0
4910         endif
4911        if (energy_dec) then
4912         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4913      &    i,itheta,rad2deg*thetiii,
4914      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4915      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4916      &    gloc(itheta+nphi-2,icg)
4917         endif
4918       enddo
4919
4920       return
4921       end
4922 #endif
4923 #ifdef CRYST_SC
4924 c-----------------------------------------------------------------------------
4925       subroutine esc(escloc)
4926 C Calculate the local energy of a side chain and its derivatives in the
4927 C corresponding virtual-bond valence angles THETA and the spherical angles
4928 C ALPHA and OMEGA.
4929       implicit real*8 (a-h,o-z)
4930       include 'DIMENSIONS'
4931       include 'COMMON.GEO'
4932       include 'COMMON.LOCAL'
4933       include 'COMMON.VAR'
4934       include 'COMMON.INTERACT'
4935       include 'COMMON.DERIV'
4936       include 'COMMON.CHAIN'
4937       include 'COMMON.IOUNITS'
4938       include 'COMMON.NAMES'
4939       include 'COMMON.FFIELD'
4940       include 'COMMON.CONTROL'
4941       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4942      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4943       common /sccalc/ time11,time12,time112,theti,it,nlobit
4944       delta=0.02d0*pi
4945       escloc=0.0D0
4946 c     write (iout,'(a)') 'ESC'
4947       do i=loc_start,loc_end
4948         it=itype(i)
4949         if (it.eq.ntyp1) cycle
4950         if (it.eq.10) goto 1
4951         nlobit=nlob(iabs(it))
4952 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4953 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4954         theti=theta(i+1)-pipol
4955         x(1)=dtan(theti)
4956         x(2)=alph(i)
4957         x(3)=omeg(i)
4958
4959         if (x(2).gt.pi-delta) then
4960           xtemp(1)=x(1)
4961           xtemp(2)=pi-delta
4962           xtemp(3)=x(3)
4963           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4964           xtemp(2)=pi
4965           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4966           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4967      &        escloci,dersc(2))
4968           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4969      &        ddersc0(1),dersc(1))
4970           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4971      &        ddersc0(3),dersc(3))
4972           xtemp(2)=pi-delta
4973           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4974           xtemp(2)=pi
4975           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4976           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4977      &            dersc0(2),esclocbi,dersc02)
4978           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4979      &            dersc12,dersc01)
4980           call splinthet(x(2),0.5d0*delta,ss,ssd)
4981           dersc0(1)=dersc01
4982           dersc0(2)=dersc02
4983           dersc0(3)=0.0d0
4984           do k=1,3
4985             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4986           enddo
4987           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4988 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4989 c    &             esclocbi,ss,ssd
4990           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4991 c         escloci=esclocbi
4992 c         write (iout,*) escloci
4993         else if (x(2).lt.delta) then
4994           xtemp(1)=x(1)
4995           xtemp(2)=delta
4996           xtemp(3)=x(3)
4997           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4998           xtemp(2)=0.0d0
4999           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5000           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5001      &        escloci,dersc(2))
5002           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5003      &        ddersc0(1),dersc(1))
5004           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5005      &        ddersc0(3),dersc(3))
5006           xtemp(2)=delta
5007           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5008           xtemp(2)=0.0d0
5009           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5010           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5011      &            dersc0(2),esclocbi,dersc02)
5012           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5013      &            dersc12,dersc01)
5014           dersc0(1)=dersc01
5015           dersc0(2)=dersc02
5016           dersc0(3)=0.0d0
5017           call splinthet(x(2),0.5d0*delta,ss,ssd)
5018           do k=1,3
5019             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5020           enddo
5021           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5022 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5023 c    &             esclocbi,ss,ssd
5024           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5025 c         write (iout,*) escloci
5026         else
5027           call enesc(x,escloci,dersc,ddummy,.false.)
5028         endif
5029
5030         escloc=escloc+escloci
5031         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5032      &     'escloc',i,escloci
5033 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5034
5035         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5036      &   wscloc*dersc(1)
5037         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5038         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5039     1   continue
5040       enddo
5041       return
5042       end
5043 C---------------------------------------------------------------------------
5044       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5045       implicit real*8 (a-h,o-z)
5046       include 'DIMENSIONS'
5047       include 'COMMON.GEO'
5048       include 'COMMON.LOCAL'
5049       include 'COMMON.IOUNITS'
5050       common /sccalc/ time11,time12,time112,theti,it,nlobit
5051       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5052       double precision contr(maxlob,-1:1)
5053       logical mixed
5054 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5055         escloc_i=0.0D0
5056         do j=1,3
5057           dersc(j)=0.0D0
5058           if (mixed) ddersc(j)=0.0d0
5059         enddo
5060         x3=x(3)
5061
5062 C Because of periodicity of the dependence of the SC energy in omega we have
5063 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5064 C To avoid underflows, first compute & store the exponents.
5065
5066         do iii=-1,1
5067
5068           x(3)=x3+iii*dwapi
5069
5070           do j=1,nlobit
5071             do k=1,3
5072               z(k)=x(k)-censc(k,j,it)
5073             enddo
5074             do k=1,3
5075               Axk=0.0D0
5076               do l=1,3
5077                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5078               enddo
5079               Ax(k,j,iii)=Axk
5080             enddo
5081             expfac=0.0D0
5082             do k=1,3
5083               expfac=expfac+Ax(k,j,iii)*z(k)
5084             enddo
5085             contr(j,iii)=expfac
5086           enddo ! j
5087
5088         enddo ! iii
5089
5090         x(3)=x3
5091 C As in the case of ebend, we want to avoid underflows in exponentiation and
5092 C subsequent NaNs and INFs in energy calculation.
5093 C Find the largest exponent
5094         emin=contr(1,-1)
5095         do iii=-1,1
5096           do j=1,nlobit
5097             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5098           enddo
5099         enddo
5100         emin=0.5D0*emin
5101 cd      print *,'it=',it,' emin=',emin
5102
5103 C Compute the contribution to SC energy and derivatives
5104         do iii=-1,1
5105
5106           do j=1,nlobit
5107 #ifdef OSF
5108             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5109             if(adexp.ne.adexp) adexp=1.0
5110             expfac=dexp(adexp)
5111 #else
5112             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5113 #endif
5114 cd          print *,'j=',j,' expfac=',expfac
5115             escloc_i=escloc_i+expfac
5116             do k=1,3
5117               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5118             enddo
5119             if (mixed) then
5120               do k=1,3,2
5121                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5122      &            +gaussc(k,2,j,it))*expfac
5123               enddo
5124             endif
5125           enddo
5126
5127         enddo ! iii
5128
5129         dersc(1)=dersc(1)/cos(theti)**2
5130         ddersc(1)=ddersc(1)/cos(theti)**2
5131         ddersc(3)=ddersc(3)
5132
5133         escloci=-(dlog(escloc_i)-emin)
5134         do j=1,3
5135           dersc(j)=dersc(j)/escloc_i
5136         enddo
5137         if (mixed) then
5138           do j=1,3,2
5139             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5140           enddo
5141         endif
5142       return
5143       end
5144 C------------------------------------------------------------------------------
5145       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5146       implicit real*8 (a-h,o-z)
5147       include 'DIMENSIONS'
5148       include 'COMMON.GEO'
5149       include 'COMMON.LOCAL'
5150       include 'COMMON.IOUNITS'
5151       common /sccalc/ time11,time12,time112,theti,it,nlobit
5152       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5153       double precision contr(maxlob)
5154       logical mixed
5155
5156       escloc_i=0.0D0
5157
5158       do j=1,3
5159         dersc(j)=0.0D0
5160       enddo
5161
5162       do j=1,nlobit
5163         do k=1,2
5164           z(k)=x(k)-censc(k,j,it)
5165         enddo
5166         z(3)=dwapi
5167         do k=1,3
5168           Axk=0.0D0
5169           do l=1,3
5170             Axk=Axk+gaussc(l,k,j,it)*z(l)
5171           enddo
5172           Ax(k,j)=Axk
5173         enddo
5174         expfac=0.0D0
5175         do k=1,3
5176           expfac=expfac+Ax(k,j)*z(k)
5177         enddo
5178         contr(j)=expfac
5179       enddo ! j
5180
5181 C As in the case of ebend, we want to avoid underflows in exponentiation and
5182 C subsequent NaNs and INFs in energy calculation.
5183 C Find the largest exponent
5184       emin=contr(1)
5185       do j=1,nlobit
5186         if (emin.gt.contr(j)) emin=contr(j)
5187       enddo
5188       emin=0.5D0*emin
5189
5190 C Compute the contribution to SC energy and derivatives
5191
5192       dersc12=0.0d0
5193       do j=1,nlobit
5194         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5195         escloc_i=escloc_i+expfac
5196         do k=1,2
5197           dersc(k)=dersc(k)+Ax(k,j)*expfac
5198         enddo
5199         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5200      &            +gaussc(1,2,j,it))*expfac
5201         dersc(3)=0.0d0
5202       enddo
5203
5204       dersc(1)=dersc(1)/cos(theti)**2
5205       dersc12=dersc12/cos(theti)**2
5206       escloci=-(dlog(escloc_i)-emin)
5207       do j=1,2
5208         dersc(j)=dersc(j)/escloc_i
5209       enddo
5210       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5211       return
5212       end
5213 #else
5214 c----------------------------------------------------------------------------------
5215       subroutine esc(escloc)
5216 C Calculate the local energy of a side chain and its derivatives in the
5217 C corresponding virtual-bond valence angles THETA and the spherical angles
5218 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5219 C added by Urszula Kozlowska. 07/11/2007
5220 C
5221       implicit real*8 (a-h,o-z)
5222       include 'DIMENSIONS'
5223       include 'COMMON.GEO'
5224       include 'COMMON.LOCAL'
5225       include 'COMMON.VAR'
5226       include 'COMMON.SCROT'
5227       include 'COMMON.INTERACT'
5228       include 'COMMON.DERIV'
5229       include 'COMMON.CHAIN'
5230       include 'COMMON.IOUNITS'
5231       include 'COMMON.NAMES'
5232       include 'COMMON.FFIELD'
5233       include 'COMMON.CONTROL'
5234       include 'COMMON.VECTORS'
5235       double precision x_prime(3),y_prime(3),z_prime(3)
5236      &    , sumene,dsc_i,dp2_i,x(65),
5237      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5238      &    de_dxx,de_dyy,de_dzz,de_dt
5239       double precision s1_t,s1_6_t,s2_t,s2_6_t
5240       double precision
5241      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5242      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5243      & dt_dCi(3),dt_dCi1(3)
5244       common /sccalc/ time11,time12,time112,theti,it,nlobit
5245       delta=0.02d0*pi
5246       escloc=0.0D0
5247       do i=loc_start,loc_end
5248         if (itype(i).eq.ntyp1) cycle
5249         costtab(i+1) =dcos(theta(i+1))
5250         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5251         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5252         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5253         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5254         cosfac=dsqrt(cosfac2)
5255         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5256         sinfac=dsqrt(sinfac2)
5257         it=iabs(itype(i))
5258         if (it.eq.10) goto 1
5259 c
5260 C  Compute the axes of tghe local cartesian coordinates system; store in
5261 c   x_prime, y_prime and z_prime
5262 c
5263         do j=1,3
5264           x_prime(j) = 0.00
5265           y_prime(j) = 0.00
5266           z_prime(j) = 0.00
5267         enddo
5268 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5269 C     &   dc_norm(3,i+nres)
5270         do j = 1,3
5271           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5272           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5273         enddo
5274         do j = 1,3
5275           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5276         enddo
5277 c       write (2,*) "i",i
5278 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5279 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5280 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5281 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5282 c      & " xy",scalar(x_prime(1),y_prime(1)),
5283 c      & " xz",scalar(x_prime(1),z_prime(1)),
5284 c      & " yy",scalar(y_prime(1),y_prime(1)),
5285 c      & " yz",scalar(y_prime(1),z_prime(1)),
5286 c      & " zz",scalar(z_prime(1),z_prime(1))
5287 c
5288 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5289 C to local coordinate system. Store in xx, yy, zz.
5290 c
5291         xx=0.0d0
5292         yy=0.0d0
5293         zz=0.0d0
5294         do j = 1,3
5295           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5296           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5297           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5298         enddo
5299
5300         xxtab(i)=xx
5301         yytab(i)=yy
5302         zztab(i)=zz
5303 C
5304 C Compute the energy of the ith side cbain
5305 C
5306 c        write (2,*) "xx",xx," yy",yy," zz",zz
5307         it=iabs(itype(i))
5308         do j = 1,65
5309           x(j) = sc_parmin(j,it)
5310         enddo
5311 #ifdef CHECK_COORD
5312 Cc diagnostics - remove later
5313         xx1 = dcos(alph(2))
5314         yy1 = dsin(alph(2))*dcos(omeg(2))
5315         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5316         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5317      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5318      &    xx1,yy1,zz1
5319 C,"  --- ", xx_w,yy_w,zz_w
5320 c end diagnostics
5321 #endif
5322         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5323      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5324      &   + x(10)*yy*zz
5325         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5326      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5327      & + x(20)*yy*zz
5328         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5329      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5330      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5331      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5332      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5333      &  +x(40)*xx*yy*zz
5334         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5335      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5336      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5337      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5338      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5339      &  +x(60)*xx*yy*zz
5340         dsc_i   = 0.743d0+x(61)
5341         dp2_i   = 1.9d0+x(62)
5342         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5343      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5344         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5345      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5346         s1=(1+x(63))/(0.1d0 + dscp1)
5347         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5348         s2=(1+x(65))/(0.1d0 + dscp2)
5349         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5350         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5351      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5352 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5353 c     &   sumene4,
5354 c     &   dscp1,dscp2,sumene
5355 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5356         escloc = escloc + sumene
5357 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5358 c     & ,zz,xx,yy
5359 c#define DEBUG
5360 #ifdef DEBUG
5361 C
5362 C This section to check the numerical derivatives of the energy of ith side
5363 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5364 C #define DEBUG in the code to turn it on.
5365 C
5366         write (2,*) "sumene               =",sumene
5367         aincr=1.0d-7
5368         xxsave=xx
5369         xx=xx+aincr
5370         write (2,*) xx,yy,zz
5371         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5372         de_dxx_num=(sumenep-sumene)/aincr
5373         xx=xxsave
5374         write (2,*) "xx+ sumene from enesc=",sumenep
5375         yysave=yy
5376         yy=yy+aincr
5377         write (2,*) xx,yy,zz
5378         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5379         de_dyy_num=(sumenep-sumene)/aincr
5380         yy=yysave
5381         write (2,*) "yy+ sumene from enesc=",sumenep
5382         zzsave=zz
5383         zz=zz+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dzz_num=(sumenep-sumene)/aincr
5387         zz=zzsave
5388         write (2,*) "zz+ sumene from enesc=",sumenep
5389         costsave=cost2tab(i+1)
5390         sintsave=sint2tab(i+1)
5391         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5392         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5394         de_dt_num=(sumenep-sumene)/aincr
5395         write (2,*) " t+ sumene from enesc=",sumenep
5396         cost2tab(i+1)=costsave
5397         sint2tab(i+1)=sintsave
5398 C End of diagnostics section.
5399 #endif
5400 C
5401 C Compute the gradient of esc
5402 C
5403 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5404         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5405         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5406         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5407         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5408         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5409         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5410         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5411         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5412         pom1=(sumene3*sint2tab(i+1)+sumene1)
5413      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5414         pom2=(sumene4*cost2tab(i+1)+sumene2)
5415      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5416         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5417         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5418      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5419      &  +x(40)*yy*zz
5420         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5421         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5422      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5423      &  +x(60)*yy*zz
5424         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5425      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5426      &        +(pom1+pom2)*pom_dx
5427 #ifdef DEBUG
5428         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5429 #endif
5430 C
5431         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5432         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5433      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5434      &  +x(40)*xx*zz
5435         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5436         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5437      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5438      &  +x(59)*zz**2 +x(60)*xx*zz
5439         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5440      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5441      &        +(pom1-pom2)*pom_dy
5442 #ifdef DEBUG
5443         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5444 #endif
5445 C
5446         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5447      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5448      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5449      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5450      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5451      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5452      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5453      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5454 #ifdef DEBUG
5455         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5456 #endif
5457 C
5458         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5459      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5460      &  +pom1*pom_dt1+pom2*pom_dt2
5461 #ifdef DEBUG
5462         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5463 #endif
5464 c#undef DEBUG
5465 c
5466 C
5467        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5468        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5469        cosfac2xx=cosfac2*xx
5470        sinfac2yy=sinfac2*yy
5471        do k = 1,3
5472          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5473      &      vbld_inv(i+1)
5474          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5475      &      vbld_inv(i)
5476          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5477          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5478 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5479 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5480 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5481 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5482          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5483          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5484          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5485          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5486          dZZ_Ci1(k)=0.0d0
5487          dZZ_Ci(k)=0.0d0
5488          do j=1,3
5489            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5490      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5491            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5492      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5493          enddo
5494
5495          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5496          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5497          dZZ_XYZ(k)=vbld_inv(i+nres)*
5498      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5499 c
5500          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5501          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5502        enddo
5503
5504        do k=1,3
5505          dXX_Ctab(k,i)=dXX_Ci(k)
5506          dXX_C1tab(k,i)=dXX_Ci1(k)
5507          dYY_Ctab(k,i)=dYY_Ci(k)
5508          dYY_C1tab(k,i)=dYY_Ci1(k)
5509          dZZ_Ctab(k,i)=dZZ_Ci(k)
5510          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5511          dXX_XYZtab(k,i)=dXX_XYZ(k)
5512          dYY_XYZtab(k,i)=dYY_XYZ(k)
5513          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5514        enddo
5515
5516        do k = 1,3
5517 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5518 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5519 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5520 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5521 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5522 c     &    dt_dci(k)
5523 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5524 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5525          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5526      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5527          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5528      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5529          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5530      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5531        enddo
5532 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5533 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5534
5535 C to check gradient call subroutine check_grad
5536
5537     1 continue
5538       enddo
5539       return
5540       end
5541 c------------------------------------------------------------------------------
5542       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5543       implicit none
5544       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5545      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5546       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5547      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5548      &   + x(10)*yy*zz
5549       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5550      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5551      & + x(20)*yy*zz
5552       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5553      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5554      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5555      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5556      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5557      &  +x(40)*xx*yy*zz
5558       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5559      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5560      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5561      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5562      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5563      &  +x(60)*xx*yy*zz
5564       dsc_i   = 0.743d0+x(61)
5565       dp2_i   = 1.9d0+x(62)
5566       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5567      &          *(xx*cost2+yy*sint2))
5568       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5569      &          *(xx*cost2-yy*sint2))
5570       s1=(1+x(63))/(0.1d0 + dscp1)
5571       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5572       s2=(1+x(65))/(0.1d0 + dscp2)
5573       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5574       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5575      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5576       enesc=sumene
5577       return
5578       end
5579 #endif
5580 c------------------------------------------------------------------------------
5581       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5582 C
5583 C This procedure calculates two-body contact function g(rij) and its derivative:
5584 C
5585 C           eps0ij                                     !       x < -1
5586 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5587 C            0                                         !       x > 1
5588 C
5589 C where x=(rij-r0ij)/delta
5590 C
5591 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5592 C
5593       implicit none
5594       double precision rij,r0ij,eps0ij,fcont,fprimcont
5595       double precision x,x2,x4,delta
5596 c     delta=0.02D0*r0ij
5597 c      delta=0.2D0*r0ij
5598       x=(rij-r0ij)/delta
5599       if (x.lt.-1.0D0) then
5600         fcont=eps0ij
5601         fprimcont=0.0D0
5602       else if (x.le.1.0D0) then
5603         x2=x*x
5604         x4=x2*x2
5605         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5606         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5607       else
5608         fcont=0.0D0
5609         fprimcont=0.0D0
5610       endif
5611       return
5612       end
5613 c------------------------------------------------------------------------------
5614       subroutine splinthet(theti,delta,ss,ssder)
5615       implicit real*8 (a-h,o-z)
5616       include 'DIMENSIONS'
5617       include 'COMMON.VAR'
5618       include 'COMMON.GEO'
5619       thetup=pi-delta
5620       thetlow=delta
5621       if (theti.gt.pipol) then
5622         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5623       else
5624         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5625         ssder=-ssder
5626       endif
5627       return
5628       end
5629 c------------------------------------------------------------------------------
5630       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5631       implicit none
5632       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5633       double precision ksi,ksi2,ksi3,a1,a2,a3
5634       a1=fprim0*delta/(f1-f0)
5635       a2=3.0d0-2.0d0*a1
5636       a3=a1-2.0d0
5637       ksi=(x-x0)/delta
5638       ksi2=ksi*ksi
5639       ksi3=ksi2*ksi
5640       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5641       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5642       return
5643       end
5644 c------------------------------------------------------------------------------
5645       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5646       implicit none
5647       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5648       double precision ksi,ksi2,ksi3,a1,a2,a3
5649       ksi=(x-x0)/delta
5650       ksi2=ksi*ksi
5651       ksi3=ksi2*ksi
5652       a1=fprim0x*delta
5653       a2=3*(f1x-f0x)-2*fprim0x*delta
5654       a3=fprim0x*delta-2*(f1x-f0x)
5655       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5656       return
5657       end
5658 C-----------------------------------------------------------------------------
5659 #ifdef CRYST_TOR
5660 C-----------------------------------------------------------------------------
5661       subroutine etor(etors,edihcnstr)
5662       implicit real*8 (a-h,o-z)
5663       include 'DIMENSIONS'
5664       include 'COMMON.VAR'
5665       include 'COMMON.GEO'
5666       include 'COMMON.LOCAL'
5667       include 'COMMON.TORSION'
5668       include 'COMMON.INTERACT'
5669       include 'COMMON.DERIV'
5670       include 'COMMON.CHAIN'
5671       include 'COMMON.NAMES'
5672       include 'COMMON.IOUNITS'
5673       include 'COMMON.FFIELD'
5674       include 'COMMON.TORCNSTR'
5675       include 'COMMON.CONTROL'
5676       logical lprn
5677 C Set lprn=.true. for debugging
5678       lprn=.false.
5679 c      lprn=.true.
5680       etors=0.0D0
5681       do i=iphi_start,iphi_end
5682       etors_ii=0.0D0
5683         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5684      &      .or. itype(i).eq.ntyp1) cycle
5685         itori=itortyp(itype(i-2))
5686         itori1=itortyp(itype(i-1))
5687         phii=phi(i)
5688         gloci=0.0D0
5689 C Proline-Proline pair is a special case...
5690         if (itori.eq.3 .and. itori1.eq.3) then
5691           if (phii.gt.-dwapi3) then
5692             cosphi=dcos(3*phii)
5693             fac=1.0D0/(1.0D0-cosphi)
5694             etorsi=v1(1,3,3)*fac
5695             etorsi=etorsi+etorsi
5696             etors=etors+etorsi-v1(1,3,3)
5697             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5698             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5699           endif
5700           do j=1,3
5701             v1ij=v1(j+1,itori,itori1)
5702             v2ij=v2(j+1,itori,itori1)
5703             cosphi=dcos(j*phii)
5704             sinphi=dsin(j*phii)
5705             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5706             if (energy_dec) etors_ii=etors_ii+
5707      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5708             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5709           enddo
5710         else
5711           do j=1,nterm_old
5712             v1ij=v1(j,itori,itori1)
5713             v2ij=v2(j,itori,itori1)
5714             cosphi=dcos(j*phii)
5715             sinphi=dsin(j*phii)
5716             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5717             if (energy_dec) etors_ii=etors_ii+
5718      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5719             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5720           enddo
5721         endif
5722         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5723              'etor',i,etors_ii
5724         if (lprn)
5725      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5726      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5727      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5728         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5729 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5730       enddo
5731 ! 6/20/98 - dihedral angle constraints
5732       edihcnstr=0.0d0
5733       do i=1,ndih_constr
5734         itori=idih_constr(i)
5735         phii=phi(itori)
5736         difi=phii-phi0(i)
5737         if (difi.gt.drange(i)) then
5738           difi=difi-drange(i)
5739           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5740           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5741         else if (difi.lt.-drange(i)) then
5742           difi=difi+drange(i)
5743           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
5744           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5745         endif
5746 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5747 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5748       enddo
5749 !      write (iout,*) 'edihcnstr',edihcnstr
5750       return
5751       end
5752 c------------------------------------------------------------------------------
5753       subroutine etor_d(etors_d)
5754       etors_d=0.0d0
5755       return
5756       end
5757 c----------------------------------------------------------------------------
5758 #else
5759       subroutine etor(etors,edihcnstr)
5760       implicit real*8 (a-h,o-z)
5761       include 'DIMENSIONS'
5762       include 'COMMON.VAR'
5763       include 'COMMON.GEO'
5764       include 'COMMON.LOCAL'
5765       include 'COMMON.TORSION'
5766       include 'COMMON.INTERACT'
5767       include 'COMMON.DERIV'
5768       include 'COMMON.CHAIN'
5769       include 'COMMON.NAMES'
5770       include 'COMMON.IOUNITS'
5771       include 'COMMON.FFIELD'
5772       include 'COMMON.TORCNSTR'
5773       include 'COMMON.CONTROL'
5774       logical lprn
5775 C Set lprn=.true. for debugging
5776       lprn=.false.
5777 c     lprn=.true.
5778       etors=0.0D0
5779       do i=iphi_start,iphi_end
5780         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5781      &       .or. itype(i).eq.ntyp1) cycle
5782         etors_ii=0.0D0
5783          if (iabs(itype(i)).eq.20) then
5784          iblock=2
5785          else
5786          iblock=1
5787          endif
5788         itori=itortyp(itype(i-2))
5789         itori1=itortyp(itype(i-1))
5790         phii=phi(i)
5791         gloci=0.0D0
5792 C Regular cosine and sine terms
5793         do j=1,nterm(itori,itori1,iblock)
5794           v1ij=v1(j,itori,itori1,iblock)
5795           v2ij=v2(j,itori,itori1,iblock)
5796           cosphi=dcos(j*phii)
5797           sinphi=dsin(j*phii)
5798           etors=etors+v1ij*cosphi+v2ij*sinphi
5799           if (energy_dec) etors_ii=etors_ii+
5800      &                v1ij*cosphi+v2ij*sinphi
5801           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5802         enddo
5803 C Lorentz terms
5804 C                         v1
5805 C  E = SUM ----------------------------------- - v1
5806 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5807 C
5808         cosphi=dcos(0.5d0*phii)
5809         sinphi=dsin(0.5d0*phii)
5810         do j=1,nlor(itori,itori1,iblock)
5811           vl1ij=vlor1(j,itori,itori1)
5812           vl2ij=vlor2(j,itori,itori1)
5813           vl3ij=vlor3(j,itori,itori1)
5814           pom=vl2ij*cosphi+vl3ij*sinphi
5815           pom1=1.0d0/(pom*pom+1.0d0)
5816           etors=etors+vl1ij*pom1
5817           if (energy_dec) etors_ii=etors_ii+
5818      &                vl1ij*pom1
5819           pom=-pom*pom1*pom1
5820           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5821         enddo
5822 C Subtract the constant term
5823         etors=etors-v0(itori,itori1,iblock)
5824           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5825      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5826         if (lprn)
5827      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5828      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5829      &  (v1(j,itori,itori1,iblock),j=1,6),
5830      &  (v2(j,itori,itori1,iblock),j=1,6)
5831         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5832 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5833       enddo
5834 ! 6/20/98 - dihedral angle constraints
5835       edihcnstr=0.0d0
5836 c      do i=1,ndih_constr
5837       do i=idihconstr_start,idihconstr_end
5838         itori=idih_constr(i)
5839         phii=phi(itori)
5840         difi=pinorm(phii-phi0(i))
5841         if (difi.gt.drange(i)) then
5842           difi=difi-drange(i)
5843           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5844           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5845         else if (difi.lt.-drange(i)) then
5846           difi=difi+drange(i)
5847           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5848           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5849         else
5850           difi=0.0
5851         endif
5852        if (energy_dec) then
5853         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
5854      &    i,itori,rad2deg*phii,
5855      &    rad2deg*phi0(i),  rad2deg*drange(i),
5856      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5857         endif
5858       enddo
5859 cd       write (iout,*) 'edihcnstr',edihcnstr
5860       return
5861       end
5862 c----------------------------------------------------------------------------
5863       subroutine etor_d(etors_d)
5864 C 6/23/01 Compute double torsional energy
5865       implicit real*8 (a-h,o-z)
5866       include 'DIMENSIONS'
5867       include 'COMMON.VAR'
5868       include 'COMMON.GEO'
5869       include 'COMMON.LOCAL'
5870       include 'COMMON.TORSION'
5871       include 'COMMON.INTERACT'
5872       include 'COMMON.DERIV'
5873       include 'COMMON.CHAIN'
5874       include 'COMMON.NAMES'
5875       include 'COMMON.IOUNITS'
5876       include 'COMMON.FFIELD'
5877       include 'COMMON.TORCNSTR'
5878       logical lprn
5879 C Set lprn=.true. for debugging
5880       lprn=.false.
5881 c     lprn=.true.
5882       etors_d=0.0D0
5883 c      write(iout,*) "a tu??"
5884       do i=iphid_start,iphid_end
5885         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5886      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5887         itori=itortyp(itype(i-2))
5888         itori1=itortyp(itype(i-1))
5889         itori2=itortyp(itype(i))
5890         phii=phi(i)
5891         phii1=phi(i+1)
5892         gloci1=0.0D0
5893         gloci2=0.0D0
5894         iblock=1
5895         if (iabs(itype(i+1)).eq.20) iblock=2
5896
5897 C Regular cosine and sine terms
5898         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5899           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5900           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5901           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5902           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5903           cosphi1=dcos(j*phii)
5904           sinphi1=dsin(j*phii)
5905           cosphi2=dcos(j*phii1)
5906           sinphi2=dsin(j*phii1)
5907           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5908      &     v2cij*cosphi2+v2sij*sinphi2
5909           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5910           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5911         enddo
5912         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5913           do l=1,k-1
5914             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5915             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5916             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5917             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5918             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5919             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5920             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5921             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5922             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5923      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5924             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5925      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5926             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5927      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5928           enddo
5929         enddo
5930         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5931         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5932       enddo
5933       return
5934       end
5935 #endif
5936 c------------------------------------------------------------------------------
5937       subroutine eback_sc_corr(esccor)
5938 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5939 c        conformational states; temporarily implemented as differences
5940 c        between UNRES torsional potentials (dependent on three types of
5941 c        residues) and the torsional potentials dependent on all 20 types
5942 c        of residues computed from AM1  energy surfaces of terminally-blocked
5943 c        amino-acid residues.
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'COMMON.VAR'
5947       include 'COMMON.GEO'
5948       include 'COMMON.LOCAL'
5949       include 'COMMON.TORSION'
5950       include 'COMMON.SCCOR'
5951       include 'COMMON.INTERACT'
5952       include 'COMMON.DERIV'
5953       include 'COMMON.CHAIN'
5954       include 'COMMON.NAMES'
5955       include 'COMMON.IOUNITS'
5956       include 'COMMON.FFIELD'
5957       include 'COMMON.CONTROL'
5958       logical lprn
5959 C Set lprn=.true. for debugging
5960       lprn=.false.
5961 c      lprn=.true.
5962 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5963       esccor=0.0D0
5964       do i=itau_start,itau_end
5965         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5966         esccor_ii=0.0D0
5967         isccori=isccortyp(itype(i-2))
5968         isccori1=isccortyp(itype(i-1))
5969 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5970         phii=phi(i)
5971         do intertyp=1,3 !intertyp
5972 cc Added 09 May 2012 (Adasko)
5973 cc  Intertyp means interaction type of backbone mainchain correlation:
5974 c   1 = SC...Ca...Ca...Ca
5975 c   2 = Ca...Ca...Ca...SC
5976 c   3 = SC...Ca...Ca...SCi
5977         gloci=0.0D0
5978         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5979      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5980      &      (itype(i-1).eq.ntyp1)))
5981      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5982      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5983      &     .or.(itype(i).eq.ntyp1)))
5984      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5985      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5986      &      (itype(i-3).eq.ntyp1)))) cycle
5987         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5988         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5989      & cycle
5990        do j=1,nterm_sccor(isccori,isccori1)
5991           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5992           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5993           cosphi=dcos(j*tauangle(intertyp,i))
5994           sinphi=dsin(j*tauangle(intertyp,i))
5995           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5996           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5997         enddo
5998 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5999         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6000         if (lprn)
6001      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6002      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6003      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6004      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6005         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6006        enddo !intertyp
6007       enddo
6008
6009       return
6010       end
6011 c----------------------------------------------------------------------------
6012       subroutine multibody(ecorr)
6013 C This subroutine calculates multi-body contributions to energy following
6014 C the idea of Skolnick et al. If side chains I and J make a contact and
6015 C at the same time side chains I+1 and J+1 make a contact, an extra
6016 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6017       implicit real*8 (a-h,o-z)
6018       include 'DIMENSIONS'
6019       include 'COMMON.IOUNITS'
6020       include 'COMMON.DERIV'
6021       include 'COMMON.INTERACT'
6022       include 'COMMON.CONTACTS'
6023       double precision gx(3),gx1(3)
6024       logical lprn
6025
6026 C Set lprn=.true. for debugging
6027       lprn=.false.
6028
6029       if (lprn) then
6030         write (iout,'(a)') 'Contact function values:'
6031         do i=nnt,nct-2
6032           write (iout,'(i2,20(1x,i2,f10.5))')
6033      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6034         enddo
6035       endif
6036       ecorr=0.0D0
6037       do i=nnt,nct
6038         do j=1,3
6039           gradcorr(j,i)=0.0D0
6040           gradxorr(j,i)=0.0D0
6041         enddo
6042       enddo
6043       do i=nnt,nct-2
6044
6045         DO ISHIFT = 3,4
6046
6047         i1=i+ishift
6048         num_conti=num_cont(i)
6049         num_conti1=num_cont(i1)
6050         do jj=1,num_conti
6051           j=jcont(jj,i)
6052           do kk=1,num_conti1
6053             j1=jcont(kk,i1)
6054             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6055 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6056 cd   &                   ' ishift=',ishift
6057 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6058 C The system gains extra energy.
6059               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6060             endif   ! j1==j+-ishift
6061           enddo     ! kk
6062         enddo       ! jj
6063
6064         ENDDO ! ISHIFT
6065
6066       enddo         ! i
6067       return
6068       end
6069 c------------------------------------------------------------------------------
6070       double precision function esccorr(i,j,k,l,jj,kk)
6071       implicit real*8 (a-h,o-z)
6072       include 'DIMENSIONS'
6073       include 'COMMON.IOUNITS'
6074       include 'COMMON.DERIV'
6075       include 'COMMON.INTERACT'
6076       include 'COMMON.CONTACTS'
6077       double precision gx(3),gx1(3)
6078       logical lprn
6079       lprn=.false.
6080       eij=facont(jj,i)
6081       ekl=facont(kk,k)
6082 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6083 C Calculate the multi-body contribution to energy.
6084 C Calculate multi-body contributions to the gradient.
6085 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6086 cd   & k,l,(gacont(m,kk,k),m=1,3)
6087       do m=1,3
6088         gx(m) =ekl*gacont(m,jj,i)
6089         gx1(m)=eij*gacont(m,kk,k)
6090         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6091         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6092         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6093         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6094       enddo
6095       do m=i,j-1
6096         do ll=1,3
6097           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6098         enddo
6099       enddo
6100       do m=k,l-1
6101         do ll=1,3
6102           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6103         enddo
6104       enddo
6105       esccorr=-eij*ekl
6106       return
6107       end
6108 c------------------------------------------------------------------------------
6109       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6110 C This subroutine calculates multi-body contributions to hydrogen-bonding
6111       implicit real*8 (a-h,o-z)
6112       include 'DIMENSIONS'
6113       include 'COMMON.IOUNITS'
6114 #ifdef MPI
6115       include "mpif.h"
6116       parameter (max_cont=maxconts)
6117       parameter (max_dim=26)
6118       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6119       double precision zapas(max_dim,maxconts,max_fg_procs),
6120      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6121       common /przechowalnia/ zapas
6122       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6123      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6124 #endif
6125       include 'COMMON.SETUP'
6126       include 'COMMON.FFIELD'
6127       include 'COMMON.DERIV'
6128       include 'COMMON.INTERACT'
6129       include 'COMMON.CONTACTS'
6130       include 'COMMON.CONTROL'
6131       include 'COMMON.LOCAL'
6132       double precision gx(3),gx1(3),time00
6133       logical lprn,ldone
6134
6135 C Set lprn=.true. for debugging
6136       lprn=.false.
6137 #ifdef MPI
6138       n_corr=0
6139       n_corr1=0
6140       if (nfgtasks.le.1) goto 30
6141       if (lprn) then
6142         write (iout,'(a)') 'Contact function values before RECEIVE:'
6143         do i=nnt,nct-2
6144           write (iout,'(2i3,50(1x,i2,f5.2))')
6145      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6146      &    j=1,num_cont_hb(i))
6147         enddo
6148       endif
6149       call flush(iout)
6150       do i=1,ntask_cont_from
6151         ncont_recv(i)=0
6152       enddo
6153       do i=1,ntask_cont_to
6154         ncont_sent(i)=0
6155       enddo
6156 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6157 c     & ntask_cont_to
6158 C Make the list of contacts to send to send to other procesors
6159 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6160 c      call flush(iout)
6161       do i=iturn3_start,iturn3_end
6162 c        write (iout,*) "make contact list turn3",i," num_cont",
6163 c     &    num_cont_hb(i)
6164         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6165       enddo
6166       do i=iturn4_start,iturn4_end
6167 c        write (iout,*) "make contact list turn4",i," num_cont",
6168 c     &   num_cont_hb(i)
6169         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6170       enddo
6171       do ii=1,nat_sent
6172         i=iat_sent(ii)
6173 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6174 c     &    num_cont_hb(i)
6175         do j=1,num_cont_hb(i)
6176         do k=1,4
6177           jjc=jcont_hb(j,i)
6178           iproc=iint_sent_local(k,jjc,ii)
6179 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6180           if (iproc.gt.0) then
6181             ncont_sent(iproc)=ncont_sent(iproc)+1
6182             nn=ncont_sent(iproc)
6183             zapas(1,nn,iproc)=i
6184             zapas(2,nn,iproc)=jjc
6185             zapas(3,nn,iproc)=facont_hb(j,i)
6186             zapas(4,nn,iproc)=ees0p(j,i)
6187             zapas(5,nn,iproc)=ees0m(j,i)
6188             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6189             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6190             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6191             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6192             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6193             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6194             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6195             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6196             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6197             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6198             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6199             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6200             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6201             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6202             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6203             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6204             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6205             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6206             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6207             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6208             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6209           endif
6210         enddo
6211         enddo
6212       enddo
6213       if (lprn) then
6214       write (iout,*)
6215      &  "Numbers of contacts to be sent to other processors",
6216      &  (ncont_sent(i),i=1,ntask_cont_to)
6217       write (iout,*) "Contacts sent"
6218       do ii=1,ntask_cont_to
6219         nn=ncont_sent(ii)
6220         iproc=itask_cont_to(ii)
6221         write (iout,*) nn," contacts to processor",iproc,
6222      &   " of CONT_TO_COMM group"
6223         do i=1,nn
6224           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6225         enddo
6226       enddo
6227       call flush(iout)
6228       endif
6229       CorrelType=477
6230       CorrelID=fg_rank+1
6231       CorrelType1=478
6232       CorrelID1=nfgtasks+fg_rank+1
6233       ireq=0
6234 C Receive the numbers of needed contacts from other processors
6235       do ii=1,ntask_cont_from
6236         iproc=itask_cont_from(ii)
6237         ireq=ireq+1
6238         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6239      &    FG_COMM,req(ireq),IERR)
6240       enddo
6241 c      write (iout,*) "IRECV ended"
6242 c      call flush(iout)
6243 C Send the number of contacts needed by other processors
6244       do ii=1,ntask_cont_to
6245         iproc=itask_cont_to(ii)
6246         ireq=ireq+1
6247         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6248      &    FG_COMM,req(ireq),IERR)
6249       enddo
6250 c      write (iout,*) "ISEND ended"
6251 c      write (iout,*) "number of requests (nn)",ireq
6252       call flush(iout)
6253       if (ireq.gt.0)
6254      &  call MPI_Waitall(ireq,req,status_array,ierr)
6255 c      write (iout,*)
6256 c     &  "Numbers of contacts to be received from other processors",
6257 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6258 c      call flush(iout)
6259 C Receive contacts
6260       ireq=0
6261       do ii=1,ntask_cont_from
6262         iproc=itask_cont_from(ii)
6263         nn=ncont_recv(ii)
6264 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6265 c     &   " of CONT_TO_COMM group"
6266         call flush(iout)
6267         if (nn.gt.0) then
6268           ireq=ireq+1
6269           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6270      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6271 c          write (iout,*) "ireq,req",ireq,req(ireq)
6272         endif
6273       enddo
6274 C Send the contacts to processors that need them
6275       do ii=1,ntask_cont_to
6276         iproc=itask_cont_to(ii)
6277         nn=ncont_sent(ii)
6278 c        write (iout,*) nn," contacts to processor",iproc,
6279 c     &   " of CONT_TO_COMM group"
6280         if (nn.gt.0) then
6281           ireq=ireq+1
6282           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6283      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6284 c          write (iout,*) "ireq,req",ireq,req(ireq)
6285 c          do i=1,nn
6286 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6287 c          enddo
6288         endif
6289       enddo
6290 c      write (iout,*) "number of requests (contacts)",ireq
6291 c      write (iout,*) "req",(req(i),i=1,4)
6292 c      call flush(iout)
6293       if (ireq.gt.0)
6294      & call MPI_Waitall(ireq,req,status_array,ierr)
6295       do iii=1,ntask_cont_from
6296         iproc=itask_cont_from(iii)
6297         nn=ncont_recv(iii)
6298         if (lprn) then
6299         write (iout,*) "Received",nn," contacts from processor",iproc,
6300      &   " of CONT_FROM_COMM group"
6301         call flush(iout)
6302         do i=1,nn
6303           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6304         enddo
6305         call flush(iout)
6306         endif
6307         do i=1,nn
6308           ii=zapas_recv(1,i,iii)
6309 c Flag the received contacts to prevent double-counting
6310           jj=-zapas_recv(2,i,iii)
6311 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6312 c          call flush(iout)
6313           nnn=num_cont_hb(ii)+1
6314           num_cont_hb(ii)=nnn
6315           jcont_hb(nnn,ii)=jj
6316           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6317           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6318           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6319           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6320           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6321           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6322           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6323           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6324           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6325           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6326           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6327           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6328           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6329           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6330           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6331           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6332           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6333           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6334           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6335           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6336           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6337           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6338           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6339           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6340         enddo
6341       enddo
6342       call flush(iout)
6343       if (lprn) then
6344         write (iout,'(a)') 'Contact function values after receive:'
6345         do i=nnt,nct-2
6346           write (iout,'(2i3,50(1x,i3,f5.2))')
6347      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6348      &    j=1,num_cont_hb(i))
6349         enddo
6350         call flush(iout)
6351       endif
6352    30 continue
6353 #endif
6354       if (lprn) then
6355         write (iout,'(a)') 'Contact function values:'
6356         do i=nnt,nct-2
6357           write (iout,'(2i3,50(1x,i3,f5.2))')
6358      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6359      &    j=1,num_cont_hb(i))
6360         enddo
6361       endif
6362       ecorr=0.0D0
6363 C Remove the loop below after debugging !!!
6364       do i=nnt,nct
6365         do j=1,3
6366           gradcorr(j,i)=0.0D0
6367           gradxorr(j,i)=0.0D0
6368         enddo
6369       enddo
6370 C Calculate the local-electrostatic correlation terms
6371       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6372         i1=i+1
6373         num_conti=num_cont_hb(i)
6374         num_conti1=num_cont_hb(i+1)
6375         do jj=1,num_conti
6376           j=jcont_hb(jj,i)
6377           jp=iabs(j)
6378           do kk=1,num_conti1
6379             j1=jcont_hb(kk,i1)
6380             jp1=iabs(j1)
6381 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6382 c     &         ' jj=',jj,' kk=',kk
6383             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6384      &          .or. j.lt.0 .and. j1.gt.0) .and.
6385      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6386 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6387 C The system gains extra energy.
6388               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6389               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6390      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6391               n_corr=n_corr+1
6392             else if (j1.eq.j) then
6393 C Contacts I-J and I-(J+1) occur simultaneously.
6394 C The system loses extra energy.
6395 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6396             endif
6397           enddo ! kk
6398           do kk=1,num_conti
6399             j1=jcont_hb(kk,i)
6400 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6401 c    &         ' jj=',jj,' kk=',kk
6402             if (j1.eq.j+1) then
6403 C Contacts I-J and (I+1)-J occur simultaneously.
6404 C The system loses extra energy.
6405 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6406             endif ! j1==j+1
6407           enddo ! kk
6408         enddo ! jj
6409       enddo ! i
6410       return
6411       end
6412 c------------------------------------------------------------------------------
6413       subroutine add_hb_contact(ii,jj,itask)
6414       implicit real*8 (a-h,o-z)
6415       include "DIMENSIONS"
6416       include "COMMON.IOUNITS"
6417       integer max_cont
6418       integer max_dim
6419       parameter (max_cont=maxconts)
6420       parameter (max_dim=26)
6421       include "COMMON.CONTACTS"
6422       double precision zapas(max_dim,maxconts,max_fg_procs),
6423      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6424       common /przechowalnia/ zapas
6425       integer i,j,ii,jj,iproc,itask(4),nn
6426 c      write (iout,*) "itask",itask
6427       do i=1,2
6428         iproc=itask(i)
6429         if (iproc.gt.0) then
6430           do j=1,num_cont_hb(ii)
6431             jjc=jcont_hb(j,ii)
6432 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6433             if (jjc.eq.jj) then
6434               ncont_sent(iproc)=ncont_sent(iproc)+1
6435               nn=ncont_sent(iproc)
6436               zapas(1,nn,iproc)=ii
6437               zapas(2,nn,iproc)=jjc
6438               zapas(3,nn,iproc)=facont_hb(j,ii)
6439               zapas(4,nn,iproc)=ees0p(j,ii)
6440               zapas(5,nn,iproc)=ees0m(j,ii)
6441               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6442               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6443               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6444               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6445               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6446               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6447               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6448               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6449               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6450               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6451               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6452               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6453               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6454               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6455               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6456               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6457               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6458               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6459               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6460               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6461               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6462               exit
6463             endif
6464           enddo
6465         endif
6466       enddo
6467       return
6468       end
6469 c------------------------------------------------------------------------------
6470       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6471      &  n_corr1)
6472 C This subroutine calculates multi-body contributions to hydrogen-bonding
6473       implicit real*8 (a-h,o-z)
6474       include 'DIMENSIONS'
6475       include 'COMMON.IOUNITS'
6476 #ifdef MPI
6477       include "mpif.h"
6478       parameter (max_cont=maxconts)
6479       parameter (max_dim=70)
6480       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6481       double precision zapas(max_dim,maxconts,max_fg_procs),
6482      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6483       common /przechowalnia/ zapas
6484       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6485      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6486 #endif
6487       include 'COMMON.SETUP'
6488       include 'COMMON.FFIELD'
6489       include 'COMMON.DERIV'
6490       include 'COMMON.LOCAL'
6491       include 'COMMON.INTERACT'
6492       include 'COMMON.CONTACTS'
6493       include 'COMMON.CHAIN'
6494       include 'COMMON.CONTROL'
6495       double precision gx(3),gx1(3)
6496       integer num_cont_hb_old(maxres)
6497       logical lprn,ldone
6498       double precision eello4,eello5,eelo6,eello_turn6
6499       external eello4,eello5,eello6,eello_turn6
6500 C Set lprn=.true. for debugging
6501       lprn=.false.
6502       eturn6=0.0d0
6503 #ifdef MPI
6504       do i=1,nres
6505         num_cont_hb_old(i)=num_cont_hb(i)
6506       enddo
6507       n_corr=0
6508       n_corr1=0
6509       if (nfgtasks.le.1) goto 30
6510       if (lprn) then
6511         write (iout,'(a)') 'Contact function values before RECEIVE:'
6512         do i=nnt,nct-2
6513           write (iout,'(2i3,50(1x,i2,f5.2))')
6514      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6515      &    j=1,num_cont_hb(i))
6516         enddo
6517       endif
6518       call flush(iout)
6519       do i=1,ntask_cont_from
6520         ncont_recv(i)=0
6521       enddo
6522       do i=1,ntask_cont_to
6523         ncont_sent(i)=0
6524       enddo
6525 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6526 c     & ntask_cont_to
6527 C Make the list of contacts to send to send to other procesors
6528       do i=iturn3_start,iturn3_end
6529 c        write (iout,*) "make contact list turn3",i," num_cont",
6530 c     &    num_cont_hb(i)
6531         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6532       enddo
6533       do i=iturn4_start,iturn4_end
6534 c        write (iout,*) "make contact list turn4",i," num_cont",
6535 c     &   num_cont_hb(i)
6536         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6537       enddo
6538       do ii=1,nat_sent
6539         i=iat_sent(ii)
6540 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6541 c     &    num_cont_hb(i)
6542         do j=1,num_cont_hb(i)
6543         do k=1,4
6544           jjc=jcont_hb(j,i)
6545           iproc=iint_sent_local(k,jjc,ii)
6546 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6547           if (iproc.ne.0) then
6548             ncont_sent(iproc)=ncont_sent(iproc)+1
6549             nn=ncont_sent(iproc)
6550             zapas(1,nn,iproc)=i
6551             zapas(2,nn,iproc)=jjc
6552             zapas(3,nn,iproc)=d_cont(j,i)
6553             ind=3
6554             do kk=1,3
6555               ind=ind+1
6556               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6557             enddo
6558             do kk=1,2
6559               do ll=1,2
6560                 ind=ind+1
6561                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6562               enddo
6563             enddo
6564             do jj=1,5
6565               do kk=1,3
6566                 do ll=1,2
6567                   do mm=1,2
6568                     ind=ind+1
6569                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6570                   enddo
6571                 enddo
6572               enddo
6573             enddo
6574           endif
6575         enddo
6576         enddo
6577       enddo
6578       if (lprn) then
6579       write (iout,*)
6580      &  "Numbers of contacts to be sent to other processors",
6581      &  (ncont_sent(i),i=1,ntask_cont_to)
6582       write (iout,*) "Contacts sent"
6583       do ii=1,ntask_cont_to
6584         nn=ncont_sent(ii)
6585         iproc=itask_cont_to(ii)
6586         write (iout,*) nn," contacts to processor",iproc,
6587      &   " of CONT_TO_COMM group"
6588         do i=1,nn
6589           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6590         enddo
6591       enddo
6592       call flush(iout)
6593       endif
6594       CorrelType=477
6595       CorrelID=fg_rank+1
6596       CorrelType1=478
6597       CorrelID1=nfgtasks+fg_rank+1
6598       ireq=0
6599 C Receive the numbers of needed contacts from other processors
6600       do ii=1,ntask_cont_from
6601         iproc=itask_cont_from(ii)
6602         ireq=ireq+1
6603         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6604      &    FG_COMM,req(ireq),IERR)
6605       enddo
6606 c      write (iout,*) "IRECV ended"
6607 c      call flush(iout)
6608 C Send the number of contacts needed by other processors
6609       do ii=1,ntask_cont_to
6610         iproc=itask_cont_to(ii)
6611         ireq=ireq+1
6612         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6613      &    FG_COMM,req(ireq),IERR)
6614       enddo
6615 c      write (iout,*) "ISEND ended"
6616 c      write (iout,*) "number of requests (nn)",ireq
6617       call flush(iout)
6618       if (ireq.gt.0)
6619      &  call MPI_Waitall(ireq,req,status_array,ierr)
6620 c      write (iout,*)
6621 c     &  "Numbers of contacts to be received from other processors",
6622 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6623 c      call flush(iout)
6624 C Receive contacts
6625       ireq=0
6626       do ii=1,ntask_cont_from
6627         iproc=itask_cont_from(ii)
6628         nn=ncont_recv(ii)
6629 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6630 c     &   " of CONT_TO_COMM group"
6631         call flush(iout)
6632         if (nn.gt.0) then
6633           ireq=ireq+1
6634           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6635      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6636 c          write (iout,*) "ireq,req",ireq,req(ireq)
6637         endif
6638       enddo
6639 C Send the contacts to processors that need them
6640       do ii=1,ntask_cont_to
6641         iproc=itask_cont_to(ii)
6642         nn=ncont_sent(ii)
6643 c        write (iout,*) nn," contacts to processor",iproc,
6644 c     &   " of CONT_TO_COMM group"
6645         if (nn.gt.0) then
6646           ireq=ireq+1
6647           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6648      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6649 c          write (iout,*) "ireq,req",ireq,req(ireq)
6650 c          do i=1,nn
6651 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6652 c          enddo
6653         endif
6654       enddo
6655 c      write (iout,*) "number of requests (contacts)",ireq
6656 c      write (iout,*) "req",(req(i),i=1,4)
6657 c      call flush(iout)
6658       if (ireq.gt.0)
6659      & call MPI_Waitall(ireq,req,status_array,ierr)
6660       do iii=1,ntask_cont_from
6661         iproc=itask_cont_from(iii)
6662         nn=ncont_recv(iii)
6663         if (lprn) then
6664         write (iout,*) "Received",nn," contacts from processor",iproc,
6665      &   " of CONT_FROM_COMM group"
6666         call flush(iout)
6667         do i=1,nn
6668           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6669         enddo
6670         call flush(iout)
6671         endif
6672         do i=1,nn
6673           ii=zapas_recv(1,i,iii)
6674 c Flag the received contacts to prevent double-counting
6675           jj=-zapas_recv(2,i,iii)
6676 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6677 c          call flush(iout)
6678           nnn=num_cont_hb(ii)+1
6679           num_cont_hb(ii)=nnn
6680           jcont_hb(nnn,ii)=jj
6681           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6682           ind=3
6683           do kk=1,3
6684             ind=ind+1
6685             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6686           enddo
6687           do kk=1,2
6688             do ll=1,2
6689               ind=ind+1
6690               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6691             enddo
6692           enddo
6693           do jj=1,5
6694             do kk=1,3
6695               do ll=1,2
6696                 do mm=1,2
6697                   ind=ind+1
6698                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6699                 enddo
6700               enddo
6701             enddo
6702           enddo
6703         enddo
6704       enddo
6705       call flush(iout)
6706       if (lprn) then
6707         write (iout,'(a)') 'Contact function values after receive:'
6708         do i=nnt,nct-2
6709           write (iout,'(2i3,50(1x,i3,5f6.3))')
6710      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6711      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6712         enddo
6713         call flush(iout)
6714       endif
6715    30 continue
6716 #endif
6717       if (lprn) then
6718         write (iout,'(a)') 'Contact function values:'
6719         do i=nnt,nct-2
6720           write (iout,'(2i3,50(1x,i2,5f6.3))')
6721      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6722      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6723         enddo
6724       endif
6725       ecorr=0.0D0
6726       ecorr5=0.0d0
6727       ecorr6=0.0d0
6728 C Remove the loop below after debugging !!!
6729       do i=nnt,nct
6730         do j=1,3
6731           gradcorr(j,i)=0.0D0
6732           gradxorr(j,i)=0.0D0
6733         enddo
6734       enddo
6735 C Calculate the dipole-dipole interaction energies
6736       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6737       do i=iatel_s,iatel_e+1
6738         num_conti=num_cont_hb(i)
6739         do jj=1,num_conti
6740           j=jcont_hb(jj,i)
6741 #ifdef MOMENT
6742           call dipole(i,j,jj)
6743 #endif
6744         enddo
6745       enddo
6746       endif
6747 C Calculate the local-electrostatic correlation terms
6748 c                write (iout,*) "gradcorr5 in eello5 before loop"
6749 c                do iii=1,nres
6750 c                  write (iout,'(i5,3f10.5)')
6751 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6752 c                enddo
6753       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6754 c        write (iout,*) "corr loop i",i
6755         i1=i+1
6756         num_conti=num_cont_hb(i)
6757         num_conti1=num_cont_hb(i+1)
6758         do jj=1,num_conti
6759           j=jcont_hb(jj,i)
6760           jp=iabs(j)
6761           do kk=1,num_conti1
6762             j1=jcont_hb(kk,i1)
6763             jp1=iabs(j1)
6764 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6765 c     &         ' jj=',jj,' kk=',kk
6766 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6767             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6768      &          .or. j.lt.0 .and. j1.gt.0) .and.
6769      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6770 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6771 C The system gains extra energy.
6772               n_corr=n_corr+1
6773               sqd1=dsqrt(d_cont(jj,i))
6774               sqd2=dsqrt(d_cont(kk,i1))
6775               sred_geom = sqd1*sqd2
6776               IF (sred_geom.lt.cutoff_corr) THEN
6777                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6778      &            ekont,fprimcont)
6779 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6780 cd     &         ' jj=',jj,' kk=',kk
6781                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6782                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6783                 do l=1,3
6784                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6785                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6786                 enddo
6787                 n_corr1=n_corr1+1
6788 cd               write (iout,*) 'sred_geom=',sred_geom,
6789 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6790 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6791 cd               write (iout,*) "g_contij",g_contij
6792 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6793 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6794                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6795                 if (wcorr4.gt.0.0d0)
6796      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6797                   if (energy_dec.and.wcorr4.gt.0.0d0)
6798      1                 write (iout,'(a6,4i5,0pf7.3)')
6799      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6800 c                write (iout,*) "gradcorr5 before eello5"
6801 c                do iii=1,nres
6802 c                  write (iout,'(i5,3f10.5)')
6803 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6804 c                enddo
6805                 if (wcorr5.gt.0.0d0)
6806      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6807 c                write (iout,*) "gradcorr5 after eello5"
6808 c                do iii=1,nres
6809 c                  write (iout,'(i5,3f10.5)')
6810 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6811 c                enddo
6812                   if (energy_dec.and.wcorr5.gt.0.0d0)
6813      1                 write (iout,'(a6,4i5,0pf7.3)')
6814      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6815 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6816 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6817                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6818      &               .or. wturn6.eq.0.0d0))then
6819 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6820                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6821                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6822      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6823 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6824 cd     &            'ecorr6=',ecorr6
6825 cd                write (iout,'(4e15.5)') sred_geom,
6826 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6827 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6828 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6829                 else if (wturn6.gt.0.0d0
6830      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6831 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6832                   eturn6=eturn6+eello_turn6(i,jj,kk)
6833                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6834      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6835 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6836                 endif
6837               ENDIF
6838 1111          continue
6839             endif
6840           enddo ! kk
6841         enddo ! jj
6842       enddo ! i
6843       do i=1,nres
6844         num_cont_hb(i)=num_cont_hb_old(i)
6845       enddo
6846 c                write (iout,*) "gradcorr5 in eello5"
6847 c                do iii=1,nres
6848 c                  write (iout,'(i5,3f10.5)')
6849 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6850 c                enddo
6851       return
6852       end
6853 c------------------------------------------------------------------------------
6854       subroutine add_hb_contact_eello(ii,jj,itask)
6855       implicit real*8 (a-h,o-z)
6856       include "DIMENSIONS"
6857       include "COMMON.IOUNITS"
6858       integer max_cont
6859       integer max_dim
6860       parameter (max_cont=maxconts)
6861       parameter (max_dim=70)
6862       include "COMMON.CONTACTS"
6863       double precision zapas(max_dim,maxconts,max_fg_procs),
6864      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6865       common /przechowalnia/ zapas
6866       integer i,j,ii,jj,iproc,itask(4),nn
6867 c      write (iout,*) "itask",itask
6868       do i=1,2
6869         iproc=itask(i)
6870         if (iproc.gt.0) then
6871           do j=1,num_cont_hb(ii)
6872             jjc=jcont_hb(j,ii)
6873 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6874             if (jjc.eq.jj) then
6875               ncont_sent(iproc)=ncont_sent(iproc)+1
6876               nn=ncont_sent(iproc)
6877               zapas(1,nn,iproc)=ii
6878               zapas(2,nn,iproc)=jjc
6879               zapas(3,nn,iproc)=d_cont(j,ii)
6880               ind=3
6881               do kk=1,3
6882                 ind=ind+1
6883                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6884               enddo
6885               do kk=1,2
6886                 do ll=1,2
6887                   ind=ind+1
6888                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6889                 enddo
6890               enddo
6891               do jj=1,5
6892                 do kk=1,3
6893                   do ll=1,2
6894                     do mm=1,2
6895                       ind=ind+1
6896                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6897                     enddo
6898                   enddo
6899                 enddo
6900               enddo
6901               exit
6902             endif
6903           enddo
6904         endif
6905       enddo
6906       return
6907       end
6908 c------------------------------------------------------------------------------
6909       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6910       implicit real*8 (a-h,o-z)
6911       include 'DIMENSIONS'
6912       include 'COMMON.IOUNITS'
6913       include 'COMMON.DERIV'
6914       include 'COMMON.INTERACT'
6915       include 'COMMON.CONTACTS'
6916       double precision gx(3),gx1(3)
6917       logical lprn
6918       lprn=.false.
6919       eij=facont_hb(jj,i)
6920       ekl=facont_hb(kk,k)
6921       ees0pij=ees0p(jj,i)
6922       ees0pkl=ees0p(kk,k)
6923       ees0mij=ees0m(jj,i)
6924       ees0mkl=ees0m(kk,k)
6925       ekont=eij*ekl
6926       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6927 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6928 C Following 4 lines for diagnostics.
6929 cd    ees0pkl=0.0D0
6930 cd    ees0pij=1.0D0
6931 cd    ees0mkl=0.0D0
6932 cd    ees0mij=1.0D0
6933 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6934 c     & 'Contacts ',i,j,
6935 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6936 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6937 c     & 'gradcorr_long'
6938 C Calculate the multi-body contribution to energy.
6939 c      ecorr=ecorr+ekont*ees
6940 C Calculate multi-body contributions to the gradient.
6941       coeffpees0pij=coeffp*ees0pij
6942       coeffmees0mij=coeffm*ees0mij
6943       coeffpees0pkl=coeffp*ees0pkl
6944       coeffmees0mkl=coeffm*ees0mkl
6945       do ll=1,3
6946 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6947         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6948      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6949      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6950         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6951      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6952      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6953 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6954         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6955      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6956      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6957         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6958      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6959      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6960         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6961      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6962      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6963         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6964         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6965         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6966      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6967      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6968         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6969         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6970 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6971       enddo
6972 c      write (iout,*)
6973 cgrad      do m=i+1,j-1
6974 cgrad        do ll=1,3
6975 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6976 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6977 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6978 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6979 cgrad        enddo
6980 cgrad      enddo
6981 cgrad      do m=k+1,l-1
6982 cgrad        do ll=1,3
6983 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6984 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6985 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6986 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6987 cgrad        enddo
6988 cgrad      enddo
6989 c      write (iout,*) "ehbcorr",ekont*ees
6990       ehbcorr=ekont*ees
6991       return
6992       end
6993 #ifdef MOMENT
6994 C---------------------------------------------------------------------------
6995       subroutine dipole(i,j,jj)
6996       implicit real*8 (a-h,o-z)
6997       include 'DIMENSIONS'
6998       include 'COMMON.IOUNITS'
6999       include 'COMMON.CHAIN'
7000       include 'COMMON.FFIELD'
7001       include 'COMMON.DERIV'
7002       include 'COMMON.INTERACT'
7003       include 'COMMON.CONTACTS'
7004       include 'COMMON.TORSION'
7005       include 'COMMON.VAR'
7006       include 'COMMON.GEO'
7007       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7008      &  auxmat(2,2)
7009       iti1 = itortyp(itype(i+1))
7010       if (j.lt.nres-1) then
7011         itj1 = itortyp(itype(j+1))
7012       else
7013         itj1=ntortyp+1
7014       endif
7015       do iii=1,2
7016         dipi(iii,1)=Ub2(iii,i)
7017         dipderi(iii)=Ub2der(iii,i)
7018         dipi(iii,2)=b1(iii,iti1)
7019         dipj(iii,1)=Ub2(iii,j)
7020         dipderj(iii)=Ub2der(iii,j)
7021         dipj(iii,2)=b1(iii,itj1)
7022       enddo
7023       kkk=0
7024       do iii=1,2
7025         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7026         do jjj=1,2
7027           kkk=kkk+1
7028           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7029         enddo
7030       enddo
7031       do kkk=1,5
7032         do lll=1,3
7033           mmm=0
7034           do iii=1,2
7035             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7036      &        auxvec(1))
7037             do jjj=1,2
7038               mmm=mmm+1
7039               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7040             enddo
7041           enddo
7042         enddo
7043       enddo
7044       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7045       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7046       do iii=1,2
7047         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7048       enddo
7049       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7050       do iii=1,2
7051         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7052       enddo
7053       return
7054       end
7055 #endif
7056 C---------------------------------------------------------------------------
7057       subroutine calc_eello(i,j,k,l,jj,kk)
7058 C
7059 C This subroutine computes matrices and vectors needed to calculate
7060 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7061 C
7062       implicit real*8 (a-h,o-z)
7063       include 'DIMENSIONS'
7064       include 'COMMON.IOUNITS'
7065       include 'COMMON.CHAIN'
7066       include 'COMMON.DERIV'
7067       include 'COMMON.INTERACT'
7068       include 'COMMON.CONTACTS'
7069       include 'COMMON.TORSION'
7070       include 'COMMON.VAR'
7071       include 'COMMON.GEO'
7072       include 'COMMON.FFIELD'
7073       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7074      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7075       logical lprn
7076       common /kutas/ lprn
7077 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7078 cd     & ' jj=',jj,' kk=',kk
7079 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7080 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7081 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7082       do iii=1,2
7083         do jjj=1,2
7084           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7085           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7086         enddo
7087       enddo
7088       call transpose2(aa1(1,1),aa1t(1,1))
7089       call transpose2(aa2(1,1),aa2t(1,1))
7090       do kkk=1,5
7091         do lll=1,3
7092           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7093      &      aa1tder(1,1,lll,kkk))
7094           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7095      &      aa2tder(1,1,lll,kkk))
7096         enddo
7097       enddo
7098       if (l.eq.j+1) then
7099 C parallel orientation of the two CA-CA-CA frames.
7100         if (i.gt.1) then
7101           iti=itortyp(itype(i))
7102         else
7103           iti=ntortyp+1
7104         endif
7105         itk1=itortyp(itype(k+1))
7106         itj=itortyp(itype(j))
7107         if (l.lt.nres-1) then
7108           itl1=itortyp(itype(l+1))
7109         else
7110           itl1=ntortyp+1
7111         endif
7112 C A1 kernel(j+1) A2T
7113 cd        do iii=1,2
7114 cd          write (iout,'(3f10.5,5x,3f10.5)')
7115 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7116 cd        enddo
7117         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7118      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7119      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7120 C Following matrices are needed only for 6-th order cumulants
7121         IF (wcorr6.gt.0.0d0) THEN
7122         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7123      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7124      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7125         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7126      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7127      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7128      &   ADtEAderx(1,1,1,1,1,1))
7129         lprn=.false.
7130         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7131      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7132      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7133      &   ADtEA1derx(1,1,1,1,1,1))
7134         ENDIF
7135 C End 6-th order cumulants
7136 cd        lprn=.false.
7137 cd        if (lprn) then
7138 cd        write (2,*) 'In calc_eello6'
7139 cd        do iii=1,2
7140 cd          write (2,*) 'iii=',iii
7141 cd          do kkk=1,5
7142 cd            write (2,*) 'kkk=',kkk
7143 cd            do jjj=1,2
7144 cd              write (2,'(3(2f10.5),5x)')
7145 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7146 cd            enddo
7147 cd          enddo
7148 cd        enddo
7149 cd        endif
7150         call transpose2(EUgder(1,1,k),auxmat(1,1))
7151         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7152         call transpose2(EUg(1,1,k),auxmat(1,1))
7153         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7154         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7155         do iii=1,2
7156           do kkk=1,5
7157             do lll=1,3
7158               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7159      &          EAEAderx(1,1,lll,kkk,iii,1))
7160             enddo
7161           enddo
7162         enddo
7163 C A1T kernel(i+1) A2
7164         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7165      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7166      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7167 C Following matrices are needed only for 6-th order cumulants
7168         IF (wcorr6.gt.0.0d0) THEN
7169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7170      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7171      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7172         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7173      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7174      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7175      &   ADtEAderx(1,1,1,1,1,2))
7176         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7177      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7178      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7179      &   ADtEA1derx(1,1,1,1,1,2))
7180         ENDIF
7181 C End 6-th order cumulants
7182         call transpose2(EUgder(1,1,l),auxmat(1,1))
7183         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7184         call transpose2(EUg(1,1,l),auxmat(1,1))
7185         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7186         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7187         do iii=1,2
7188           do kkk=1,5
7189             do lll=1,3
7190               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7191      &          EAEAderx(1,1,lll,kkk,iii,2))
7192             enddo
7193           enddo
7194         enddo
7195 C AEAb1 and AEAb2
7196 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7197 C They are needed only when the fifth- or the sixth-order cumulants are
7198 C indluded.
7199         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7200         call transpose2(AEA(1,1,1),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7202         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7203         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7204         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7205         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7206         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7207         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7208         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7209         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7210         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7211         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7212         call transpose2(AEA(1,1,2),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7214         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7215         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7216         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7217         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7218         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7219         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7220         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7221         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7222         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7223         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7224 C Calculate the Cartesian derivatives of the vectors.
7225         do iii=1,2
7226           do kkk=1,5
7227             do lll=1,3
7228               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7229               call matvec2(auxmat(1,1),b1(1,iti),
7230      &          AEAb1derx(1,lll,kkk,iii,1,1))
7231               call matvec2(auxmat(1,1),Ub2(1,i),
7232      &          AEAb2derx(1,lll,kkk,iii,1,1))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7234      &          AEAb1derx(1,lll,kkk,iii,2,1))
7235               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7236      &          AEAb2derx(1,lll,kkk,iii,2,1))
7237               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7238               call matvec2(auxmat(1,1),b1(1,itj),
7239      &          AEAb1derx(1,lll,kkk,iii,1,2))
7240               call matvec2(auxmat(1,1),Ub2(1,j),
7241      &          AEAb2derx(1,lll,kkk,iii,1,2))
7242               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7243      &          AEAb1derx(1,lll,kkk,iii,2,2))
7244               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7245      &          AEAb2derx(1,lll,kkk,iii,2,2))
7246             enddo
7247           enddo
7248         enddo
7249         ENDIF
7250 C End vectors
7251       else
7252 C Antiparallel orientation of the two CA-CA-CA frames.
7253         if (i.gt.1) then
7254           iti=itortyp(itype(i))
7255         else
7256           iti=ntortyp+1
7257         endif
7258         itk1=itortyp(itype(k+1))
7259         itl=itortyp(itype(l))
7260         itj=itortyp(itype(j))
7261         if (j.lt.nres-1) then
7262           itj1=itortyp(itype(j+1))
7263         else
7264           itj1=ntortyp+1
7265         endif
7266 C A2 kernel(j-1)T A1T
7267         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7268      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7269      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7270 C Following matrices are needed only for 6-th order cumulants
7271         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7272      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7273         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7274      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7275      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7276         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7277      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7278      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7279      &   ADtEAderx(1,1,1,1,1,1))
7280         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7281      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7282      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7283      &   ADtEA1derx(1,1,1,1,1,1))
7284         ENDIF
7285 C End 6-th order cumulants
7286         call transpose2(EUgder(1,1,k),auxmat(1,1))
7287         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7288         call transpose2(EUg(1,1,k),auxmat(1,1))
7289         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7290         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7291         do iii=1,2
7292           do kkk=1,5
7293             do lll=1,3
7294               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7295      &          EAEAderx(1,1,lll,kkk,iii,1))
7296             enddo
7297           enddo
7298         enddo
7299 C A2T kernel(i+1)T A1
7300         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7301      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7302      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7303 C Following matrices are needed only for 6-th order cumulants
7304         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7305      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7307      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7308      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7309         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7310      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7311      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7312      &   ADtEAderx(1,1,1,1,1,2))
7313         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7314      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7315      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7316      &   ADtEA1derx(1,1,1,1,1,2))
7317         ENDIF
7318 C End 6-th order cumulants
7319         call transpose2(EUgder(1,1,j),auxmat(1,1))
7320         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7321         call transpose2(EUg(1,1,j),auxmat(1,1))
7322         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7323         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7324         do iii=1,2
7325           do kkk=1,5
7326             do lll=1,3
7327               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7328      &          EAEAderx(1,1,lll,kkk,iii,2))
7329             enddo
7330           enddo
7331         enddo
7332 C AEAb1 and AEAb2
7333 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7334 C They are needed only when the fifth- or the sixth-order cumulants are
7335 C indluded.
7336         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7337      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7338         call transpose2(AEA(1,1,1),auxmat(1,1))
7339         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7340         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7341         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7342         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7343         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7344         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7345         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7346         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7347         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7348         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7349         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7350         call transpose2(AEA(1,1,2),auxmat(1,1))
7351         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7352         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7353         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7354         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7355         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7356         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7357         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7358         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7359         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7360         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7361         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7362 C Calculate the Cartesian derivatives of the vectors.
7363         do iii=1,2
7364           do kkk=1,5
7365             do lll=1,3
7366               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7367               call matvec2(auxmat(1,1),b1(1,iti),
7368      &          AEAb1derx(1,lll,kkk,iii,1,1))
7369               call matvec2(auxmat(1,1),Ub2(1,i),
7370      &          AEAb2derx(1,lll,kkk,iii,1,1))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7372      &          AEAb1derx(1,lll,kkk,iii,2,1))
7373               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7374      &          AEAb2derx(1,lll,kkk,iii,2,1))
7375               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7376               call matvec2(auxmat(1,1),b1(1,itl),
7377      &          AEAb1derx(1,lll,kkk,iii,1,2))
7378               call matvec2(auxmat(1,1),Ub2(1,l),
7379      &          AEAb2derx(1,lll,kkk,iii,1,2))
7380               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7381      &          AEAb1derx(1,lll,kkk,iii,2,2))
7382               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7383      &          AEAb2derx(1,lll,kkk,iii,2,2))
7384             enddo
7385           enddo
7386         enddo
7387         ENDIF
7388 C End vectors
7389       endif
7390       return
7391       end
7392 C---------------------------------------------------------------------------
7393       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7394      &  KK,KKderg,AKA,AKAderg,AKAderx)
7395       implicit none
7396       integer nderg
7397       logical transp
7398       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7399      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7400      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7401       integer iii,kkk,lll
7402       integer jjj,mmm
7403       logical lprn
7404       common /kutas/ lprn
7405       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7406       do iii=1,nderg
7407         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7408      &    AKAderg(1,1,iii))
7409       enddo
7410 cd      if (lprn) write (2,*) 'In kernel'
7411       do kkk=1,5
7412 cd        if (lprn) write (2,*) 'kkk=',kkk
7413         do lll=1,3
7414           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7415      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7416 cd          if (lprn) then
7417 cd            write (2,*) 'lll=',lll
7418 cd            write (2,*) 'iii=1'
7419 cd            do jjj=1,2
7420 cd              write (2,'(3(2f10.5),5x)')
7421 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7422 cd            enddo
7423 cd          endif
7424           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7425      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7426 cd          if (lprn) then
7427 cd            write (2,*) 'lll=',lll
7428 cd            write (2,*) 'iii=2'
7429 cd            do jjj=1,2
7430 cd              write (2,'(3(2f10.5),5x)')
7431 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7432 cd            enddo
7433 cd          endif
7434         enddo
7435       enddo
7436       return
7437       end
7438 C---------------------------------------------------------------------------
7439       double precision function eello4(i,j,k,l,jj,kk)
7440       implicit real*8 (a-h,o-z)
7441       include 'DIMENSIONS'
7442       include 'COMMON.IOUNITS'
7443       include 'COMMON.CHAIN'
7444       include 'COMMON.DERIV'
7445       include 'COMMON.INTERACT'
7446       include 'COMMON.CONTACTS'
7447       include 'COMMON.TORSION'
7448       include 'COMMON.VAR'
7449       include 'COMMON.GEO'
7450       double precision pizda(2,2),ggg1(3),ggg2(3)
7451 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7452 cd        eello4=0.0d0
7453 cd        return
7454 cd      endif
7455 cd      print *,'eello4:',i,j,k,l,jj,kk
7456 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7457 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7458 cold      eij=facont_hb(jj,i)
7459 cold      ekl=facont_hb(kk,k)
7460 cold      ekont=eij*ekl
7461       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7462 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7463       gcorr_loc(k-1)=gcorr_loc(k-1)
7464      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7465       if (l.eq.j+1) then
7466         gcorr_loc(l-1)=gcorr_loc(l-1)
7467      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7468       else
7469         gcorr_loc(j-1)=gcorr_loc(j-1)
7470      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7471       endif
7472       do iii=1,2
7473         do kkk=1,5
7474           do lll=1,3
7475             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7476      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7477 cd            derx(lll,kkk,iii)=0.0d0
7478           enddo
7479         enddo
7480       enddo
7481 cd      gcorr_loc(l-1)=0.0d0
7482 cd      gcorr_loc(j-1)=0.0d0
7483 cd      gcorr_loc(k-1)=0.0d0
7484 cd      eel4=1.0d0
7485 cd      write (iout,*)'Contacts have occurred for peptide groups',
7486 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7487 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7488       if (j.lt.nres-1) then
7489         j1=j+1
7490         j2=j-1
7491       else
7492         j1=j-1
7493         j2=j-2
7494       endif
7495       if (l.lt.nres-1) then
7496         l1=l+1
7497         l2=l-1
7498       else
7499         l1=l-1
7500         l2=l-2
7501       endif
7502       do ll=1,3
7503 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7504 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7505         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7506         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7507 cgrad        ghalf=0.5d0*ggg1(ll)
7508         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7509         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7510         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7511         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7512         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7513         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7514 cgrad        ghalf=0.5d0*ggg2(ll)
7515         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7516         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7517         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7518         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7519         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7520         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7521       enddo
7522 cgrad      do m=i+1,j-1
7523 cgrad        do ll=1,3
7524 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7525 cgrad        enddo
7526 cgrad      enddo
7527 cgrad      do m=k+1,l-1
7528 cgrad        do ll=1,3
7529 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7530 cgrad        enddo
7531 cgrad      enddo
7532 cgrad      do m=i+2,j2
7533 cgrad        do ll=1,3
7534 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7535 cgrad        enddo
7536 cgrad      enddo
7537 cgrad      do m=k+2,l2
7538 cgrad        do ll=1,3
7539 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7540 cgrad        enddo
7541 cgrad      enddo
7542 cd      do iii=1,nres-3
7543 cd        write (2,*) iii,gcorr_loc(iii)
7544 cd      enddo
7545       eello4=ekont*eel4
7546 cd      write (2,*) 'ekont',ekont
7547 cd      write (iout,*) 'eello4',ekont*eel4
7548       return
7549       end
7550 C---------------------------------------------------------------------------
7551       double precision function eello5(i,j,k,l,jj,kk)
7552       implicit real*8 (a-h,o-z)
7553       include 'DIMENSIONS'
7554       include 'COMMON.IOUNITS'
7555       include 'COMMON.CHAIN'
7556       include 'COMMON.DERIV'
7557       include 'COMMON.INTERACT'
7558       include 'COMMON.CONTACTS'
7559       include 'COMMON.TORSION'
7560       include 'COMMON.VAR'
7561       include 'COMMON.GEO'
7562       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7563       double precision ggg1(3),ggg2(3)
7564 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7565 C                                                                              C
7566 C                            Parallel chains                                   C
7567 C                                                                              C
7568 C          o             o                   o             o                   C
7569 C         /l\           / \             \   / \           / \   /              C
7570 C        /   \         /   \             \ /   \         /   \ /               C
7571 C       j| o |l1       | o |              o| o |         | o |o                C
7572 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7573 C      \i/   \         /   \ /             /   \         /   \                 C
7574 C       o    k1             o                                                  C
7575 C         (I)          (II)                (III)          (IV)                 C
7576 C                                                                              C
7577 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7578 C                                                                              C
7579 C                            Antiparallel chains                               C
7580 C                                                                              C
7581 C          o             o                   o             o                   C
7582 C         /j\           / \             \   / \           / \   /              C
7583 C        /   \         /   \             \ /   \         /   \ /               C
7584 C      j1| o |l        | o |              o| o |         | o |o                C
7585 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7586 C      \i/   \         /   \ /             /   \         /   \                 C
7587 C       o     k1            o                                                  C
7588 C         (I)          (II)                (III)          (IV)                 C
7589 C                                                                              C
7590 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7591 C                                                                              C
7592 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7593 C                                                                              C
7594 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7595 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7596 cd        eello5=0.0d0
7597 cd        return
7598 cd      endif
7599 cd      write (iout,*)
7600 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7601 cd     &   ' and',k,l
7602       itk=itortyp(itype(k))
7603       itl=itortyp(itype(l))
7604       itj=itortyp(itype(j))
7605       eello5_1=0.0d0
7606       eello5_2=0.0d0
7607       eello5_3=0.0d0
7608       eello5_4=0.0d0
7609 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7610 cd     &   eel5_3_num,eel5_4_num)
7611       do iii=1,2
7612         do kkk=1,5
7613           do lll=1,3
7614             derx(lll,kkk,iii)=0.0d0
7615           enddo
7616         enddo
7617       enddo
7618 cd      eij=facont_hb(jj,i)
7619 cd      ekl=facont_hb(kk,k)
7620 cd      ekont=eij*ekl
7621 cd      write (iout,*)'Contacts have occurred for peptide groups',
7622 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7623 cd      goto 1111
7624 C Contribution from the graph I.
7625 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7626 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7627       call transpose2(EUg(1,1,k),auxmat(1,1))
7628       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7629       vv(1)=pizda(1,1)-pizda(2,2)
7630       vv(2)=pizda(1,2)+pizda(2,1)
7631       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7632      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7633 C Explicit gradient in virtual-dihedral angles.
7634       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7635      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7636      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7637       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7638       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7639       vv(1)=pizda(1,1)-pizda(2,2)
7640       vv(2)=pizda(1,2)+pizda(2,1)
7641       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7642      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7643      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7644       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7645       vv(1)=pizda(1,1)-pizda(2,2)
7646       vv(2)=pizda(1,2)+pizda(2,1)
7647       if (l.eq.j+1) then
7648         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7649      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7651       else
7652         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7653      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7654      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7655       endif
7656 C Cartesian gradient
7657       do iii=1,2
7658         do kkk=1,5
7659           do lll=1,3
7660             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7661      &        pizda(1,1))
7662             vv(1)=pizda(1,1)-pizda(2,2)
7663             vv(2)=pizda(1,2)+pizda(2,1)
7664             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7665      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7666      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7667           enddo
7668         enddo
7669       enddo
7670 c      goto 1112
7671 c1111  continue
7672 C Contribution from graph II
7673       call transpose2(EE(1,1,itk),auxmat(1,1))
7674       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7675       vv(1)=pizda(1,1)+pizda(2,2)
7676       vv(2)=pizda(2,1)-pizda(1,2)
7677       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7678      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7679 C Explicit gradient in virtual-dihedral angles.
7680       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7681      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7682       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7683       vv(1)=pizda(1,1)+pizda(2,2)
7684       vv(2)=pizda(2,1)-pizda(1,2)
7685       if (l.eq.j+1) then
7686         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7687      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7688      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7689       else
7690         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7691      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7692      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7693       endif
7694 C Cartesian gradient
7695       do iii=1,2
7696         do kkk=1,5
7697           do lll=1,3
7698             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7699      &        pizda(1,1))
7700             vv(1)=pizda(1,1)+pizda(2,2)
7701             vv(2)=pizda(2,1)-pizda(1,2)
7702             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7703      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7704      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7705           enddo
7706         enddo
7707       enddo
7708 cd      goto 1112
7709 cd1111  continue
7710       if (l.eq.j+1) then
7711 cd        goto 1110
7712 C Parallel orientation
7713 C Contribution from graph III
7714         call transpose2(EUg(1,1,l),auxmat(1,1))
7715         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7716         vv(1)=pizda(1,1)-pizda(2,2)
7717         vv(2)=pizda(1,2)+pizda(2,1)
7718         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7720 C Explicit gradient in virtual-dihedral angles.
7721         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7722      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7723      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7724         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7725         vv(1)=pizda(1,1)-pizda(2,2)
7726         vv(2)=pizda(1,2)+pizda(2,1)
7727         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7728      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7730         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7731         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7732         vv(1)=pizda(1,1)-pizda(2,2)
7733         vv(2)=pizda(1,2)+pizda(2,1)
7734         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7735      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7736      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7737 C Cartesian gradient
7738         do iii=1,2
7739           do kkk=1,5
7740             do lll=1,3
7741               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7742      &          pizda(1,1))
7743               vv(1)=pizda(1,1)-pizda(2,2)
7744               vv(2)=pizda(1,2)+pizda(2,1)
7745               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7746      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7747      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7748             enddo
7749           enddo
7750         enddo
7751 cd        goto 1112
7752 C Contribution from graph IV
7753 cd1110    continue
7754         call transpose2(EE(1,1,itl),auxmat(1,1))
7755         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7756         vv(1)=pizda(1,1)+pizda(2,2)
7757         vv(2)=pizda(2,1)-pizda(1,2)
7758         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7759      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7760 C Explicit gradient in virtual-dihedral angles.
7761         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7762      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7763         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7764         vv(1)=pizda(1,1)+pizda(2,2)
7765         vv(2)=pizda(2,1)-pizda(1,2)
7766         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7767      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7768      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7769 C Cartesian gradient
7770         do iii=1,2
7771           do kkk=1,5
7772             do lll=1,3
7773               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7774      &          pizda(1,1))
7775               vv(1)=pizda(1,1)+pizda(2,2)
7776               vv(2)=pizda(2,1)-pizda(1,2)
7777               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7778      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7779      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7780             enddo
7781           enddo
7782         enddo
7783       else
7784 C Antiparallel orientation
7785 C Contribution from graph III
7786 c        goto 1110
7787         call transpose2(EUg(1,1,j),auxmat(1,1))
7788         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7789         vv(1)=pizda(1,1)-pizda(2,2)
7790         vv(2)=pizda(1,2)+pizda(2,1)
7791         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7792      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7793 C Explicit gradient in virtual-dihedral angles.
7794         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7795      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7796      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7797         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7798         vv(1)=pizda(1,1)-pizda(2,2)
7799         vv(2)=pizda(1,2)+pizda(2,1)
7800         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7801      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7802      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7803         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7804         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7805         vv(1)=pizda(1,1)-pizda(2,2)
7806         vv(2)=pizda(1,2)+pizda(2,1)
7807         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7808      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7809      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7810 C Cartesian gradient
7811         do iii=1,2
7812           do kkk=1,5
7813             do lll=1,3
7814               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7815      &          pizda(1,1))
7816               vv(1)=pizda(1,1)-pizda(2,2)
7817               vv(2)=pizda(1,2)+pizda(2,1)
7818               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7819      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7820      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7821             enddo
7822           enddo
7823         enddo
7824 cd        goto 1112
7825 C Contribution from graph IV
7826 1110    continue
7827         call transpose2(EE(1,1,itj),auxmat(1,1))
7828         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7829         vv(1)=pizda(1,1)+pizda(2,2)
7830         vv(2)=pizda(2,1)-pizda(1,2)
7831         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7832      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7833 C Explicit gradient in virtual-dihedral angles.
7834         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7835      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7836         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7837         vv(1)=pizda(1,1)+pizda(2,2)
7838         vv(2)=pizda(2,1)-pizda(1,2)
7839         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7840      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7841      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7842 C Cartesian gradient
7843         do iii=1,2
7844           do kkk=1,5
7845             do lll=1,3
7846               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7847      &          pizda(1,1))
7848               vv(1)=pizda(1,1)+pizda(2,2)
7849               vv(2)=pizda(2,1)-pizda(1,2)
7850               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7851      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7852      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7853             enddo
7854           enddo
7855         enddo
7856       endif
7857 1112  continue
7858       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7859 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7860 cd        write (2,*) 'ijkl',i,j,k,l
7861 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7862 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7863 cd      endif
7864 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7865 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7866 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7867 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7868       if (j.lt.nres-1) then
7869         j1=j+1
7870         j2=j-1
7871       else
7872         j1=j-1
7873         j2=j-2
7874       endif
7875       if (l.lt.nres-1) then
7876         l1=l+1
7877         l2=l-1
7878       else
7879         l1=l-1
7880         l2=l-2
7881       endif
7882 cd      eij=1.0d0
7883 cd      ekl=1.0d0
7884 cd      ekont=1.0d0
7885 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7886 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7887 C        summed up outside the subrouine as for the other subroutines
7888 C        handling long-range interactions. The old code is commented out
7889 C        with "cgrad" to keep track of changes.
7890       do ll=1,3
7891 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7892 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7893         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7894         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7895 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7896 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7897 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7898 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7899 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7900 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7901 c     &   gradcorr5ij,
7902 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7903 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7904 cgrad        ghalf=0.5d0*ggg1(ll)
7905 cd        ghalf=0.0d0
7906         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7907         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7908         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7909         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7910         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7911         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7912 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7913 cgrad        ghalf=0.5d0*ggg2(ll)
7914 cd        ghalf=0.0d0
7915         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7916         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7917         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7918         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7919         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7920         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7921       enddo
7922 cd      goto 1112
7923 cgrad      do m=i+1,j-1
7924 cgrad        do ll=1,3
7925 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7926 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7927 cgrad        enddo
7928 cgrad      enddo
7929 cgrad      do m=k+1,l-1
7930 cgrad        do ll=1,3
7931 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7932 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7933 cgrad        enddo
7934 cgrad      enddo
7935 c1112  continue
7936 cgrad      do m=i+2,j2
7937 cgrad        do ll=1,3
7938 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7939 cgrad        enddo
7940 cgrad      enddo
7941 cgrad      do m=k+2,l2
7942 cgrad        do ll=1,3
7943 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7944 cgrad        enddo
7945 cgrad      enddo
7946 cd      do iii=1,nres-3
7947 cd        write (2,*) iii,g_corr5_loc(iii)
7948 cd      enddo
7949       eello5=ekont*eel5
7950 cd      write (2,*) 'ekont',ekont
7951 cd      write (iout,*) 'eello5',ekont*eel5
7952       return
7953       end
7954 c--------------------------------------------------------------------------
7955       double precision function eello6(i,j,k,l,jj,kk)
7956       implicit real*8 (a-h,o-z)
7957       include 'DIMENSIONS'
7958       include 'COMMON.IOUNITS'
7959       include 'COMMON.CHAIN'
7960       include 'COMMON.DERIV'
7961       include 'COMMON.INTERACT'
7962       include 'COMMON.CONTACTS'
7963       include 'COMMON.TORSION'
7964       include 'COMMON.VAR'
7965       include 'COMMON.GEO'
7966       include 'COMMON.FFIELD'
7967       double precision ggg1(3),ggg2(3)
7968 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7969 cd        eello6=0.0d0
7970 cd        return
7971 cd      endif
7972 cd      write (iout,*)
7973 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7974 cd     &   ' and',k,l
7975       eello6_1=0.0d0
7976       eello6_2=0.0d0
7977       eello6_3=0.0d0
7978       eello6_4=0.0d0
7979       eello6_5=0.0d0
7980       eello6_6=0.0d0
7981 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7982 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7983       do iii=1,2
7984         do kkk=1,5
7985           do lll=1,3
7986             derx(lll,kkk,iii)=0.0d0
7987           enddo
7988         enddo
7989       enddo
7990 cd      eij=facont_hb(jj,i)
7991 cd      ekl=facont_hb(kk,k)
7992 cd      ekont=eij*ekl
7993 cd      eij=1.0d0
7994 cd      ekl=1.0d0
7995 cd      ekont=1.0d0
7996       if (l.eq.j+1) then
7997         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7998         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7999         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8000         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8001         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8002         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8003       else
8004         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8005         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8006         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8007         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8008         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8009           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8010         else
8011           eello6_5=0.0d0
8012         endif
8013         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8014       endif
8015 C If turn contributions are considered, they will be handled separately.
8016       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8017 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8018 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8019 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8020 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8021 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8022 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8023 cd      goto 1112
8024       if (j.lt.nres-1) then
8025         j1=j+1
8026         j2=j-1
8027       else
8028         j1=j-1
8029         j2=j-2
8030       endif
8031       if (l.lt.nres-1) then
8032         l1=l+1
8033         l2=l-1
8034       else
8035         l1=l-1
8036         l2=l-2
8037       endif
8038       do ll=1,3
8039 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8040 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8041 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8042 cgrad        ghalf=0.5d0*ggg1(ll)
8043 cd        ghalf=0.0d0
8044         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8045         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8046         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8047         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8048         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8049         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8050         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8051         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8052 cgrad        ghalf=0.5d0*ggg2(ll)
8053 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8054 cd        ghalf=0.0d0
8055         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8056         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8057         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8058         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8059         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8060         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8061       enddo
8062 cd      goto 1112
8063 cgrad      do m=i+1,j-1
8064 cgrad        do ll=1,3
8065 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8066 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8067 cgrad        enddo
8068 cgrad      enddo
8069 cgrad      do m=k+1,l-1
8070 cgrad        do ll=1,3
8071 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8072 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8073 cgrad        enddo
8074 cgrad      enddo
8075 cgrad1112  continue
8076 cgrad      do m=i+2,j2
8077 cgrad        do ll=1,3
8078 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8079 cgrad        enddo
8080 cgrad      enddo
8081 cgrad      do m=k+2,l2
8082 cgrad        do ll=1,3
8083 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8084 cgrad        enddo
8085 cgrad      enddo
8086 cd      do iii=1,nres-3
8087 cd        write (2,*) iii,g_corr6_loc(iii)
8088 cd      enddo
8089       eello6=ekont*eel6
8090 cd      write (2,*) 'ekont',ekont
8091 cd      write (iout,*) 'eello6',ekont*eel6
8092       return
8093       end
8094 c--------------------------------------------------------------------------
8095       double precision function eello6_graph1(i,j,k,l,imat,swap)
8096       implicit real*8 (a-h,o-z)
8097       include 'DIMENSIONS'
8098       include 'COMMON.IOUNITS'
8099       include 'COMMON.CHAIN'
8100       include 'COMMON.DERIV'
8101       include 'COMMON.INTERACT'
8102       include 'COMMON.CONTACTS'
8103       include 'COMMON.TORSION'
8104       include 'COMMON.VAR'
8105       include 'COMMON.GEO'
8106       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8107       logical swap
8108       logical lprn
8109       common /kutas/ lprn
8110 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8111 C                                                                              C
8112 C      Parallel       Antiparallel                                             C
8113 C                                                                              C
8114 C          o             o                                                     C
8115 C         /l\           /j\                                                    C
8116 C        /   \         /   \                                                   C
8117 C       /| o |         | o |\                                                  C
8118 C     \ j|/k\|  /   \  |/k\|l /                                                C
8119 C      \ /   \ /     \ /   \ /                                                 C
8120 C       o     o       o     o                                                  C
8121 C       i             i                                                        C
8122 C                                                                              C
8123 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8124       itk=itortyp(itype(k))
8125       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8126       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8127       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8128       call transpose2(EUgC(1,1,k),auxmat(1,1))
8129       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8130       vv1(1)=pizda1(1,1)-pizda1(2,2)
8131       vv1(2)=pizda1(1,2)+pizda1(2,1)
8132       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8133       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8134       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8135       s5=scalar2(vv(1),Dtobr2(1,i))
8136 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8137       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8138       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8139      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8140      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8141      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8142      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8143      & +scalar2(vv(1),Dtobr2der(1,i)))
8144       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8145       vv1(1)=pizda1(1,1)-pizda1(2,2)
8146       vv1(2)=pizda1(1,2)+pizda1(2,1)
8147       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8148       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8149       if (l.eq.j+1) then
8150         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8151      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8152      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8153      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8154      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8155       else
8156         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8157      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8158      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8159      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8160      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8161       endif
8162       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8163       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8164       vv1(1)=pizda1(1,1)-pizda1(2,2)
8165       vv1(2)=pizda1(1,2)+pizda1(2,1)
8166       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8167      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8168      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8169      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8170       do iii=1,2
8171         if (swap) then
8172           ind=3-iii
8173         else
8174           ind=iii
8175         endif
8176         do kkk=1,5
8177           do lll=1,3
8178             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8179             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8180             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8181             call transpose2(EUgC(1,1,k),auxmat(1,1))
8182             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8183      &        pizda1(1,1))
8184             vv1(1)=pizda1(1,1)-pizda1(2,2)
8185             vv1(2)=pizda1(1,2)+pizda1(2,1)
8186             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8187             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8188      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8189             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8190      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8191             s5=scalar2(vv(1),Dtobr2(1,i))
8192             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8193           enddo
8194         enddo
8195       enddo
8196       return
8197       end
8198 c----------------------------------------------------------------------------
8199       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8200       implicit real*8 (a-h,o-z)
8201       include 'DIMENSIONS'
8202       include 'COMMON.IOUNITS'
8203       include 'COMMON.CHAIN'
8204       include 'COMMON.DERIV'
8205       include 'COMMON.INTERACT'
8206       include 'COMMON.CONTACTS'
8207       include 'COMMON.TORSION'
8208       include 'COMMON.VAR'
8209       include 'COMMON.GEO'
8210       logical swap
8211       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8212      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8213       logical lprn
8214       common /kutas/ lprn
8215 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8216 C                                                                              C
8217 C      Parallel       Antiparallel                                             C
8218 C                                                                              C
8219 C          o             o                                                     C
8220 C     \   /l\           /j\   /                                                C
8221 C      \ /   \         /   \ /                                                 C
8222 C       o| o |         | o |o                                                  C
8223 C     \ j|/k\|      \  |/k\|l                                                  C
8224 C      \ /   \       \ /   \                                                   C
8225 C       o             o                                                        C
8226 C       i             i                                                        C
8227 C                                                                              C
8228 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8229 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8230 C AL 7/4/01 s1 would occur in the sixth-order moment,
8231 C           but not in a cluster cumulant
8232 #ifdef MOMENT
8233       s1=dip(1,jj,i)*dip(1,kk,k)
8234 #endif
8235       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8236       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8237       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8238       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8239       call transpose2(EUg(1,1,k),auxmat(1,1))
8240       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8241       vv(1)=pizda(1,1)-pizda(2,2)
8242       vv(2)=pizda(1,2)+pizda(2,1)
8243       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8244 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8245 #ifdef MOMENT
8246       eello6_graph2=-(s1+s2+s3+s4)
8247 #else
8248       eello6_graph2=-(s2+s3+s4)
8249 #endif
8250 c      eello6_graph2=-s3
8251 C Derivatives in gamma(i-1)
8252       if (i.gt.1) then
8253 #ifdef MOMENT
8254         s1=dipderg(1,jj,i)*dip(1,kk,k)
8255 #endif
8256         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8257         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8258         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8259         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8260 #ifdef MOMENT
8261         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8262 #else
8263         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8264 #endif
8265 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8266       endif
8267 C Derivatives in gamma(k-1)
8268 #ifdef MOMENT
8269       s1=dip(1,jj,i)*dipderg(1,kk,k)
8270 #endif
8271       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8272       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8273       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8274       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8275       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8276       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8277       vv(1)=pizda(1,1)-pizda(2,2)
8278       vv(2)=pizda(1,2)+pizda(2,1)
8279       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8280 #ifdef MOMENT
8281       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8282 #else
8283       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8284 #endif
8285 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8286 C Derivatives in gamma(j-1) or gamma(l-1)
8287       if (j.gt.1) then
8288 #ifdef MOMENT
8289         s1=dipderg(3,jj,i)*dip(1,kk,k)
8290 #endif
8291         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8292         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8293         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8294         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8295         vv(1)=pizda(1,1)-pizda(2,2)
8296         vv(2)=pizda(1,2)+pizda(2,1)
8297         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8298 #ifdef MOMENT
8299         if (swap) then
8300           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8301         else
8302           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8303         endif
8304 #endif
8305         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8306 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8307       endif
8308 C Derivatives in gamma(l-1) or gamma(j-1)
8309       if (l.gt.1) then
8310 #ifdef MOMENT
8311         s1=dip(1,jj,i)*dipderg(3,kk,k)
8312 #endif
8313         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8314         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8315         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8316         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8317         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8318         vv(1)=pizda(1,1)-pizda(2,2)
8319         vv(2)=pizda(1,2)+pizda(2,1)
8320         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8321 #ifdef MOMENT
8322         if (swap) then
8323           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8324         else
8325           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8326         endif
8327 #endif
8328         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8329 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8330       endif
8331 C Cartesian derivatives.
8332       if (lprn) then
8333         write (2,*) 'In eello6_graph2'
8334         do iii=1,2
8335           write (2,*) 'iii=',iii
8336           do kkk=1,5
8337             write (2,*) 'kkk=',kkk
8338             do jjj=1,2
8339               write (2,'(3(2f10.5),5x)')
8340      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8341             enddo
8342           enddo
8343         enddo
8344       endif
8345       do iii=1,2
8346         do kkk=1,5
8347           do lll=1,3
8348 #ifdef MOMENT
8349             if (iii.eq.1) then
8350               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8351             else
8352               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8353             endif
8354 #endif
8355             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8356      &        auxvec(1))
8357             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8358             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8359      &        auxvec(1))
8360             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8361             call transpose2(EUg(1,1,k),auxmat(1,1))
8362             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8363      &        pizda(1,1))
8364             vv(1)=pizda(1,1)-pizda(2,2)
8365             vv(2)=pizda(1,2)+pizda(2,1)
8366             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8367 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8368 #ifdef MOMENT
8369             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8370 #else
8371             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8372 #endif
8373             if (swap) then
8374               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8375             else
8376               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8377             endif
8378           enddo
8379         enddo
8380       enddo
8381       return
8382       end
8383 c----------------------------------------------------------------------------
8384       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8385       implicit real*8 (a-h,o-z)
8386       include 'DIMENSIONS'
8387       include 'COMMON.IOUNITS'
8388       include 'COMMON.CHAIN'
8389       include 'COMMON.DERIV'
8390       include 'COMMON.INTERACT'
8391       include 'COMMON.CONTACTS'
8392       include 'COMMON.TORSION'
8393       include 'COMMON.VAR'
8394       include 'COMMON.GEO'
8395       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8396       logical swap
8397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8398 C                                                                              C
8399 C      Parallel       Antiparallel                                             C
8400 C                                                                              C
8401 C          o             o                                                     C
8402 C         /l\   /   \   /j\                                                    C
8403 C        /   \ /     \ /   \                                                   C
8404 C       /| o |o       o| o |\                                                  C
8405 C       j|/k\|  /      |/k\|l /                                                C
8406 C        /   \ /       /   \ /                                                 C
8407 C       /     o       /     o                                                  C
8408 C       i             i                                                        C
8409 C                                                                              C
8410 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8411 C
8412 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8413 C           energy moment and not to the cluster cumulant.
8414       iti=itortyp(itype(i))
8415       if (j.lt.nres-1) then
8416         itj1=itortyp(itype(j+1))
8417       else
8418         itj1=ntortyp+1
8419       endif
8420       itk=itortyp(itype(k))
8421       itk1=itortyp(itype(k+1))
8422       if (l.lt.nres-1) then
8423         itl1=itortyp(itype(l+1))
8424       else
8425         itl1=ntortyp+1
8426       endif
8427 #ifdef MOMENT
8428       s1=dip(4,jj,i)*dip(4,kk,k)
8429 #endif
8430       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8431       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8432       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8433       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8434       call transpose2(EE(1,1,itk),auxmat(1,1))
8435       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8436       vv(1)=pizda(1,1)+pizda(2,2)
8437       vv(2)=pizda(2,1)-pizda(1,2)
8438       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8439 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8440 cd     & "sum",-(s2+s3+s4)
8441 #ifdef MOMENT
8442       eello6_graph3=-(s1+s2+s3+s4)
8443 #else
8444       eello6_graph3=-(s2+s3+s4)
8445 #endif
8446 c      eello6_graph3=-s4
8447 C Derivatives in gamma(k-1)
8448       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8449       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8450       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8451       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8452 C Derivatives in gamma(l-1)
8453       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8454       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8455       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8456       vv(1)=pizda(1,1)+pizda(2,2)
8457       vv(2)=pizda(2,1)-pizda(1,2)
8458       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8459       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8460 C Cartesian derivatives.
8461       do iii=1,2
8462         do kkk=1,5
8463           do lll=1,3
8464 #ifdef MOMENT
8465             if (iii.eq.1) then
8466               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8467             else
8468               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8469             endif
8470 #endif
8471             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8472      &        auxvec(1))
8473             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8474             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8475      &        auxvec(1))
8476             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8477             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8478      &        pizda(1,1))
8479             vv(1)=pizda(1,1)+pizda(2,2)
8480             vv(2)=pizda(2,1)-pizda(1,2)
8481             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8482 #ifdef MOMENT
8483             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8484 #else
8485             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8486 #endif
8487             if (swap) then
8488               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8489             else
8490               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8491             endif
8492 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8493           enddo
8494         enddo
8495       enddo
8496       return
8497       end
8498 c----------------------------------------------------------------------------
8499       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8500       implicit real*8 (a-h,o-z)
8501       include 'DIMENSIONS'
8502       include 'COMMON.IOUNITS'
8503       include 'COMMON.CHAIN'
8504       include 'COMMON.DERIV'
8505       include 'COMMON.INTERACT'
8506       include 'COMMON.CONTACTS'
8507       include 'COMMON.TORSION'
8508       include 'COMMON.VAR'
8509       include 'COMMON.GEO'
8510       include 'COMMON.FFIELD'
8511       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8512      & auxvec1(2),auxmat1(2,2)
8513       logical swap
8514 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8515 C                                                                              C
8516 C      Parallel       Antiparallel                                             C
8517 C                                                                              C
8518 C          o             o                                                     C
8519 C         /l\   /   \   /j\                                                    C
8520 C        /   \ /     \ /   \                                                   C
8521 C       /| o |o       o| o |\                                                  C
8522 C     \ j|/k\|      \  |/k\|l                                                  C
8523 C      \ /   \       \ /   \                                                   C
8524 C       o     \       o     \                                                  C
8525 C       i             i                                                        C
8526 C                                                                              C
8527 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8528 C
8529 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8530 C           energy moment and not to the cluster cumulant.
8531 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8532       iti=itortyp(itype(i))
8533       itj=itortyp(itype(j))
8534       if (j.lt.nres-1) then
8535         itj1=itortyp(itype(j+1))
8536       else
8537         itj1=ntortyp+1
8538       endif
8539       itk=itortyp(itype(k))
8540       if (k.lt.nres-1) then
8541         itk1=itortyp(itype(k+1))
8542       else
8543         itk1=ntortyp+1
8544       endif
8545       itl=itortyp(itype(l))
8546       if (l.lt.nres-1) then
8547         itl1=itortyp(itype(l+1))
8548       else
8549         itl1=ntortyp+1
8550       endif
8551 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8552 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8553 cd     & ' itl',itl,' itl1',itl1
8554 #ifdef MOMENT
8555       if (imat.eq.1) then
8556         s1=dip(3,jj,i)*dip(3,kk,k)
8557       else
8558         s1=dip(2,jj,j)*dip(2,kk,l)
8559       endif
8560 #endif
8561       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8562       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8563       if (j.eq.l+1) then
8564         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8566       else
8567         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8568         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8569       endif
8570       call transpose2(EUg(1,1,k),auxmat(1,1))
8571       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8572       vv(1)=pizda(1,1)-pizda(2,2)
8573       vv(2)=pizda(2,1)+pizda(1,2)
8574       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8575 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8576 #ifdef MOMENT
8577       eello6_graph4=-(s1+s2+s3+s4)
8578 #else
8579       eello6_graph4=-(s2+s3+s4)
8580 #endif
8581 C Derivatives in gamma(i-1)
8582       if (i.gt.1) then
8583 #ifdef MOMENT
8584         if (imat.eq.1) then
8585           s1=dipderg(2,jj,i)*dip(3,kk,k)
8586         else
8587           s1=dipderg(4,jj,j)*dip(2,kk,l)
8588         endif
8589 #endif
8590         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8591         if (j.eq.l+1) then
8592           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8593           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8594         else
8595           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8596           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8597         endif
8598         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8599         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8600 cd          write (2,*) 'turn6 derivatives'
8601 #ifdef MOMENT
8602           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8603 #else
8604           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8605 #endif
8606         else
8607 #ifdef MOMENT
8608           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8609 #else
8610           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8611 #endif
8612         endif
8613       endif
8614 C Derivatives in gamma(k-1)
8615 #ifdef MOMENT
8616       if (imat.eq.1) then
8617         s1=dip(3,jj,i)*dipderg(2,kk,k)
8618       else
8619         s1=dip(2,jj,j)*dipderg(4,kk,l)
8620       endif
8621 #endif
8622       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8623       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8624       if (j.eq.l+1) then
8625         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8626         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8627       else
8628         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8629         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8630       endif
8631       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8632       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8633       vv(1)=pizda(1,1)-pizda(2,2)
8634       vv(2)=pizda(2,1)+pizda(1,2)
8635       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8636       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8637 #ifdef MOMENT
8638         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8639 #else
8640         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8641 #endif
8642       else
8643 #ifdef MOMENT
8644         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8647 #endif
8648       endif
8649 C Derivatives in gamma(j-1) or gamma(l-1)
8650       if (l.eq.j+1 .and. l.gt.1) then
8651         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8652         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8653         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8654         vv(1)=pizda(1,1)-pizda(2,2)
8655         vv(2)=pizda(2,1)+pizda(1,2)
8656         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8657         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8658       else if (j.gt.1) then
8659         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8660         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8661         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8662         vv(1)=pizda(1,1)-pizda(2,2)
8663         vv(2)=pizda(2,1)+pizda(1,2)
8664         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8665         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8666           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8667         else
8668           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8669         endif
8670       endif
8671 C Cartesian derivatives.
8672       do iii=1,2
8673         do kkk=1,5
8674           do lll=1,3
8675 #ifdef MOMENT
8676             if (iii.eq.1) then
8677               if (imat.eq.1) then
8678                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8679               else
8680                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8681               endif
8682             else
8683               if (imat.eq.1) then
8684                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8685               else
8686                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8687               endif
8688             endif
8689 #endif
8690             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8691      &        auxvec(1))
8692             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8693             if (j.eq.l+1) then
8694               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8695      &          b1(1,itj1),auxvec(1))
8696               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8697             else
8698               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8699      &          b1(1,itl1),auxvec(1))
8700               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8701             endif
8702             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8703      &        pizda(1,1))
8704             vv(1)=pizda(1,1)-pizda(2,2)
8705             vv(2)=pizda(2,1)+pizda(1,2)
8706             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8707             if (swap) then
8708               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8709 #ifdef MOMENT
8710                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8711      &             -(s1+s2+s4)
8712 #else
8713                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8714      &             -(s2+s4)
8715 #endif
8716                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8717               else
8718 #ifdef MOMENT
8719                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8720 #else
8721                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8722 #endif
8723                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8724               endif
8725             else
8726 #ifdef MOMENT
8727               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8728 #else
8729               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8730 #endif
8731               if (l.eq.j+1) then
8732                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8733               else
8734                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8735               endif
8736             endif
8737           enddo
8738         enddo
8739       enddo
8740       return
8741       end
8742 c----------------------------------------------------------------------------
8743       double precision function eello_turn6(i,jj,kk)
8744       implicit real*8 (a-h,o-z)
8745       include 'DIMENSIONS'
8746       include 'COMMON.IOUNITS'
8747       include 'COMMON.CHAIN'
8748       include 'COMMON.DERIV'
8749       include 'COMMON.INTERACT'
8750       include 'COMMON.CONTACTS'
8751       include 'COMMON.TORSION'
8752       include 'COMMON.VAR'
8753       include 'COMMON.GEO'
8754       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8755      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8756      &  ggg1(3),ggg2(3)
8757       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8758      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8759 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8760 C           the respective energy moment and not to the cluster cumulant.
8761       s1=0.0d0
8762       s8=0.0d0
8763       s13=0.0d0
8764 c
8765       eello_turn6=0.0d0
8766       j=i+4
8767       k=i+1
8768       l=i+3
8769       iti=itortyp(itype(i))
8770       itk=itortyp(itype(k))
8771       itk1=itortyp(itype(k+1))
8772       itl=itortyp(itype(l))
8773       itj=itortyp(itype(j))
8774 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8775 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8776 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8777 cd        eello6=0.0d0
8778 cd        return
8779 cd      endif
8780 cd      write (iout,*)
8781 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8782 cd     &   ' and',k,l
8783 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8784       do iii=1,2
8785         do kkk=1,5
8786           do lll=1,3
8787             derx_turn(lll,kkk,iii)=0.0d0
8788           enddo
8789         enddo
8790       enddo
8791 cd      eij=1.0d0
8792 cd      ekl=1.0d0
8793 cd      ekont=1.0d0
8794       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8795 cd      eello6_5=0.0d0
8796 cd      write (2,*) 'eello6_5',eello6_5
8797 #ifdef MOMENT
8798       call transpose2(AEA(1,1,1),auxmat(1,1))
8799       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8800       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8801       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8802 #endif
8803       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8804       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8805       s2 = scalar2(b1(1,itk),vtemp1(1))
8806 #ifdef MOMENT
8807       call transpose2(AEA(1,1,2),atemp(1,1))
8808       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8809       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8810       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8811 #endif
8812       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8813       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8814       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8815 #ifdef MOMENT
8816       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8817       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8818       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8819       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8820       ss13 = scalar2(b1(1,itk),vtemp4(1))
8821       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8822 #endif
8823 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8824 c      s1=0.0d0
8825 c      s2=0.0d0
8826 c      s8=0.0d0
8827 c      s12=0.0d0
8828 c      s13=0.0d0
8829       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8830 C Derivatives in gamma(i+2)
8831       s1d =0.0d0
8832       s8d =0.0d0
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,1),auxmatd(1,1))
8835       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8836       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8837       call transpose2(AEAderg(1,1,2),atempd(1,1))
8838       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8839       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8840 #endif
8841       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8842       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8843       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8844 c      s1d=0.0d0
8845 c      s2d=0.0d0
8846 c      s8d=0.0d0
8847 c      s12d=0.0d0
8848 c      s13d=0.0d0
8849       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8850 C Derivatives in gamma(i+3)
8851 #ifdef MOMENT
8852       call transpose2(AEA(1,1,1),auxmatd(1,1))
8853       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8854       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8855       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8856 #endif
8857       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8858       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8859       s2d = scalar2(b1(1,itk),vtemp1d(1))
8860 #ifdef MOMENT
8861       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8862       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8863 #endif
8864       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8865 #ifdef MOMENT
8866       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8867       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8868       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8869 #endif
8870 c      s1d=0.0d0
8871 c      s2d=0.0d0
8872 c      s8d=0.0d0
8873 c      s12d=0.0d0
8874 c      s13d=0.0d0
8875 #ifdef MOMENT
8876       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8877      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8878 #else
8879       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8880      &               -0.5d0*ekont*(s2d+s12d)
8881 #endif
8882 C Derivatives in gamma(i+4)
8883       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8884       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8885       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8886 #ifdef MOMENT
8887       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8888       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8889       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8890 #endif
8891 c      s1d=0.0d0
8892 c      s2d=0.0d0
8893 c      s8d=0.0d0
8894 C      s12d=0.0d0
8895 c      s13d=0.0d0
8896 #ifdef MOMENT
8897       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8898 #else
8899       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8900 #endif
8901 C Derivatives in gamma(i+5)
8902 #ifdef MOMENT
8903       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8904       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8905       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8906 #endif
8907       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8908       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8909       s2d = scalar2(b1(1,itk),vtemp1d(1))
8910 #ifdef MOMENT
8911       call transpose2(AEA(1,1,2),atempd(1,1))
8912       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8913       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8914 #endif
8915       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8916       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8917 #ifdef MOMENT
8918       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8919       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8920       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8921 #endif
8922 c      s1d=0.0d0
8923 c      s2d=0.0d0
8924 c      s8d=0.0d0
8925 c      s12d=0.0d0
8926 c      s13d=0.0d0
8927 #ifdef MOMENT
8928       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8929      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8930 #else
8931       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8932      &               -0.5d0*ekont*(s2d+s12d)
8933 #endif
8934 C Cartesian derivatives
8935       do iii=1,2
8936         do kkk=1,5
8937           do lll=1,3
8938 #ifdef MOMENT
8939             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8940             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8941             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8942 #endif
8943             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8944             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8945      &          vtemp1d(1))
8946             s2d = scalar2(b1(1,itk),vtemp1d(1))
8947 #ifdef MOMENT
8948             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8949             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8950             s8d = -(atempd(1,1)+atempd(2,2))*
8951      &           scalar2(cc(1,1,itl),vtemp2(1))
8952 #endif
8953             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8954      &           auxmatd(1,1))
8955             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8956             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8957 c      s1d=0.0d0
8958 c      s2d=0.0d0
8959 c      s8d=0.0d0
8960 c      s12d=0.0d0
8961 c      s13d=0.0d0
8962 #ifdef MOMENT
8963             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8964      &        - 0.5d0*(s1d+s2d)
8965 #else
8966             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8967      &        - 0.5d0*s2d
8968 #endif
8969 #ifdef MOMENT
8970             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8971      &        - 0.5d0*(s8d+s12d)
8972 #else
8973             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8974      &        - 0.5d0*s12d
8975 #endif
8976           enddo
8977         enddo
8978       enddo
8979 #ifdef MOMENT
8980       do kkk=1,5
8981         do lll=1,3
8982           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8983      &      achuj_tempd(1,1))
8984           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8985           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8986           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8987           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8988           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8989      &      vtemp4d(1))
8990           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8991           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8992           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8993         enddo
8994       enddo
8995 #endif
8996 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8997 cd     &  16*eel_turn6_num
8998 cd      goto 1112
8999       if (j.lt.nres-1) then
9000         j1=j+1
9001         j2=j-1
9002       else
9003         j1=j-1
9004         j2=j-2
9005       endif
9006       if (l.lt.nres-1) then
9007         l1=l+1
9008         l2=l-1
9009       else
9010         l1=l-1
9011         l2=l-2
9012       endif
9013       do ll=1,3
9014 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9015 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9016 cgrad        ghalf=0.5d0*ggg1(ll)
9017 cd        ghalf=0.0d0
9018         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9019         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9020         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9021      &    +ekont*derx_turn(ll,2,1)
9022         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9023         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9024      &    +ekont*derx_turn(ll,4,1)
9025         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9026         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9027         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9028 cgrad        ghalf=0.5d0*ggg2(ll)
9029 cd        ghalf=0.0d0
9030         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9031      &    +ekont*derx_turn(ll,2,2)
9032         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9033         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9034      &    +ekont*derx_turn(ll,4,2)
9035         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9036         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9037         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9038       enddo
9039 cd      goto 1112
9040 cgrad      do m=i+1,j-1
9041 cgrad        do ll=1,3
9042 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9043 cgrad        enddo
9044 cgrad      enddo
9045 cgrad      do m=k+1,l-1
9046 cgrad        do ll=1,3
9047 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9048 cgrad        enddo
9049 cgrad      enddo
9050 cgrad1112  continue
9051 cgrad      do m=i+2,j2
9052 cgrad        do ll=1,3
9053 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9054 cgrad        enddo
9055 cgrad      enddo
9056 cgrad      do m=k+2,l2
9057 cgrad        do ll=1,3
9058 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9059 cgrad        enddo
9060 cgrad      enddo
9061 cd      do iii=1,nres-3
9062 cd        write (2,*) iii,g_corr6_loc(iii)
9063 cd      enddo
9064       eello_turn6=ekont*eel_turn6
9065 cd      write (2,*) 'ekont',ekont
9066 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9067       return
9068       end
9069
9070 C-----------------------------------------------------------------------------
9071       double precision function scalar(u,v)
9072 !DIR$ INLINEALWAYS scalar
9073 #ifndef OSF
9074 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9075 #endif
9076       implicit none
9077       double precision u(3),v(3)
9078 cd      double precision sc
9079 cd      integer i
9080 cd      sc=0.0d0
9081 cd      do i=1,3
9082 cd        sc=sc+u(i)*v(i)
9083 cd      enddo
9084 cd      scalar=sc
9085
9086       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9087       return
9088       end
9089 crc-------------------------------------------------
9090       SUBROUTINE MATVEC2(A1,V1,V2)
9091 !DIR$ INLINEALWAYS MATVEC2
9092 #ifndef OSF
9093 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9094 #endif
9095       implicit real*8 (a-h,o-z)
9096       include 'DIMENSIONS'
9097       DIMENSION A1(2,2),V1(2),V2(2)
9098 c      DO 1 I=1,2
9099 c        VI=0.0
9100 c        DO 3 K=1,2
9101 c    3     VI=VI+A1(I,K)*V1(K)
9102 c        Vaux(I)=VI
9103 c    1 CONTINUE
9104
9105       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9106       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9107
9108       v2(1)=vaux1
9109       v2(2)=vaux2
9110       END
9111 C---------------------------------------
9112       SUBROUTINE MATMAT2(A1,A2,A3)
9113 #ifndef OSF
9114 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9115 #endif
9116       implicit real*8 (a-h,o-z)
9117       include 'DIMENSIONS'
9118       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9119 c      DIMENSION AI3(2,2)
9120 c        DO  J=1,2
9121 c          A3IJ=0.0
9122 c          DO K=1,2
9123 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9124 c          enddo
9125 c          A3(I,J)=A3IJ
9126 c       enddo
9127 c      enddo
9128
9129       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9130       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9131       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9132       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9133
9134       A3(1,1)=AI3_11
9135       A3(2,1)=AI3_21
9136       A3(1,2)=AI3_12
9137       A3(2,2)=AI3_22
9138       END
9139
9140 c-------------------------------------------------------------------------
9141       double precision function scalar2(u,v)
9142 !DIR$ INLINEALWAYS scalar2
9143       implicit none
9144       double precision u(2),v(2)
9145       double precision sc
9146       integer i
9147       scalar2=u(1)*v(1)+u(2)*v(2)
9148       return
9149       end
9150
9151 C-----------------------------------------------------------------------------
9152
9153       subroutine transpose2(a,at)
9154 !DIR$ INLINEALWAYS transpose2
9155 #ifndef OSF
9156 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9157 #endif
9158       implicit none
9159       double precision a(2,2),at(2,2)
9160       at(1,1)=a(1,1)
9161       at(1,2)=a(2,1)
9162       at(2,1)=a(1,2)
9163       at(2,2)=a(2,2)
9164       return
9165       end
9166 c--------------------------------------------------------------------------
9167       subroutine transpose(n,a,at)
9168       implicit none
9169       integer n,i,j
9170       double precision a(n,n),at(n,n)
9171       do i=1,n
9172         do j=1,n
9173           at(j,i)=a(i,j)
9174         enddo
9175       enddo
9176       return
9177       end
9178 C---------------------------------------------------------------------------
9179       subroutine prodmat3(a1,a2,kk,transp,prod)
9180 !DIR$ INLINEALWAYS prodmat3
9181 #ifndef OSF
9182 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9183 #endif
9184       implicit none
9185       integer i,j
9186       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9187       logical transp
9188 crc      double precision auxmat(2,2),prod_(2,2)
9189
9190       if (transp) then
9191 crc        call transpose2(kk(1,1),auxmat(1,1))
9192 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9193 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9194
9195            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9196      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9197            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9198      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9199            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9200      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9201            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9202      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9203
9204       else
9205 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9206 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9207
9208            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9209      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9210            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9211      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9212            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9213      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9214            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9215      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9216
9217       endif
9218 c      call transpose2(a2(1,1),a2t(1,1))
9219
9220 crc      print *,transp
9221 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9222 crc      print *,((prod(i,j),i=1,2),j=1,2)
9223
9224       return
9225       end
9226