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       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=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    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445 #endif
 446       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 447      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,ebr*nss,
 982      &  Uconst,etot
 983    10 format (/'Virtual-chain energies:'//
 984      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 985      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 986      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 987      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #else
1008       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1009      &  estr,wbond,ebe,wang,
1010      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1011      &  ecorr,wcorr,
1012      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1013      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1014      &  ebr*nss,Uconst,etot
1015    10 format (/'Virtual-chain energies:'//
1016      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1017      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1018      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1019      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1020      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1021      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1022      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1023      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1024      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1025      & ' (SS bridges & dist. cnstr.)'/
1026      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1030      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1031      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1032      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1033      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1034      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1035      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1036      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1037      & 'ETOT=  ',1pE16.6,' (total)')
1038 #endif
1039       return
1040       end
1041 C-----------------------------------------------------------------------
1042       subroutine elj(evdw)
1043 C
1044 C This subroutine calculates the interaction energy of nonbonded side chains
1045 C assuming the LJ potential of interaction.
1046 C
1047       implicit real*8 (a-h,o-z)
1048       include 'DIMENSIONS'
1049       parameter (accur=1.0d-10)
1050       include 'COMMON.GEO'
1051       include 'COMMON.VAR'
1052       include 'COMMON.LOCAL'
1053       include 'COMMON.CHAIN'
1054       include 'COMMON.DERIV'
1055       include 'COMMON.INTERACT'
1056       include 'COMMON.TORSION'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.NAMES'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.CONTACTS'
1061       dimension gg(3)
1062 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1063       evdw=0.0D0
1064       do i=iatsc_s,iatsc_e
1065         itypi=iabs(itype(i))
1066         if (itypi.eq.ntyp1) cycle
1067         itypi1=iabs(itype(i+1))
1068         xi=c(1,nres+i)
1069         yi=c(2,nres+i)
1070         zi=c(3,nres+i)
1071 C Change 12/1/95
1072         num_conti=0
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1078 cd   &                  'iend=',iend(i,iint)
1079           do j=istart(i,iint),iend(i,iint)
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             xj=c(1,nres+j)-xi
1083             yj=c(2,nres+j)-yi
1084             zj=c(3,nres+j)-zi
1085 C Change 12/1/95 to calculate four-body interactions
1086             rij=xj*xj+yj*yj+zj*zj
1087             rrij=1.0D0/rij
1088 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1089             eps0ij=eps(itypi,itypj)
1090             fac=rrij**expon2
1091             e1=fac*fac*aa(itypi,itypj)
1092             e2=fac*bb(itypi,itypj)
1093             evdwij=e1+e2
1094 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1097 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1098 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1099 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1100             evdw=evdw+evdwij
1101 C
1102 C Calculate the components of the gradient in DC and X
1103 C
1104             fac=-rrij*(e1+evdwij)
1105             gg(1)=xj*fac
1106             gg(2)=yj*fac
1107             gg(3)=zj*fac
1108             do k=1,3
1109               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1110               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1111               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1112               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1113             enddo
1114 cgrad            do k=i,j-1
1115 cgrad              do l=1,3
1116 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1117 cgrad              enddo
1118 cgrad            enddo
1119 C
1120 C 12/1/95, revised on 5/20/97
1121 C
1122 C Calculate the contact function. The ith column of the array JCONT will
1123 C contain the numbers of atoms that make contacts with the atom I (of numbers
1124 C greater than I). The arrays FACONT and GACONT will contain the values of
1125 C the contact function and its derivative.
1126 C
1127 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1128 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1129 C Uncomment next line, if the correlation interactions are contact function only
1130             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1131               rij=dsqrt(rij)
1132               sigij=sigma(itypi,itypj)
1133               r0ij=rs0(itypi,itypj)
1134 C
1135 C Check whether the SC's are not too far to make a contact.
1136 C
1137               rcut=1.5d0*r0ij
1138               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1139 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1140 C
1141               if (fcont.gt.0.0D0) then
1142 C If the SC-SC distance if close to sigma, apply spline.
1143 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1144 cAdam &             fcont1,fprimcont1)
1145 cAdam           fcont1=1.0d0-fcont1
1146 cAdam           if (fcont1.gt.0.0d0) then
1147 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1148 cAdam             fcont=fcont*fcont1
1149 cAdam           endif
1150 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1151 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1152 cga             do k=1,3
1153 cga               gg(k)=gg(k)*eps0ij
1154 cga             enddo
1155 cga             eps0ij=-evdwij*eps0ij
1156 C Uncomment for AL's type of SC correlation interactions.
1157 cadam           eps0ij=-evdwij
1158                 num_conti=num_conti+1
1159                 jcont(num_conti,i)=j
1160                 facont(num_conti,i)=fcont*eps0ij
1161                 fprimcont=eps0ij*fprimcont/rij
1162                 fcont=expon*fcont
1163 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1164 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1165 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1166 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1167                 gacont(1,num_conti,i)=-fprimcont*xj
1168                 gacont(2,num_conti,i)=-fprimcont*yj
1169                 gacont(3,num_conti,i)=-fprimcont*zj
1170 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1171 cd              write (iout,'(2i3,3f10.5)')
1172 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1173               endif
1174             endif
1175           enddo      ! j
1176         enddo        ! iint
1177 C Change 12/1/95
1178         num_cont(i)=num_conti
1179       enddo          ! i
1180       do i=1,nct
1181         do j=1,3
1182           gvdwc(j,i)=expon*gvdwc(j,i)
1183           gvdwx(j,i)=expon*gvdwx(j,i)
1184         enddo
1185       enddo
1186 C******************************************************************************
1187 C
1188 C                              N O T E !!!
1189 C
1190 C To save time, the factor of EXPON has been extracted from ALL components
1191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1192 C use!
1193 C
1194 C******************************************************************************
1195       return
1196       end
1197 C-----------------------------------------------------------------------------
1198       subroutine eljk(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJK potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       include 'COMMON.GEO'
1206       include 'COMMON.VAR'
1207       include 'COMMON.LOCAL'
1208       include 'COMMON.CHAIN'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       include 'COMMON.IOUNITS'
1212       include 'COMMON.NAMES'
1213       dimension gg(3)
1214       logical scheck
1215 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1216       evdw=0.0D0
1217       do i=iatsc_s,iatsc_e
1218         itypi=iabs(itype(i))
1219         if (itypi.eq.ntyp1) cycle
1220         itypi1=iabs(itype(i+1))
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224 C
1225 C Calculate SC interaction energy.
1226 C
1227         do iint=1,nint_gr(i)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             fac_augm=rrij**expon
1236             e_augm=augm(itypi,itypj)*fac_augm
1237             r_inv_ij=dsqrt(rrij)
1238             rij=1.0D0/r_inv_ij
1239             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1240             fac=r_shift_inv**expon
1241             e1=fac*fac*aa(itypi,itypj)
1242             e2=fac*bb(itypi,itypj)
1243             evdwij=e_augm+e1+e2
1244 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1245 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1246 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1247 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1248 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1249 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1250 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1251             evdw=evdw+evdwij
1252 C
1253 C Calculate the components of the gradient in DC and X
1254 C
1255             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1256             gg(1)=xj*fac
1257             gg(2)=yj*fac
1258             gg(3)=zj*fac
1259             do k=1,3
1260               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1261               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1262               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1263               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1264             enddo
1265 cgrad            do k=i,j-1
1266 cgrad              do l=1,3
1267 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1268 cgrad              enddo
1269 cgrad            enddo
1270           enddo      ! j
1271         enddo        ! iint
1272       enddo          ! i
1273       do i=1,nct
1274         do j=1,3
1275           gvdwc(j,i)=expon*gvdwc(j,i)
1276           gvdwx(j,i)=expon*gvdwx(j,i)
1277         enddo
1278       enddo
1279       return
1280       end
1281 C-----------------------------------------------------------------------------
1282       subroutine ebp(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the Berne-Pechukas potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       include 'COMMON.GEO'
1290       include 'COMMON.VAR'
1291       include 'COMMON.LOCAL'
1292       include 'COMMON.CHAIN'
1293       include 'COMMON.DERIV'
1294       include 'COMMON.NAMES'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.CALC'
1298       common /srutu/ icall
1299 c     double precision rrsave(maxdim)
1300       logical lprn
1301       evdw=0.0D0
1302 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304 c     if (icall.eq.0) then
1305 c       lprn=.true.
1306 c     else
1307         lprn=.false.
1308 c     endif
1309       ind=0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317         dxi=dc_norm(1,nres+i)
1318         dyi=dc_norm(2,nres+i)
1319         dzi=dc_norm(3,nres+i)
1320 c        dsci_inv=dsc_inv(itypi)
1321         dsci_inv=vbld_inv(i+nres)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             ind=ind+1
1328             itypj=iabs(itype(j))
1329             if (itypj.eq.ntyp1) cycle
1330 c            dscj_inv=dsc_inv(itypj)
1331             dscj_inv=vbld_inv(j+nres)
1332             chi1=chi(itypi,itypj)
1333             chi2=chi(itypj,itypi)
1334             chi12=chi1*chi2
1335             chip1=chip(itypi)
1336             chip2=chip(itypj)
1337             chip12=chip1*chip2
1338             alf1=alp(itypi)
1339             alf2=alp(itypj)
1340             alf12=0.5D0*(alf1+alf2)
1341 C For diagnostics only!!!
1342 c           chi1=0.0D0
1343 c           chi2=0.0D0
1344 c           chi12=0.0D0
1345 c           chip1=0.0D0
1346 c           chip2=0.0D0
1347 c           chip12=0.0D0
1348 c           alf1=0.0D0
1349 c           alf2=0.0D0
1350 c           alf12=0.0D0
1351             xj=c(1,nres+j)-xi
1352             yj=c(2,nres+j)-yi
1353             zj=c(3,nres+j)-zi
1354             dxj=dc_norm(1,nres+j)
1355             dyj=dc_norm(2,nres+j)
1356             dzj=dc_norm(3,nres+j)
1357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1358 cd          if (icall.eq.0) then
1359 cd            rrsave(ind)=rrij
1360 cd          else
1361 cd            rrij=rrsave(ind)
1362 cd          endif
1363             rij=dsqrt(rrij)
1364 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1365             call sc_angular
1366 C Calculate whole angle-dependent part of epsilon and contributions
1367 C to its derivatives
1368             fac=(rrij*sigsq)**expon2
1369             e1=fac*fac*aa(itypi,itypj)
1370             e2=fac*bb(itypi,itypj)
1371             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1372             eps2der=evdwij*eps3rt
1373             eps3der=evdwij*eps2rt
1374             evdwij=evdwij*eps2rt*eps3rt
1375             evdw=evdw+evdwij
1376             if (lprn) then
1377             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1378             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1379 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1380 cd     &        restyp(itypi),i,restyp(itypj),j,
1381 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1382 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1383 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1384 cd     &        evdwij
1385             endif
1386 C Calculate gradient components.
1387             e1=e1*eps1*eps2rt**2*eps3rt**2
1388             fac=-expon*(e1+evdwij)
1389             sigder=fac/sigsq
1390             fac=rrij*fac
1391 C Calculate radial part of the gradient
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395 C Calculate the angular part of the gradient and sum add the contributions
1396 C to the appropriate components of the Cartesian gradient.
1397             call sc_grad
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401 c     stop
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine egb(evdw)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Gay-Berne potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       include 'COMMON.CONTROL'
1422       include 'COMMON.SPLITELE'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       integer xshift,yshift,zshift
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1434 C we have the original box)
1435 C      do xshift=-1,1
1436 C      do yshift=-1,1
1437 C      do zshift=-1,1
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445 C Return atom into box, boxxsize is size of box in x dimension
1446 c  134   continue
1447 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1448 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1449 C Condition for being inside the proper box
1450 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1451 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1452 c        go to 134
1453 c        endif
1454 c  135   continue
1455 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1456 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1457 C Condition for being inside the proper box
1458 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1459 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1460 c        go to 135
1461 c        endif
1462 c  136   continue
1463 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1464 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1465 C Condition for being inside the proper box
1466 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1467 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1468 c        go to 136
1469 c        endif
1470           xi=mod(xi,boxxsize)
1471           if (xi.lt.0) xi=xi+boxxsize
1472           yi=mod(yi,boxysize)
1473           if (yi.lt.0) yi=yi+boxysize
1474           zi=mod(zi,boxzsize)
1475           if (zi.lt.0) zi=zi+boxzsize
1476 C          xi=xi+xshift*boxxsize
1477 C          yi=yi+yshift*boxysize
1478 C          zi=zi+zshift*boxzsize
1479
1480         dxi=dc_norm(1,nres+i)
1481         dyi=dc_norm(2,nres+i)
1482         dzi=dc_norm(3,nres+i)
1483 c        dsci_inv=dsc_inv(itypi)
1484         dsci_inv=vbld_inv(i+nres)
1485 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1486 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1487 C
1488 C Calculate SC interaction energy.
1489 C
1490         do iint=1,nint_gr(i)
1491           do j=istart(i,iint),iend(i,iint)
1492             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1493               call dyn_ssbond_ene(i,j,evdwij)
1494               evdw=evdw+evdwij
1495               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1496      &                        'evdw',i,j,evdwij,' ss'
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)
1527             yj=c(2,nres+j)
1528             zj=c(3,nres+j)
1529 C Return atom J into box the original box
1530 c  137   continue
1531 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1532 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1533 C Condition for being inside the proper box
1534 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1535 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1536 c        go to 137
1537 c        endif
1538 c  138   continue
1539 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1540 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1541 C Condition for being inside the proper box
1542 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1543 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1544 c        go to 138
1545 c        endif
1546 c  139   continue
1547 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1548 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1549 C Condition for being inside the proper box
1550 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1551 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1552 c        go to 139
1553 c        endif
1554           xj=mod(xj,boxxsize)
1555           if (xj.lt.0) xj=xj+boxxsize
1556           yj=mod(yj,boxysize)
1557           if (yj.lt.0) yj=yj+boxysize
1558           zj=mod(zj,boxzsize)
1559           if (zj.lt.0) zj=zj+boxzsize
1560       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1561       xj_safe=xj
1562       yj_safe=yj
1563       zj_safe=zj
1564       subchap=0
1565       do xshift=-1,1
1566       do yshift=-1,1
1567       do zshift=-1,1
1568           xj=xj_safe+xshift*boxxsize
1569           yj=yj_safe+yshift*boxysize
1570           zj=zj_safe+zshift*boxzsize
1571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572           if(dist_temp.lt.dist_init) then
1573             dist_init=dist_temp
1574             xj_temp=xj
1575             yj_temp=yj
1576             zj_temp=zj
1577             subchap=1
1578           endif
1579        enddo
1580        enddo
1581        enddo
1582        if (subchap.eq.1) then
1583           xj=xj_temp-xi
1584           yj=yj_temp-yi
1585           zj=zj_temp-zi
1586        else
1587           xj=xj_safe-xi
1588           yj=yj_safe-yi
1589           zj=zj_safe-zi
1590        endif
1591             dxj=dc_norm(1,nres+j)
1592             dyj=dc_norm(2,nres+j)
1593             dzj=dc_norm(3,nres+j)
1594 C            xj=xj-xi
1595 C            yj=yj-yi
1596 C            zj=zj-zi
1597 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1598 c            write (iout,*) "j",j," dc_norm",
1599 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1600             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1601             rij=dsqrt(rrij)
1602             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1603             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1604
1605 c            write (iout,'(a7,4f8.3)')
1606 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1607             if (sss.gt.0.0d0) then
1608 C Calculate angle-dependent terms of energy and contributions to their
1609 C derivatives.
1610             call sc_angular
1611             sigsq=1.0D0/sigsq
1612             sig=sig0ij*dsqrt(sigsq)
1613             rij_shift=1.0D0/rij-sig+sig0ij
1614 c for diagnostics; uncomment
1615 c            rij_shift=1.2*sig0ij
1616 C I hate to put IF's in the loops, but here don't have another choice!!!!
1617             if (rij_shift.le.0.0D0) then
1618               evdw=1.0D20
1619 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1620 cd     &        restyp(itypi),i,restyp(itypj),j,
1621 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1622               return
1623             endif
1624             sigder=-sig*sigsq
1625 c---------------------------------------------------------------
1626             rij_shift=1.0D0/rij_shift
1627             fac=rij_shift**expon
1628             e1=fac*fac*aa(itypi,itypj)
1629             e2=fac*bb(itypi,itypj)
1630             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1631             eps2der=evdwij*eps3rt
1632             eps3der=evdwij*eps2rt
1633 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1634 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1635             evdwij=evdwij*eps2rt*eps3rt
1636             evdw=evdw+evdwij*sss
1637             if (lprn) then
1638             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1639             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1640             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1641      &        restyp(itypi),i,restyp(itypj),j,
1642      &        epsi,sigm,chi1,chi2,chip1,chip2,
1643      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1644      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1645      &        evdwij
1646             endif
1647
1648             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1649      &                        'evdw',i,j,evdwij
1650
1651 C Calculate gradient components.
1652             e1=e1*eps1*eps2rt**2*eps3rt**2
1653             fac=-expon*(e1+evdwij)*rij_shift
1654             sigder=fac*sigder
1655             fac=rij*fac
1656 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1657 c     &      evdwij,fac,sigma(itypi,itypj),expon
1658             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1659 c            fac=0.0d0
1660 C Calculate the radial part of the gradient
1661             gg(1)=xj*fac
1662             gg(2)=yj*fac
1663             gg(3)=zj*fac
1664 C Calculate angular part of the gradient.
1665             call sc_grad
1666             endif    ! sss
1667             ENDIF    ! dyn_ss
1668           enddo      ! j
1669         enddo        ! iint
1670       enddo          ! i
1671 C      enddo          ! zshift
1672 C      enddo          ! yshift
1673 C      enddo          ! xshift
1674 c      write (iout,*) "Number of loop steps in EGB:",ind
1675 cccc      energy_dec=.false.
1676       return
1677       end
1678 C-----------------------------------------------------------------------------
1679       subroutine egbv(evdw)
1680 C
1681 C This subroutine calculates the interaction energy of nonbonded side chains
1682 C assuming the Gay-Berne-Vorobjev potential of interaction.
1683 C
1684       implicit real*8 (a-h,o-z)
1685       include 'DIMENSIONS'
1686       include 'COMMON.GEO'
1687       include 'COMMON.VAR'
1688       include 'COMMON.LOCAL'
1689       include 'COMMON.CHAIN'
1690       include 'COMMON.DERIV'
1691       include 'COMMON.NAMES'
1692       include 'COMMON.INTERACT'
1693       include 'COMMON.IOUNITS'
1694       include 'COMMON.CALC'
1695       common /srutu/ icall
1696       logical lprn
1697       evdw=0.0D0
1698 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1699       evdw=0.0D0
1700       lprn=.false.
1701 c     if (icall.eq.0) lprn=.true.
1702       ind=0
1703       do i=iatsc_s,iatsc_e
1704         itypi=iabs(itype(i))
1705         if (itypi.eq.ntyp1) cycle
1706         itypi1=iabs(itype(i+1))
1707         xi=c(1,nres+i)
1708         yi=c(2,nres+i)
1709         zi=c(3,nres+i)
1710         dxi=dc_norm(1,nres+i)
1711         dyi=dc_norm(2,nres+i)
1712         dzi=dc_norm(3,nres+i)
1713 c        dsci_inv=dsc_inv(itypi)
1714         dsci_inv=vbld_inv(i+nres)
1715 C
1716 C Calculate SC interaction energy.
1717 C
1718         do iint=1,nint_gr(i)
1719           do j=istart(i,iint),iend(i,iint)
1720             ind=ind+1
1721             itypj=iabs(itype(j))
1722             if (itypj.eq.ntyp1) cycle
1723 c            dscj_inv=dsc_inv(itypj)
1724             dscj_inv=vbld_inv(j+nres)
1725             sig0ij=sigma(itypi,itypj)
1726             r0ij=r0(itypi,itypj)
1727             chi1=chi(itypi,itypj)
1728             chi2=chi(itypj,itypi)
1729             chi12=chi1*chi2
1730             chip1=chip(itypi)
1731             chip2=chip(itypj)
1732             chip12=chip1*chip2
1733             alf1=alp(itypi)
1734             alf2=alp(itypj)
1735             alf12=0.5D0*(alf1+alf2)
1736 C For diagnostics only!!!
1737 c           chi1=0.0D0
1738 c           chi2=0.0D0
1739 c           chi12=0.0D0
1740 c           chip1=0.0D0
1741 c           chip2=0.0D0
1742 c           chip12=0.0D0
1743 c           alf1=0.0D0
1744 c           alf2=0.0D0
1745 c           alf12=0.0D0
1746             xj=c(1,nres+j)-xi
1747             yj=c(2,nres+j)-yi
1748             zj=c(3,nres+j)-zi
1749             dxj=dc_norm(1,nres+j)
1750             dyj=dc_norm(2,nres+j)
1751             dzj=dc_norm(3,nres+j)
1752             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1753             rij=dsqrt(rrij)
1754 C Calculate angle-dependent terms of energy and contributions to their
1755 C derivatives.
1756             call sc_angular
1757             sigsq=1.0D0/sigsq
1758             sig=sig0ij*dsqrt(sigsq)
1759             rij_shift=1.0D0/rij-sig+r0ij
1760 C I hate to put IF's in the loops, but here don't have another choice!!!!
1761             if (rij_shift.le.0.0D0) then
1762               evdw=1.0D20
1763               return
1764             endif
1765             sigder=-sig*sigsq
1766 c---------------------------------------------------------------
1767             rij_shift=1.0D0/rij_shift
1768             fac=rij_shift**expon
1769             e1=fac*fac*aa(itypi,itypj)
1770             e2=fac*bb(itypi,itypj)
1771             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1772             eps2der=evdwij*eps3rt
1773             eps3der=evdwij*eps2rt
1774             fac_augm=rrij**expon
1775             e_augm=augm(itypi,itypj)*fac_augm
1776             evdwij=evdwij*eps2rt*eps3rt
1777             evdw=evdw+evdwij+e_augm
1778             if (lprn) then
1779             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1780             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1781             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1782      &        restyp(itypi),i,restyp(itypj),j,
1783      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1784      &        chi1,chi2,chip1,chip2,
1785      &        eps1,eps2rt**2,eps3rt**2,
1786      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1787      &        evdwij+e_augm
1788             endif
1789 C Calculate gradient components.
1790             e1=e1*eps1*eps2rt**2*eps3rt**2
1791             fac=-expon*(e1+evdwij)*rij_shift
1792             sigder=fac*sigder
1793             fac=rij*fac-2*expon*rrij*e_augm
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799             call sc_grad
1800           enddo      ! j
1801         enddo        ! iint
1802       enddo          ! i
1803       end
1804 C-----------------------------------------------------------------------------
1805       subroutine sc_angular
1806 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1807 C om12. Called by ebp, egb, and egbv.
1808       implicit none
1809       include 'COMMON.CALC'
1810       include 'COMMON.IOUNITS'
1811       erij(1)=xj*rij
1812       erij(2)=yj*rij
1813       erij(3)=zj*rij
1814       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1815       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1816       om12=dxi*dxj+dyi*dyj+dzi*dzj
1817       chiom12=chi12*om12
1818 C Calculate eps1(om12) and its derivative in om12
1819       faceps1=1.0D0-om12*chiom12
1820       faceps1_inv=1.0D0/faceps1
1821       eps1=dsqrt(faceps1_inv)
1822 C Following variable is eps1*deps1/dom12
1823       eps1_om12=faceps1_inv*chiom12
1824 c diagnostics only
1825 c      faceps1_inv=om12
1826 c      eps1=om12
1827 c      eps1_om12=1.0d0
1828 c      write (iout,*) "om12",om12," eps1",eps1
1829 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1830 C and om12.
1831       om1om2=om1*om2
1832       chiom1=chi1*om1
1833       chiom2=chi2*om2
1834       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1835       sigsq=1.0D0-facsig*faceps1_inv
1836       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1837       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1838       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1839 c diagnostics only
1840 c      sigsq=1.0d0
1841 c      sigsq_om1=0.0d0
1842 c      sigsq_om2=0.0d0
1843 c      sigsq_om12=0.0d0
1844 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1845 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1846 c     &    " eps1",eps1
1847 C Calculate eps2 and its derivatives in om1, om2, and om12.
1848       chipom1=chip1*om1
1849       chipom2=chip2*om2
1850       chipom12=chip12*om12
1851       facp=1.0D0-om12*chipom12
1852       facp_inv=1.0D0/facp
1853       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1854 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1855 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1856 C Following variable is the square root of eps2
1857       eps2rt=1.0D0-facp1*facp_inv
1858 C Following three variables are the derivatives of the square root of eps
1859 C in om1, om2, and om12.
1860       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1861       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1862       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1863 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1864       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1865 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1866 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1867 c     &  " eps2rt_om12",eps2rt_om12
1868 C Calculate whole angle-dependent part of epsilon and contributions
1869 C to its derivatives
1870       return
1871       end
1872 C----------------------------------------------------------------------------
1873       subroutine sc_grad
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CHAIN'
1877       include 'COMMON.DERIV'
1878       include 'COMMON.CALC'
1879       include 'COMMON.IOUNITS'
1880       double precision dcosom1(3),dcosom2(3)
1881 cc      print *,'sss=',sss
1882       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1883       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1884       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1885      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1886 c diagnostics only
1887 c      eom1=0.0d0
1888 c      eom2=0.0d0
1889 c      eom12=evdwij*eps1_om12
1890 c end diagnostics
1891 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1892 c     &  " sigder",sigder
1893 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1894 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1895       do k=1,3
1896         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1897         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1898       enddo
1899       do k=1,3
1900         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1901       enddo
1902 c      write (iout,*) "gg",(gg(k),k=1,3)
1903       do k=1,3
1904         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1905      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1906      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1907         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1908      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1909      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1910 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1911 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1912 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914       enddo
1915 C
1916 C Calculate the components of the gradient in DC and X
1917 C
1918 cgrad      do k=i,j-1
1919 cgrad        do l=1,3
1920 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1921 cgrad        enddo
1922 cgrad      enddo
1923       do l=1,3
1924         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1925         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1926       enddo
1927       return
1928       end
1929 C-----------------------------------------------------------------------
1930       subroutine e_softsphere(evdw)
1931 C
1932 C This subroutine calculates the interaction energy of nonbonded side chains
1933 C assuming the LJ potential of interaction.
1934 C
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937       parameter (accur=1.0d-10)
1938       include 'COMMON.GEO'
1939       include 'COMMON.VAR'
1940       include 'COMMON.LOCAL'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.INTERACT'
1944       include 'COMMON.TORSION'
1945       include 'COMMON.SBRIDGE'
1946       include 'COMMON.NAMES'
1947       include 'COMMON.IOUNITS'
1948       include 'COMMON.CONTACTS'
1949       dimension gg(3)
1950 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1951       evdw=0.0D0
1952       do i=iatsc_s,iatsc_e
1953         itypi=iabs(itype(i))
1954         if (itypi.eq.ntyp1) cycle
1955         itypi1=iabs(itype(i+1))
1956         xi=c(1,nres+i)
1957         yi=c(2,nres+i)
1958         zi=c(3,nres+i)
1959 C
1960 C Calculate SC interaction energy.
1961 C
1962         do iint=1,nint_gr(i)
1963 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1964 cd   &                  'iend=',iend(i,iint)
1965           do j=istart(i,iint),iend(i,iint)
1966             itypj=iabs(itype(j))
1967             if (itypj.eq.ntyp1) cycle
1968             xj=c(1,nres+j)-xi
1969             yj=c(2,nres+j)-yi
1970             zj=c(3,nres+j)-zi
1971             rij=xj*xj+yj*yj+zj*zj
1972 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1973             r0ij=r0(itypi,itypj)
1974             r0ijsq=r0ij*r0ij
1975 c            print *,i,j,r0ij,dsqrt(rij)
1976             if (rij.lt.r0ijsq) then
1977               evdwij=0.25d0*(rij-r0ijsq)**2
1978               fac=rij-r0ijsq
1979             else
1980               evdwij=0.0d0
1981               fac=0.0d0
1982             endif
1983             evdw=evdw+evdwij
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987             gg(1)=xj*fac
1988             gg(2)=yj*fac
1989             gg(3)=zj*fac
1990             do k=1,3
1991               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1992               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1993               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1994               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1995             enddo
1996 cgrad            do k=i,j-1
1997 cgrad              do l=1,3
1998 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1999 cgrad              enddo
2000 cgrad            enddo
2001           enddo ! j
2002         enddo ! iint
2003       enddo ! i
2004       return
2005       end
2006 C--------------------------------------------------------------------------
2007       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2008      &              eello_turn4)
2009 C
2010 C Soft-sphere potential of p-p interaction
2011 C
2012       implicit real*8 (a-h,o-z)
2013       include 'DIMENSIONS'
2014       include 'COMMON.CONTROL'
2015       include 'COMMON.IOUNITS'
2016       include 'COMMON.GEO'
2017       include 'COMMON.VAR'
2018       include 'COMMON.LOCAL'
2019       include 'COMMON.CHAIN'
2020       include 'COMMON.DERIV'
2021       include 'COMMON.INTERACT'
2022       include 'COMMON.CONTACTS'
2023       include 'COMMON.TORSION'
2024       include 'COMMON.VECTORS'
2025       include 'COMMON.FFIELD'
2026       dimension ggg(3)
2027 C      write(iout,*) 'In EELEC_soft_sphere'
2028       ees=0.0D0
2029       evdw1=0.0D0
2030       eel_loc=0.0d0
2031       eello_turn3=0.0d0
2032       eello_turn4=0.0d0
2033       ind=0
2034       do i=iatel_s,iatel_e
2035         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2036         dxi=dc(1,i)
2037         dyi=dc(2,i)
2038         dzi=dc(3,i)
2039         xmedi=c(1,i)+0.5d0*dxi
2040         ymedi=c(2,i)+0.5d0*dyi
2041         zmedi=c(3,i)+0.5d0*dzi
2042           xmedi=mod(xmedi,boxxsize)
2043           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2044           ymedi=mod(ymedi,boxysize)
2045           if (ymedi.lt.0) ymedi=ymedi+boxysize
2046           zmedi=mod(zmedi,boxzsize)
2047           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2048         num_conti=0
2049 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2050         do j=ielstart(i),ielend(i)
2051           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2052           ind=ind+1
2053           iteli=itel(i)
2054           itelj=itel(j)
2055           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2056           r0ij=rpp(iteli,itelj)
2057           r0ijsq=r0ij*r0ij
2058           dxj=dc(1,j)
2059           dyj=dc(2,j)
2060           dzj=dc(3,j)
2061           xj=c(1,j)+0.5D0*dxj
2062           yj=c(2,j)+0.5D0*dyj
2063           zj=c(3,j)+0.5D0*dzj
2064           xj=mod(xj,boxxsize)
2065           if (xj.lt.0) xj=xj+boxxsize
2066           yj=mod(yj,boxysize)
2067           if (yj.lt.0) yj=yj+boxysize
2068           zj=mod(zj,boxzsize)
2069           if (zj.lt.0) zj=zj+boxzsize
2070       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2071       xj_safe=xj
2072       yj_safe=yj
2073       zj_safe=zj
2074       isubchap=0
2075       do xshift=-1,1
2076       do yshift=-1,1
2077       do zshift=-1,1
2078           xj=xj_safe+xshift*boxxsize
2079           yj=yj_safe+yshift*boxysize
2080           zj=zj_safe+zshift*boxzsize
2081           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2082           if(dist_temp.lt.dist_init) then
2083             dist_init=dist_temp
2084             xj_temp=xj
2085             yj_temp=yj
2086             zj_temp=zj
2087             isubchap=1
2088           endif
2089        enddo
2090        enddo
2091        enddo
2092        if (isubchap.eq.1) then
2093           xj=xj_temp-xmedi
2094           yj=yj_temp-ymedi
2095           zj=zj_temp-zmedi
2096        else
2097           xj=xj_safe-xmedi
2098           yj=yj_safe-ymedi
2099           zj=zj_safe-zmedi
2100        endif
2101           rij=xj*xj+yj*yj+zj*zj
2102             sss=sscale(sqrt(rij))
2103             sssgrad=sscagrad(sqrt(rij))
2104           if (rij.lt.r0ijsq) then
2105             evdw1ij=0.25d0*(rij-r0ijsq)**2
2106             fac=rij-r0ijsq
2107           else
2108             evdw1ij=0.0d0
2109             fac=0.0d0
2110           endif
2111           evdw1=evdw1+evdw1ij*sss
2112 C
2113 C Calculate contributions to the Cartesian gradient.
2114 C
2115           ggg(1)=fac*xj*sssgrad
2116           ggg(2)=fac*yj*sssgrad
2117           ggg(3)=fac*zj*sssgrad
2118           do k=1,3
2119             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2120             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2121           enddo
2122 *
2123 * Loop over residues i+1 thru j-1.
2124 *
2125 cgrad          do k=i+1,j-1
2126 cgrad            do l=1,3
2127 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2128 cgrad            enddo
2129 cgrad          enddo
2130         enddo ! j
2131       enddo   ! i
2132 cgrad      do i=nnt,nct-1
2133 cgrad        do k=1,3
2134 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2135 cgrad        enddo
2136 cgrad        do j=i+1,nct-1
2137 cgrad          do k=1,3
2138 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2139 cgrad          enddo
2140 cgrad        enddo
2141 cgrad      enddo
2142       return
2143       end
2144 c------------------------------------------------------------------------------
2145       subroutine vec_and_deriv
2146       implicit real*8 (a-h,o-z)
2147       include 'DIMENSIONS'
2148 #ifdef MPI
2149       include 'mpif.h'
2150 #endif
2151       include 'COMMON.IOUNITS'
2152       include 'COMMON.GEO'
2153       include 'COMMON.VAR'
2154       include 'COMMON.LOCAL'
2155       include 'COMMON.CHAIN'
2156       include 'COMMON.VECTORS'
2157       include 'COMMON.SETUP'
2158       include 'COMMON.TIME1'
2159       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2160 C Compute the local reference systems. For reference system (i), the
2161 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2162 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2163 #ifdef PARVEC
2164       do i=ivec_start,ivec_end
2165 #else
2166       do i=1,nres-1
2167 #endif
2168           if (i.eq.nres-1) then
2169 C Case of the last full residue
2170 C Compute the Z-axis
2171             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2172             costh=dcos(pi-theta(nres))
2173             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2174             do k=1,3
2175               uz(k,i)=fac*uz(k,i)
2176             enddo
2177 C Compute the derivatives of uz
2178             uzder(1,1,1)= 0.0d0
2179             uzder(2,1,1)=-dc_norm(3,i-1)
2180             uzder(3,1,1)= dc_norm(2,i-1)
2181             uzder(1,2,1)= dc_norm(3,i-1)
2182             uzder(2,2,1)= 0.0d0
2183             uzder(3,2,1)=-dc_norm(1,i-1)
2184             uzder(1,3,1)=-dc_norm(2,i-1)
2185             uzder(2,3,1)= dc_norm(1,i-1)
2186             uzder(3,3,1)= 0.0d0
2187             uzder(1,1,2)= 0.0d0
2188             uzder(2,1,2)= dc_norm(3,i)
2189             uzder(3,1,2)=-dc_norm(2,i)
2190             uzder(1,2,2)=-dc_norm(3,i)
2191             uzder(2,2,2)= 0.0d0
2192             uzder(3,2,2)= dc_norm(1,i)
2193             uzder(1,3,2)= dc_norm(2,i)
2194             uzder(2,3,2)=-dc_norm(1,i)
2195             uzder(3,3,2)= 0.0d0
2196 C Compute the Y-axis
2197             facy=fac
2198             do k=1,3
2199               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2200             enddo
2201 C Compute the derivatives of uy
2202             do j=1,3
2203               do k=1,3
2204                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2205      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2206                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2207               enddo
2208               uyder(j,j,1)=uyder(j,j,1)-costh
2209               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2210             enddo
2211             do j=1,2
2212               do k=1,3
2213                 do l=1,3
2214                   uygrad(l,k,j,i)=uyder(l,k,j)
2215                   uzgrad(l,k,j,i)=uzder(l,k,j)
2216                 enddo
2217               enddo
2218             enddo
2219             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2220             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2221             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2222             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2223           else
2224 C Other residues
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2227             costh=dcos(pi-theta(i+2))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i+1)
2235             uzder(3,1,1)= dc_norm(2,i+1)
2236             uzder(1,2,1)= dc_norm(3,i+1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i+1)
2239             uzder(1,3,1)=-dc_norm(2,i+1)
2240             uzder(2,3,1)= dc_norm(1,i+1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           endif
2279       enddo
2280       do i=1,nres-1
2281         vbld_inv_temp(1)=vbld_inv(i+1)
2282         if (i.lt.nres-1) then
2283           vbld_inv_temp(2)=vbld_inv(i+2)
2284           else
2285           vbld_inv_temp(2)=vbld_inv(i)
2286           endif
2287         do j=1,2
2288           do k=1,3
2289             do l=1,3
2290               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2291               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2292             enddo
2293           enddo
2294         enddo
2295       enddo
2296 #if defined(PARVEC) && defined(MPI)
2297       if (nfgtasks1.gt.1) then
2298         time00=MPI_Wtime()
2299 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2300 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2301 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2302         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2303      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2304      &   FG_COMM1,IERR)
2305         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2306      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2307      &   FG_COMM1,IERR)
2308         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2309      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2310      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2311         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2312      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2313      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2314         time_gather=time_gather+MPI_Wtime()-time00
2315       endif
2316 c      if (fg_rank.eq.0) then
2317 c        write (iout,*) "Arrays UY and UZ"
2318 c        do i=1,nres-1
2319 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2320 c     &     (uz(k,i),k=1,3)
2321 c        enddo
2322 c      endif
2323 #endif
2324       return
2325       end
2326 C-----------------------------------------------------------------------------
2327       subroutine check_vecgrad
2328       implicit real*8 (a-h,o-z)
2329       include 'DIMENSIONS'
2330       include 'COMMON.IOUNITS'
2331       include 'COMMON.GEO'
2332       include 'COMMON.VAR'
2333       include 'COMMON.LOCAL'
2334       include 'COMMON.CHAIN'
2335       include 'COMMON.VECTORS'
2336       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2337       dimension uyt(3,maxres),uzt(3,maxres)
2338       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2339       double precision delta /1.0d-7/
2340       call vec_and_deriv
2341 cd      do i=1,nres
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2344 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2345 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2346 cd     &     (dc_norm(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2348 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2349 cd          write(iout,'(a)')
2350 cd      enddo
2351       do i=1,nres
2352         do j=1,2
2353           do k=1,3
2354             do l=1,3
2355               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2356               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2357             enddo
2358           enddo
2359         enddo
2360       enddo
2361       call vec_and_deriv
2362       do i=1,nres
2363         do j=1,3
2364           uyt(j,i)=uy(j,i)
2365           uzt(j,i)=uz(j,i)
2366         enddo
2367       enddo
2368       do i=1,nres
2369 cd        write (iout,*) 'i=',i
2370         do k=1,3
2371           erij(k)=dc_norm(k,i)
2372         enddo
2373         do j=1,3
2374           do k=1,3
2375             dc_norm(k,i)=erij(k)
2376           enddo
2377           dc_norm(j,i)=dc_norm(j,i)+delta
2378 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2379 c          do k=1,3
2380 c            dc_norm(k,i)=dc_norm(k,i)/fac
2381 c          enddo
2382 c          write (iout,*) (dc_norm(k,i),k=1,3)
2383 c          write (iout,*) (erij(k),k=1,3)
2384           call vec_and_deriv
2385           do k=1,3
2386             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2387             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2388             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2389             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2390           enddo
2391 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2392 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2393 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2394         enddo
2395         do k=1,3
2396           dc_norm(k,i)=erij(k)
2397         enddo
2398 cd        do k=1,3
2399 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2400 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2401 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2402 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2403 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2404 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2405 cd          write (iout,'(a)')
2406 cd        enddo
2407       enddo
2408       return
2409       end
2410 C--------------------------------------------------------------------------
2411       subroutine set_matrices
2412       implicit real*8 (a-h,o-z)
2413       include 'DIMENSIONS'
2414 #ifdef MPI
2415       include "mpif.h"
2416       include "COMMON.SETUP"
2417       integer IERR
2418       integer status(MPI_STATUS_SIZE)
2419 #endif
2420       include 'COMMON.IOUNITS'
2421       include 'COMMON.GEO'
2422       include 'COMMON.VAR'
2423       include 'COMMON.LOCAL'
2424       include 'COMMON.CHAIN'
2425       include 'COMMON.DERIV'
2426       include 'COMMON.INTERACT'
2427       include 'COMMON.CONTACTS'
2428       include 'COMMON.TORSION'
2429       include 'COMMON.VECTORS'
2430       include 'COMMON.FFIELD'
2431       double precision auxvec(2),auxmat(2,2)
2432 C
2433 C Compute the virtual-bond-torsional-angle dependent quantities needed
2434 C to calculate the el-loc multibody terms of various order.
2435 C
2436 c      write(iout,*) 'nphi=',nphi,nres
2437 #ifdef PARMAT
2438       do i=ivec_start+2,ivec_end+2
2439 #else
2440       do i=3,nres+1
2441 #endif
2442 #ifdef NEWCORR
2443         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2444           iti = itortyp(itype(i-2))
2445         else
2446           iti=ntortyp+1
2447         endif
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           iti1 = itortyp(itype(i-1))
2451         else
2452           iti1=ntortyp+1
2453         endif
2454 c        write(iout,*),i
2455         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2456      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2457      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2458         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2459      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2460      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2461 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2462 c     &*(cos(theta(i)/2.0)
2463         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2464      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2465      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2466 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2467 c     &*(cos(theta(i)/2.0)
2468         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2469      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2470      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2471 c        if (ggb1(1,i).eq.0.0d0) then
2472 c        write(iout,*) 'i=',i,ggb1(1,i),
2473 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2474 c     &bnew1(2,1,iti)*cos(theta(i)),
2475 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2476 c        endif
2477         b1(2,i-2)=bnew1(1,2,iti)
2478         gtb1(2,i-2)=0.0
2479         b2(2,i-2)=bnew2(1,2,iti)
2480         gtb2(2,i-2)=0.0
2481         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2482         EE(1,2,i-2)=eeold(1,2,iti)
2483         EE(2,1,i-2)=eeold(2,1,iti)
2484         EE(2,2,i-2)=eeold(2,2,iti)
2485         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2486         gtEE(1,2,i-2)=0.0d0
2487         gtEE(2,2,i-2)=0.0d0
2488         gtEE(2,1,i-2)=0.0d0
2489 c        EE(2,2,iti)=0.0d0
2490 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2491 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2492 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2493 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2494        b1tilde(1,i-2)=b1(1,i-2)
2495        b1tilde(2,i-2)=-b1(2,i-2)
2496        b2tilde(1,i-2)=b2(1,i-2)
2497        b2tilde(2,i-2)=-b2(2,i-2)
2498 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2499 c       write(iout,*)  'b1=',b1(1,i-2)
2500 c       write (iout,*) 'theta=', theta(i-1)
2501        enddo
2502 #else
2503         b1(1,i-2)=b(3,iti)
2504         b1(2,i-2)=b(5,iti)
2505         b2(1,i-2)=b(2,iti)
2506         b2(2,i-2)=b(4,iti)
2507        b1tilde(1,i-2)=b1(1,i-2)
2508        b1tilde(2,i-2)=-b1(2,i-2)
2509        b2tilde(1,i-2)=b2(1,i-2)
2510        b2tilde(2,i-2)=-b2(2,i-2)
2511         EE(1,2,i-2)=eeold(1,2,iti)
2512         EE(2,1,i-2)=eeold(2,1,iti)
2513         EE(2,2,i-2)=eeold(2,2,iti)
2514         EE(1,1,i-2)=eeold(1,1,iti)
2515       enddo
2516 #endif
2517 #ifdef PARMAT
2518       do i=ivec_start+2,ivec_end+2
2519 #else
2520       do i=3,nres+1
2521 #endif
2522         if (i .lt. nres+1) then
2523           sin1=dsin(phi(i))
2524           cos1=dcos(phi(i))
2525           sintab(i-2)=sin1
2526           costab(i-2)=cos1
2527           obrot(1,i-2)=cos1
2528           obrot(2,i-2)=sin1
2529           sin2=dsin(2*phi(i))
2530           cos2=dcos(2*phi(i))
2531           sintab2(i-2)=sin2
2532           costab2(i-2)=cos2
2533           obrot2(1,i-2)=cos2
2534           obrot2(2,i-2)=sin2
2535           Ug(1,1,i-2)=-cos1
2536           Ug(1,2,i-2)=-sin1
2537           Ug(2,1,i-2)=-sin1
2538           Ug(2,2,i-2)= cos1
2539           Ug2(1,1,i-2)=-cos2
2540           Ug2(1,2,i-2)=-sin2
2541           Ug2(2,1,i-2)=-sin2
2542           Ug2(2,2,i-2)= cos2
2543         else
2544           costab(i-2)=1.0d0
2545           sintab(i-2)=0.0d0
2546           obrot(1,i-2)=1.0d0
2547           obrot(2,i-2)=0.0d0
2548           obrot2(1,i-2)=0.0d0
2549           obrot2(2,i-2)=0.0d0
2550           Ug(1,1,i-2)=1.0d0
2551           Ug(1,2,i-2)=0.0d0
2552           Ug(2,1,i-2)=0.0d0
2553           Ug(2,2,i-2)=1.0d0
2554           Ug2(1,1,i-2)=0.0d0
2555           Ug2(1,2,i-2)=0.0d0
2556           Ug2(2,1,i-2)=0.0d0
2557           Ug2(2,2,i-2)=0.0d0
2558         endif
2559         if (i .gt. 3 .and. i .lt. nres+1) then
2560           obrot_der(1,i-2)=-sin1
2561           obrot_der(2,i-2)= cos1
2562           Ugder(1,1,i-2)= sin1
2563           Ugder(1,2,i-2)=-cos1
2564           Ugder(2,1,i-2)=-cos1
2565           Ugder(2,2,i-2)=-sin1
2566           dwacos2=cos2+cos2
2567           dwasin2=sin2+sin2
2568           obrot2_der(1,i-2)=-dwasin2
2569           obrot2_der(2,i-2)= dwacos2
2570           Ug2der(1,1,i-2)= dwasin2
2571           Ug2der(1,2,i-2)=-dwacos2
2572           Ug2der(2,1,i-2)=-dwacos2
2573           Ug2der(2,2,i-2)=-dwasin2
2574         else
2575           obrot_der(1,i-2)=0.0d0
2576           obrot_der(2,i-2)=0.0d0
2577           Ugder(1,1,i-2)=0.0d0
2578           Ugder(1,2,i-2)=0.0d0
2579           Ugder(2,1,i-2)=0.0d0
2580           Ugder(2,2,i-2)=0.0d0
2581           obrot2_der(1,i-2)=0.0d0
2582           obrot2_der(2,i-2)=0.0d0
2583           Ug2der(1,1,i-2)=0.0d0
2584           Ug2der(1,2,i-2)=0.0d0
2585           Ug2der(2,1,i-2)=0.0d0
2586           Ug2der(2,2,i-2)=0.0d0
2587         endif
2588 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2589         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2590           iti = itortyp(itype(i-2))
2591         else
2592           iti=ntortyp
2593         endif
2594 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2595         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2596           iti1 = itortyp(itype(i-1))
2597         else
2598           iti1=ntortyp
2599         endif
2600 cd        write (iout,*) '*******i',i,' iti1',iti
2601 cd        write (iout,*) 'b1',b1(:,iti)
2602 cd        write (iout,*) 'b2',b2(:,iti)
2603 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2604 c        if (i .gt. iatel_s+2) then
2605         if (i .gt. nnt+2) then
2606           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2607 #ifdef NEWCORR
2608           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2609 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2610 #endif
2611 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2612 c     &    EE(1,2,iti),EE(2,2,iti)
2613           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2614           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2615 c          write(iout,*) "Macierz EUG",
2616 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2617 c     &    eug(2,2,i-2)
2618           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2619      &    then
2620           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2621           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2622           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2623           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2624           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2625           endif
2626         else
2627           do k=1,2
2628             Ub2(k,i-2)=0.0d0
2629             Ctobr(k,i-2)=0.0d0
2630             Dtobr2(k,i-2)=0.0d0
2631             do l=1,2
2632               EUg(l,k,i-2)=0.0d0
2633               CUg(l,k,i-2)=0.0d0
2634               DUg(l,k,i-2)=0.0d0
2635               DtUg2(l,k,i-2)=0.0d0
2636             enddo
2637           enddo
2638         endif
2639         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2640         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2641         do k=1,2
2642           muder(k,i-2)=Ub2der(k,i-2)
2643         enddo
2644 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2645         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2646           if (itype(i-1).le.ntyp) then
2647             iti1 = itortyp(itype(i-1))
2648           else
2649             iti1=ntortyp
2650           endif
2651         else
2652           iti1=ntortyp
2653         endif
2654         do k=1,2
2655           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2656         enddo
2657 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2658 cd        write (iout,*) 'mu1',mu1(:,i-2)
2659 cd        write (iout,*) 'mu2',mu2(:,i-2)
2660         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2661      &  then
2662         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2663         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2664         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2665         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2666         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2667 C Vectors and matrices dependent on a single virtual-bond dihedral.
2668         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2669         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2670         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2671         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2672         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2673         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2674         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2675         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2676         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2677         endif
2678       enddo
2679 C Matrices dependent on two consecutive virtual-bond dihedrals.
2680 C The order of matrices is from left to right.
2681       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2682      &then
2683 c      do i=max0(ivec_start,2),ivec_end
2684       do i=2,nres-1
2685         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2686         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2687         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2688         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2689         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2690         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2691         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2692         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2693       enddo
2694       endif
2695 #if defined(MPI) && defined(PARMAT)
2696 #ifdef DEBUG
2697 c      if (fg_rank.eq.0) then
2698         write (iout,*) "Arrays UG and UGDER before GATHER"
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       if (nfgtasks.gt.1) then
2728         time00=MPI_Wtime()
2729 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2730 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2731 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2732 #ifdef MATGATHER
2733         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2752      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2753      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2755      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2756      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2758      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2759      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2760         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2761      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2762      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2763         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2764      &  then
2765         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2773      &   FG_COMM1,IERR)
2774        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2800      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2803      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2804      &   FG_COMM1,IERR)
2805         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2806      &   ivec_count(fg_rank1),
2807      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2817      &   FG_COMM1,IERR)
2818        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2819      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2820      &   FG_COMM1,IERR)
2821         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2822      &   ivec_count(fg_rank1),
2823      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2824      &   FG_COMM1,IERR)
2825         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2826      &   ivec_count(fg_rank1),
2827      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2828      &   FG_COMM1,IERR)
2829         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2830      &   ivec_count(fg_rank1),
2831      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2832      &   MPI_MAT2,FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2834      &   ivec_count(fg_rank1),
2835      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2836      &   MPI_MAT2,FG_COMM1,IERR)
2837         endif
2838 #else
2839 c Passes matrix info through the ring
2840       isend=fg_rank1
2841       irecv=fg_rank1-1
2842       if (irecv.lt.0) irecv=nfgtasks1-1
2843       iprev=irecv
2844       inext=fg_rank1+1
2845       if (inext.ge.nfgtasks1) inext=0
2846       do i=1,nfgtasks1-1
2847 c        write (iout,*) "isend",isend," irecv",irecv
2848 c        call flush(iout)
2849         lensend=lentyp(isend)
2850         lenrecv=lentyp(irecv)
2851 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2852 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2853 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2854 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2855 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2856 c        write (iout,*) "Gather ROTAT1"
2857 c        call flush(iout)
2858 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2859 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2860 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2861 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2862 c        write (iout,*) "Gather ROTAT2"
2863 c        call flush(iout)
2864         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2865      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2866      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2867      &   iprev,4400+irecv,FG_COMM,status,IERR)
2868 c        write (iout,*) "Gather ROTAT_OLD"
2869 c        call flush(iout)
2870         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2871      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2872      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2873      &   iprev,5500+irecv,FG_COMM,status,IERR)
2874 c        write (iout,*) "Gather PRECOMP11"
2875 c        call flush(iout)
2876         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2877      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2878      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2879      &   iprev,6600+irecv,FG_COMM,status,IERR)
2880 c        write (iout,*) "Gather PRECOMP12"
2881 c        call flush(iout)
2882         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2883      &  then
2884         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2885      &   MPI_ROTAT2(lensend),inext,7700+isend,
2886      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2887      &   iprev,7700+irecv,FG_COMM,status,IERR)
2888 c        write (iout,*) "Gather PRECOMP21"
2889 c        call flush(iout)
2890         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2891      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2892      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2893      &   iprev,8800+irecv,FG_COMM,status,IERR)
2894 c        write (iout,*) "Gather PRECOMP22"
2895 c        call flush(iout)
2896         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2897      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2898      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2899      &   MPI_PRECOMP23(lenrecv),
2900      &   iprev,9900+irecv,FG_COMM,status,IERR)
2901 c        write (iout,*) "Gather PRECOMP23"
2902 c        call flush(iout)
2903         endif
2904         isend=irecv
2905         irecv=irecv-1
2906         if (irecv.lt.0) irecv=nfgtasks1-1
2907       enddo
2908 #endif
2909         time_gather=time_gather+MPI_Wtime()-time00
2910       endif
2911 #ifdef DEBUG
2912 c      if (fg_rank.eq.0) then
2913         write (iout,*) "Arrays UG and UGDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2916      &     ((ug(l,k,i),l=1,2),k=1,2),
2917      &     ((ugder(l,k,i),l=1,2),k=1,2)
2918         enddo
2919         write (iout,*) "Arrays UG2 and UG2DER"
2920         do i=1,nres-1
2921           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2922      &     ((ug2(l,k,i),l=1,2),k=1,2),
2923      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2924         enddo
2925         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2926         do i=1,nres-1
2927           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2928      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2929      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2930         enddo
2931         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2932         do i=1,nres-1
2933           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2934      &     costab(i),sintab(i),costab2(i),sintab2(i)
2935         enddo
2936         write (iout,*) "Array MUDER"
2937         do i=1,nres-1
2938           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2939         enddo
2940 c      endif
2941 #endif
2942 #endif
2943 cd      do i=1,nres
2944 cd        iti = itortyp(itype(i))
2945 cd        write (iout,*) i
2946 cd        do j=1,2
2947 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2948 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2949 cd        enddo
2950 cd      enddo
2951       return
2952       end
2953 C--------------------------------------------------------------------------
2954       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2955 C
2956 C This subroutine calculates the average interaction energy and its gradient
2957 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2958 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2959 C The potential depends both on the distance of peptide-group centers and on
2960 C the orientation of the CA-CA virtual bonds.
2961 C
2962       implicit real*8 (a-h,o-z)
2963 #ifdef MPI
2964       include 'mpif.h'
2965 #endif
2966       include 'DIMENSIONS'
2967       include 'COMMON.CONTROL'
2968       include 'COMMON.SETUP'
2969       include 'COMMON.IOUNITS'
2970       include 'COMMON.GEO'
2971       include 'COMMON.VAR'
2972       include 'COMMON.LOCAL'
2973       include 'COMMON.CHAIN'
2974       include 'COMMON.DERIV'
2975       include 'COMMON.INTERACT'
2976       include 'COMMON.CONTACTS'
2977       include 'COMMON.TORSION'
2978       include 'COMMON.VECTORS'
2979       include 'COMMON.FFIELD'
2980       include 'COMMON.TIME1'
2981       include 'COMMON.SPLITELE'
2982       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2983      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2984       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2985      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2986       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2987      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2988      &    num_conti,j1,j2
2989 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2990 #ifdef MOMENT
2991       double precision scal_el /1.0d0/
2992 #else
2993       double precision scal_el /0.5d0/
2994 #endif
2995 C 12/13/98
2996 C 13-go grudnia roku pamietnego...
2997       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2998      &                   0.0d0,1.0d0,0.0d0,
2999      &                   0.0d0,0.0d0,1.0d0/
3000 cd      write(iout,*) 'In EELEC'
3001 cd      do i=1,nloctyp
3002 cd        write(iout,*) 'Type',i
3003 cd        write(iout,*) 'B1',B1(:,i)
3004 cd        write(iout,*) 'B2',B2(:,i)
3005 cd        write(iout,*) 'CC',CC(:,:,i)
3006 cd        write(iout,*) 'DD',DD(:,:,i)
3007 cd        write(iout,*) 'EE',EE(:,:,i)
3008 cd      enddo
3009 cd      call check_vecgrad
3010 cd      stop
3011       if (icheckgrad.eq.1) then
3012         do i=1,nres-1
3013           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3014           do k=1,3
3015             dc_norm(k,i)=dc(k,i)*fac
3016           enddo
3017 c          write (iout,*) 'i',i,' fac',fac
3018         enddo
3019       endif
3020       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3021      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3022      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3023 c        call vec_and_deriv
3024 #ifdef TIMING
3025         time01=MPI_Wtime()
3026 #endif
3027         call set_matrices
3028 #ifdef TIMING
3029         time_mat=time_mat+MPI_Wtime()-time01
3030 #endif
3031       endif
3032 cd      do i=1,nres-1
3033 cd        write (iout,*) 'i=',i
3034 cd        do k=1,3
3035 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3036 cd        enddo
3037 cd        do k=1,3
3038 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3039 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3040 cd        enddo
3041 cd      enddo
3042       t_eelecij=0.0d0
3043       ees=0.0D0
3044       evdw1=0.0D0
3045       eel_loc=0.0d0
3046       eello_turn3=0.0d0
3047       eello_turn4=0.0d0
3048       ind=0
3049       do i=1,nres
3050         num_cont_hb(i)=0
3051       enddo
3052 cd      print '(a)','Enter EELEC'
3053 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3054       do i=1,nres
3055         gel_loc_loc(i)=0.0d0
3056         gcorr_loc(i)=0.0d0
3057       enddo
3058 c
3059 c
3060 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3061 C
3062 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3063 C
3064 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3065       do i=iturn3_start,iturn3_end
3066         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3067      &  .or. itype(i+2).eq.ntyp1
3068      &  .or. itype(i+3).eq.ntyp1
3069      &  .or. itype(i-1).eq.ntyp1
3070      &  .or. itype(i+4).eq.ntyp1
3071      &  ) cycle
3072         dxi=dc(1,i)
3073         dyi=dc(2,i)
3074         dzi=dc(3,i)
3075         dx_normi=dc_norm(1,i)
3076         dy_normi=dc_norm(2,i)
3077         dz_normi=dc_norm(3,i)
3078         xmedi=c(1,i)+0.5d0*dxi
3079         ymedi=c(2,i)+0.5d0*dyi
3080         zmedi=c(3,i)+0.5d0*dzi
3081           xmedi=mod(xmedi,boxxsize)
3082           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3083           ymedi=mod(ymedi,boxysize)
3084           if (ymedi.lt.0) ymedi=ymedi+boxysize
3085           zmedi=mod(zmedi,boxzsize)
3086           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3087         num_conti=0
3088         call eelecij(i,i+2,ees,evdw1,eel_loc)
3089         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3090         num_cont_hb(i)=num_conti
3091       enddo
3092       do i=iturn4_start,iturn4_end
3093         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3094      &    .or. itype(i+3).eq.ntyp1
3095      &    .or. itype(i+4).eq.ntyp1
3096      &    .or. itype(i+5).eq.ntyp1
3097      &    .or. itype(i).eq.ntyp1
3098      &    .or. itype(i-1).eq.ntyp1
3099      &                             ) cycle
3100         dxi=dc(1,i)
3101         dyi=dc(2,i)
3102         dzi=dc(3,i)
3103         dx_normi=dc_norm(1,i)
3104         dy_normi=dc_norm(2,i)
3105         dz_normi=dc_norm(3,i)
3106         xmedi=c(1,i)+0.5d0*dxi
3107         ymedi=c(2,i)+0.5d0*dyi
3108         zmedi=c(3,i)+0.5d0*dzi
3109 C Return atom into box, boxxsize is size of box in x dimension
3110 c  194   continue
3111 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3112 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3113 C Condition for being inside the proper box
3114 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3115 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3116 c        go to 194
3117 c        endif
3118 c  195   continue
3119 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3120 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3121 C Condition for being inside the proper box
3122 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3123 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3124 c        go to 195
3125 c        endif
3126 c  196   continue
3127 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3128 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3129 C Condition for being inside the proper box
3130 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3131 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3132 c        go to 196
3133 c        endif
3134           xmedi=mod(xmedi,boxxsize)
3135           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3136           ymedi=mod(ymedi,boxysize)
3137           if (ymedi.lt.0) ymedi=ymedi+boxysize
3138           zmedi=mod(zmedi,boxzsize)
3139           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3140
3141         num_conti=num_cont_hb(i)
3142 c        write(iout,*) "JESTEM W PETLI"
3143         call eelecij(i,i+3,ees,evdw1,eel_loc)
3144         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3145      &   call eturn4(i,eello_turn4)
3146         num_cont_hb(i)=num_conti
3147       enddo   ! i
3148 C Loop over all neighbouring boxes
3149 C      do xshift=-1,1
3150 C      do yshift=-1,1
3151 C      do zshift=-1,1
3152 c
3153 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3154 c
3155       do i=iatel_s,iatel_e
3156         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3157      &  .or. itype(i+2).eq.ntyp1
3158      &  .or. itype(i-1).eq.ntyp1
3159      &                ) cycle
3160         dxi=dc(1,i)
3161         dyi=dc(2,i)
3162         dzi=dc(3,i)
3163         dx_normi=dc_norm(1,i)
3164         dy_normi=dc_norm(2,i)
3165         dz_normi=dc_norm(3,i)
3166         xmedi=c(1,i)+0.5d0*dxi
3167         ymedi=c(2,i)+0.5d0*dyi
3168         zmedi=c(3,i)+0.5d0*dzi
3169           xmedi=mod(xmedi,boxxsize)
3170           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3171           ymedi=mod(ymedi,boxysize)
3172           if (ymedi.lt.0) ymedi=ymedi+boxysize
3173           zmedi=mod(zmedi,boxzsize)
3174           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3175 C          xmedi=xmedi+xshift*boxxsize
3176 C          ymedi=ymedi+yshift*boxysize
3177 C          zmedi=zmedi+zshift*boxzsize
3178
3179 C Return tom into box, boxxsize is size of box in x dimension
3180 c  164   continue
3181 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3182 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3183 C Condition for being inside the proper box
3184 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3185 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3186 c        go to 164
3187 c        endif
3188 c  165   continue
3189 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3190 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3191 C Condition for being inside the proper box
3192 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3193 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3194 c        go to 165
3195 c        endif
3196 c  166   continue
3197 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3198 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3199 cC Condition for being inside the proper box
3200 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3201 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3202 c        go to 166
3203 c        endif
3204
3205 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3206         num_conti=num_cont_hb(i)
3207         do j=ielstart(i),ielend(i)
3208 c          write (iout,*) i,j,itype(i),itype(j)
3209           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3210      & .or.itype(j+2).eq.ntyp1
3211      & .or.itype(j-1).eq.ntyp1
3212      &) cycle
3213           call eelecij(i,j,ees,evdw1,eel_loc)
3214         enddo ! j
3215         num_cont_hb(i)=num_conti
3216       enddo   ! i
3217 C     enddo   ! zshift
3218 C      enddo   ! yshift
3219 C      enddo   ! xshift
3220
3221 c      write (iout,*) "Number of loop steps in EELEC:",ind
3222 cd      do i=1,nres
3223 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3224 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3225 cd      enddo
3226 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3227 ccc      eel_loc=eel_loc+eello_turn3
3228 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3229       return
3230       end
3231 C-------------------------------------------------------------------------------
3232       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3233       implicit real*8 (a-h,o-z)
3234       include 'DIMENSIONS'
3235 #ifdef MPI
3236       include "mpif.h"
3237 #endif
3238       include 'COMMON.CONTROL'
3239       include 'COMMON.IOUNITS'
3240       include 'COMMON.GEO'
3241       include 'COMMON.VAR'
3242       include 'COMMON.LOCAL'
3243       include 'COMMON.CHAIN'
3244       include 'COMMON.DERIV'
3245       include 'COMMON.INTERACT'
3246       include 'COMMON.CONTACTS'
3247       include 'COMMON.TORSION'
3248       include 'COMMON.VECTORS'
3249       include 'COMMON.FFIELD'
3250       include 'COMMON.TIME1'
3251       include 'COMMON.SPLITELE'
3252       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3253      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3254       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3255      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3256      &    gmuij2(4),gmuji2(4)
3257       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3258      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3259      &    num_conti,j1,j2
3260 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3261 #ifdef MOMENT
3262       double precision scal_el /1.0d0/
3263 #else
3264       double precision scal_el /0.5d0/
3265 #endif
3266 C 12/13/98
3267 C 13-go grudnia roku pamietnego...
3268       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3269      &                   0.0d0,1.0d0,0.0d0,
3270      &                   0.0d0,0.0d0,1.0d0/
3271 c          time00=MPI_Wtime()
3272 cd      write (iout,*) "eelecij",i,j
3273 c          ind=ind+1
3274           iteli=itel(i)
3275           itelj=itel(j)
3276           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3277           aaa=app(iteli,itelj)
3278           bbb=bpp(iteli,itelj)
3279           ael6i=ael6(iteli,itelj)
3280           ael3i=ael3(iteli,itelj)
3281           dxj=dc(1,j)
3282           dyj=dc(2,j)
3283           dzj=dc(3,j)
3284           dx_normj=dc_norm(1,j)
3285           dy_normj=dc_norm(2,j)
3286           dz_normj=dc_norm(3,j)
3287 C          xj=c(1,j)+0.5D0*dxj-xmedi
3288 C          yj=c(2,j)+0.5D0*dyj-ymedi
3289 C          zj=c(3,j)+0.5D0*dzj-zmedi
3290           xj=c(1,j)+0.5D0*dxj
3291           yj=c(2,j)+0.5D0*dyj
3292           zj=c(3,j)+0.5D0*dzj
3293           xj=mod(xj,boxxsize)
3294           if (xj.lt.0) xj=xj+boxxsize
3295           yj=mod(yj,boxysize)
3296           if (yj.lt.0) yj=yj+boxysize
3297           zj=mod(zj,boxzsize)
3298           if (zj.lt.0) zj=zj+boxzsize
3299           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3300       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3301       xj_safe=xj
3302       yj_safe=yj
3303       zj_safe=zj
3304       isubchap=0
3305       do xshift=-1,1
3306       do yshift=-1,1
3307       do zshift=-1,1
3308           xj=xj_safe+xshift*boxxsize
3309           yj=yj_safe+yshift*boxysize
3310           zj=zj_safe+zshift*boxzsize
3311           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3312           if(dist_temp.lt.dist_init) then
3313             dist_init=dist_temp
3314             xj_temp=xj
3315             yj_temp=yj
3316             zj_temp=zj
3317             isubchap=1
3318           endif
3319        enddo
3320        enddo
3321        enddo
3322        if (isubchap.eq.1) then
3323           xj=xj_temp-xmedi
3324           yj=yj_temp-ymedi
3325           zj=zj_temp-zmedi
3326        else
3327           xj=xj_safe-xmedi
3328           yj=yj_safe-ymedi
3329           zj=zj_safe-zmedi
3330        endif
3331 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3332 c  174   continue
3333 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3334 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3335 C Condition for being inside the proper box
3336 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3337 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3338 c        go to 174
3339 c        endif
3340 c  175   continue
3341 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3342 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3343 C Condition for being inside the proper box
3344 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3345 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3346 c        go to 175
3347 c        endif
3348 c  176   continue
3349 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3350 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3351 C Condition for being inside the proper box
3352 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3353 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3354 c        go to 176
3355 c        endif
3356 C        endif !endPBC condintion
3357 C        xj=xj-xmedi
3358 C        yj=yj-ymedi
3359 C        zj=zj-zmedi
3360           rij=xj*xj+yj*yj+zj*zj
3361
3362             sss=sscale(sqrt(rij))
3363             sssgrad=sscagrad(sqrt(rij))
3364 c            if (sss.gt.0.0d0) then
3365           rrmij=1.0D0/rij
3366           rij=dsqrt(rij)
3367           rmij=1.0D0/rij
3368           r3ij=rrmij*rmij
3369           r6ij=r3ij*r3ij
3370           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3371           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3372           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3373           fac=cosa-3.0D0*cosb*cosg
3374           ev1=aaa*r6ij*r6ij
3375 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3376           if (j.eq.i+2) ev1=scal_el*ev1
3377           ev2=bbb*r6ij
3378           fac3=ael6i*r6ij
3379           fac4=ael3i*r3ij
3380           evdwij=(ev1+ev2)
3381           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3382           el2=fac4*fac
3383 C MARYSIA
3384           eesij=(el1+el2)
3385 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3386           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3387           ees=ees+eesij
3388           evdw1=evdw1+evdwij*sss
3389 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3390 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3391 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3392 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3393
3394           if (energy_dec) then
3395               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3396      &'evdw1',i,j,evdwij
3397      &,iteli,itelj,aaa,evdw1
3398               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3399           endif
3400
3401 C
3402 C Calculate contributions to the Cartesian gradient.
3403 C
3404 #ifdef SPLITELE
3405           facvdw=-6*rrmij*(ev1+evdwij)*sss
3406           facel=-3*rrmij*(el1+eesij)
3407           fac1=fac
3408           erij(1)=xj*rmij
3409           erij(2)=yj*rmij
3410           erij(3)=zj*rmij
3411 *
3412 * Radial derivatives. First process both termini of the fragment (i,j)
3413 *
3414           ggg(1)=facel*xj
3415           ggg(2)=facel*yj
3416           ggg(3)=facel*zj
3417 c          do k=1,3
3418 c            ghalf=0.5D0*ggg(k)
3419 c            gelc(k,i)=gelc(k,i)+ghalf
3420 c            gelc(k,j)=gelc(k,j)+ghalf
3421 c          enddo
3422 c 9/28/08 AL Gradient compotents will be summed only at the end
3423           do k=1,3
3424             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3425             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3426           enddo
3427 *
3428 * Loop over residues i+1 thru j-1.
3429 *
3430 cgrad          do k=i+1,j-1
3431 cgrad            do l=1,3
3432 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3433 cgrad            enddo
3434 cgrad          enddo
3435           if (sss.gt.0.0) then
3436           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3437           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3438           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3439           else
3440           ggg(1)=0.0
3441           ggg(2)=0.0
3442           ggg(3)=0.0
3443           endif
3444 c          do k=1,3
3445 c            ghalf=0.5D0*ggg(k)
3446 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3447 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3448 c          enddo
3449 c 9/28/08 AL Gradient compotents will be summed only at the end
3450           do k=1,3
3451             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3452             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3453           enddo
3454 *
3455 * Loop over residues i+1 thru j-1.
3456 *
3457 cgrad          do k=i+1,j-1
3458 cgrad            do l=1,3
3459 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3460 cgrad            enddo
3461 cgrad          enddo
3462 #else
3463 C MARYSIA
3464           facvdw=(ev1+evdwij)*sss
3465           facel=(el1+eesij)
3466           fac1=fac
3467           fac=-3*rrmij*(facvdw+facvdw+facel)
3468           erij(1)=xj*rmij
3469           erij(2)=yj*rmij
3470           erij(3)=zj*rmij
3471 *
3472 * Radial derivatives. First process both termini of the fragment (i,j)
3473 *
3474           ggg(1)=fac*xj
3475           ggg(2)=fac*yj
3476           ggg(3)=fac*zj
3477 c          do k=1,3
3478 c            ghalf=0.5D0*ggg(k)
3479 c            gelc(k,i)=gelc(k,i)+ghalf
3480 c            gelc(k,j)=gelc(k,j)+ghalf
3481 c          enddo
3482 c 9/28/08 AL Gradient compotents will be summed only at the end
3483           do k=1,3
3484             gelc_long(k,j)=gelc(k,j)+ggg(k)
3485             gelc_long(k,i)=gelc(k,i)-ggg(k)
3486           enddo
3487 *
3488 * Loop over residues i+1 thru j-1.
3489 *
3490 cgrad          do k=i+1,j-1
3491 cgrad            do l=1,3
3492 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3493 cgrad            enddo
3494 cgrad          enddo
3495 c 9/28/08 AL Gradient compotents will be summed only at the end
3496           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3497           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3498           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3499           do k=1,3
3500             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3501             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3502           enddo
3503 #endif
3504 *
3505 * Angular part
3506 *
3507           ecosa=2.0D0*fac3*fac1+fac4
3508           fac4=-3.0D0*fac4
3509           fac3=-6.0D0*fac3
3510           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3511           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3512           do k=1,3
3513             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3514             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3515           enddo
3516 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3517 cd   &          (dcosg(k),k=1,3)
3518           do k=1,3
3519             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3520           enddo
3521 c          do k=1,3
3522 c            ghalf=0.5D0*ggg(k)
3523 c            gelc(k,i)=gelc(k,i)+ghalf
3524 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3525 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3526 c            gelc(k,j)=gelc(k,j)+ghalf
3527 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3528 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3529 c          enddo
3530 cgrad          do k=i+1,j-1
3531 cgrad            do l=1,3
3532 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3533 cgrad            enddo
3534 cgrad          enddo
3535           do k=1,3
3536             gelc(k,i)=gelc(k,i)
3537      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3538      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3539             gelc(k,j)=gelc(k,j)
3540      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3541      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3542             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3543             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3544           enddo
3545 C MARYSIA
3546 c          endif !sscale
3547           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3548      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3549      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3550 C
3551 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3552 C   energy of a peptide unit is assumed in the form of a second-order
3553 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3554 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3555 C   are computed for EVERY pair of non-contiguous peptide groups.
3556 C
3557
3558           if (j.lt.nres-1) then
3559             j1=j+1
3560             j2=j-1
3561           else
3562             j1=j-1
3563             j2=j-2
3564           endif
3565           kkk=0
3566           lll=0
3567           do k=1,2
3568             do l=1,2
3569               kkk=kkk+1
3570               muij(kkk)=mu(k,i)*mu(l,j)
3571 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3572 #ifdef NEWCORR
3573              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3574 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3575              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3576              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3577 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3578              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3579 #endif
3580             enddo
3581           enddo
3582 cd         write (iout,*) 'EELEC: i',i,' j',j
3583 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3584 cd          write(iout,*) 'muij',muij
3585           ury=scalar(uy(1,i),erij)
3586           urz=scalar(uz(1,i),erij)
3587           vry=scalar(uy(1,j),erij)
3588           vrz=scalar(uz(1,j),erij)
3589           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3590           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3591           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3592           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3593           fac=dsqrt(-ael6i)*r3ij
3594           a22=a22*fac
3595           a23=a23*fac
3596           a32=a32*fac
3597           a33=a33*fac
3598 cd          write (iout,'(4i5,4f10.5)')
3599 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3600 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3601 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3602 cd     &      uy(:,j),uz(:,j)
3603 cd          write (iout,'(4f10.5)')
3604 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3605 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3606 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3607 cd           write (iout,'(9f10.5/)')
3608 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3609 C Derivatives of the elements of A in virtual-bond vectors
3610           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3611           do k=1,3
3612             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3613             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3614             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3615             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3616             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3617             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3618             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3619             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3620             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3621             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3622             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3623             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3624           enddo
3625 C Compute radial contributions to the gradient
3626           facr=-3.0d0*rrmij
3627           a22der=a22*facr
3628           a23der=a23*facr
3629           a32der=a32*facr
3630           a33der=a33*facr
3631           agg(1,1)=a22der*xj
3632           agg(2,1)=a22der*yj
3633           agg(3,1)=a22der*zj
3634           agg(1,2)=a23der*xj
3635           agg(2,2)=a23der*yj
3636           agg(3,2)=a23der*zj
3637           agg(1,3)=a32der*xj
3638           agg(2,3)=a32der*yj
3639           agg(3,3)=a32der*zj
3640           agg(1,4)=a33der*xj
3641           agg(2,4)=a33der*yj
3642           agg(3,4)=a33der*zj
3643 C Add the contributions coming from er
3644           fac3=-3.0d0*fac
3645           do k=1,3
3646             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3647             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3648             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3649             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3650           enddo
3651           do k=1,3
3652 C Derivatives in DC(i)
3653 cgrad            ghalf1=0.5d0*agg(k,1)
3654 cgrad            ghalf2=0.5d0*agg(k,2)
3655 cgrad            ghalf3=0.5d0*agg(k,3)
3656 cgrad            ghalf4=0.5d0*agg(k,4)
3657             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3658      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3659             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3660      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3661             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3662      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3663             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3664      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3665 C Derivatives in DC(i+1)
3666             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3667      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3668             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3669      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3670             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3671      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3672             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3673      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3674 C Derivatives in DC(j)
3675             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3676      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3677             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3678      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3679             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3680      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3681             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3682      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3683 C Derivatives in DC(j+1) or DC(nres-1)
3684             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3685      &      -3.0d0*vryg(k,3)*ury)
3686             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3687      &      -3.0d0*vrzg(k,3)*ury)
3688             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3689      &      -3.0d0*vryg(k,3)*urz)
3690             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3691      &      -3.0d0*vrzg(k,3)*urz)
3692 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3693 cgrad              do l=1,4
3694 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3695 cgrad              enddo
3696 cgrad            endif
3697           enddo
3698           acipa(1,1)=a22
3699           acipa(1,2)=a23
3700           acipa(2,1)=a32
3701           acipa(2,2)=a33
3702           a22=-a22
3703           a23=-a23
3704           do l=1,2
3705             do k=1,3
3706               agg(k,l)=-agg(k,l)
3707               aggi(k,l)=-aggi(k,l)
3708               aggi1(k,l)=-aggi1(k,l)
3709               aggj(k,l)=-aggj(k,l)
3710               aggj1(k,l)=-aggj1(k,l)
3711             enddo
3712           enddo
3713           if (j.lt.nres-1) then
3714             a22=-a22
3715             a32=-a32
3716             do l=1,3,2
3717               do k=1,3
3718                 agg(k,l)=-agg(k,l)
3719                 aggi(k,l)=-aggi(k,l)
3720                 aggi1(k,l)=-aggi1(k,l)
3721                 aggj(k,l)=-aggj(k,l)
3722                 aggj1(k,l)=-aggj1(k,l)
3723               enddo
3724             enddo
3725           else
3726             a22=-a22
3727             a23=-a23
3728             a32=-a32
3729             a33=-a33
3730             do l=1,4
3731               do k=1,3
3732                 agg(k,l)=-agg(k,l)
3733                 aggi(k,l)=-aggi(k,l)
3734                 aggi1(k,l)=-aggi1(k,l)
3735                 aggj(k,l)=-aggj(k,l)
3736                 aggj1(k,l)=-aggj1(k,l)
3737               enddo
3738             enddo
3739           endif
3740           ENDIF ! WCORR
3741           IF (wel_loc.gt.0.0d0) THEN
3742 C Contribution to the local-electrostatic energy coming from the i-j pair
3743           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3744      &     +a33*muij(4)
3745 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3746 c     &                     ' eel_loc_ij',eel_loc_ij
3747 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3748 C Calculate patrial derivative for theta angle
3749 #ifdef NEWCORR
3750          geel_loc_ij=a22*gmuij1(1)
3751      &     +a23*gmuij1(2)
3752      &     +a32*gmuij1(3)
3753      &     +a33*gmuij1(4)
3754 c         write(iout,*) "derivative over thatai"
3755 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3756 c     &   a33*gmuij1(4)
3757          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3758      &      geel_loc_ij*wel_loc
3759 c         write(iout,*) "derivative over thatai-1"
3760 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3761 c     &   a33*gmuij2(4)
3762          geel_loc_ij=
3763      &     a22*gmuij2(1)
3764      &     +a23*gmuij2(2)
3765      &     +a32*gmuij2(3)
3766      &     +a33*gmuij2(4)
3767          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3768      &      geel_loc_ij*wel_loc
3769 c  Derivative over j residue
3770          geel_loc_ji=a22*gmuji1(1)
3771      &     +a23*gmuji1(2)
3772      &     +a32*gmuji1(3)
3773      &     +a33*gmuji1(4)
3774 c         write(iout,*) "derivative over thataj"
3775 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3776 c     &   a33*gmuji1(4)
3777
3778         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3779      &      geel_loc_ji*wel_loc
3780          geel_loc_ji=
3781      &     +a22*gmuji2(1)
3782      &     +a23*gmuji2(2)
3783      &     +a32*gmuji2(3)
3784      &     +a33*gmuji2(4)
3785 c         write(iout,*) "derivative over thataj-1"
3786 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3787 c     &   a33*gmuji2(4)
3788          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3789      &      geel_loc_ji*wel_loc
3790 #endif
3791 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3792
3793           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3794      &            'eelloc',i,j,eel_loc_ij
3795 c           if (eel_loc_ij.ne.0)
3796 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3797 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3798
3799           eel_loc=eel_loc+eel_loc_ij
3800 C Partial derivatives in virtual-bond dihedral angles gamma
3801           if (i.gt.1)
3802      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3803      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3804      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3805           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3806      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3807      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3808 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3809           do l=1,3
3810             ggg(l)=agg(l,1)*muij(1)+
3811      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3812             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3813             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3814 cgrad            ghalf=0.5d0*ggg(l)
3815 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3816 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3817           enddo
3818 cgrad          do k=i+1,j2
3819 cgrad            do l=1,3
3820 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3821 cgrad            enddo
3822 cgrad          enddo
3823 C Remaining derivatives of eello
3824           do l=1,3
3825             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3826      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3827             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3828      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3829             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3830      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3831             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3832      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3833           enddo
3834           ENDIF
3835 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3836 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3837           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3838      &       .and. num_conti.le.maxconts) then
3839 c            write (iout,*) i,j," entered corr"
3840 C
3841 C Calculate the contact function. The ith column of the array JCONT will
3842 C contain the numbers of atoms that make contacts with the atom I (of numbers
3843 C greater than I). The arrays FACONT and GACONT will contain the values of
3844 C the contact function and its derivative.
3845 c           r0ij=1.02D0*rpp(iteli,itelj)
3846 c           r0ij=1.11D0*rpp(iteli,itelj)
3847             r0ij=2.20D0*rpp(iteli,itelj)
3848 c           r0ij=1.55D0*rpp(iteli,itelj)
3849             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3850             if (fcont.gt.0.0D0) then
3851               num_conti=num_conti+1
3852               if (num_conti.gt.maxconts) then
3853                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3854      &                         ' will skip next contacts for this conf.'
3855               else
3856                 jcont_hb(num_conti,i)=j
3857 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3858 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3859                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3860      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3861 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3862 C  terms.
3863                 d_cont(num_conti,i)=rij
3864 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3865 C     --- Electrostatic-interaction matrix ---
3866                 a_chuj(1,1,num_conti,i)=a22
3867                 a_chuj(1,2,num_conti,i)=a23
3868                 a_chuj(2,1,num_conti,i)=a32
3869                 a_chuj(2,2,num_conti,i)=a33
3870 C     --- Gradient of rij
3871                 do kkk=1,3
3872                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3873                 enddo
3874                 kkll=0
3875                 do k=1,2
3876                   do l=1,2
3877                     kkll=kkll+1
3878                     do m=1,3
3879                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3880                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3881                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3882                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3883                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3884                     enddo
3885                   enddo
3886                 enddo
3887                 ENDIF
3888                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3889 C Calculate contact energies
3890                 cosa4=4.0D0*cosa
3891                 wij=cosa-3.0D0*cosb*cosg
3892                 cosbg1=cosb+cosg
3893                 cosbg2=cosb-cosg
3894 c               fac3=dsqrt(-ael6i)/r0ij**3
3895                 fac3=dsqrt(-ael6i)*r3ij
3896 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3897                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3898                 if (ees0tmp.gt.0) then
3899                   ees0pij=dsqrt(ees0tmp)
3900                 else
3901                   ees0pij=0
3902                 endif
3903 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3904                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3905                 if (ees0tmp.gt.0) then
3906                   ees0mij=dsqrt(ees0tmp)
3907                 else
3908                   ees0mij=0
3909                 endif
3910 c               ees0mij=0.0D0
3911                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3912                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3913 C Diagnostics. Comment out or remove after debugging!
3914 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3915 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3916 c               ees0m(num_conti,i)=0.0D0
3917 C End diagnostics.
3918 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3919 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3920 C Angular derivatives of the contact function
3921                 ees0pij1=fac3/ees0pij
3922                 ees0mij1=fac3/ees0mij
3923                 fac3p=-3.0D0*fac3*rrmij
3924                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3925                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3926 c               ees0mij1=0.0D0
3927                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3928                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3929                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3930                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3931                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3932                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3933                 ecosap=ecosa1+ecosa2
3934                 ecosbp=ecosb1+ecosb2
3935                 ecosgp=ecosg1+ecosg2
3936                 ecosam=ecosa1-ecosa2
3937                 ecosbm=ecosb1-ecosb2
3938                 ecosgm=ecosg1-ecosg2
3939 C Diagnostics
3940 c               ecosap=ecosa1
3941 c               ecosbp=ecosb1
3942 c               ecosgp=ecosg1
3943 c               ecosam=0.0D0
3944 c               ecosbm=0.0D0
3945 c               ecosgm=0.0D0
3946 C End diagnostics
3947                 facont_hb(num_conti,i)=fcont
3948                 fprimcont=fprimcont/rij
3949 cd              facont_hb(num_conti,i)=1.0D0
3950 C Following line is for diagnostics.
3951 cd              fprimcont=0.0D0
3952                 do k=1,3
3953                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3954                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3955                 enddo
3956                 do k=1,3
3957                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3958                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3959                 enddo
3960                 gggp(1)=gggp(1)+ees0pijp*xj
3961                 gggp(2)=gggp(2)+ees0pijp*yj
3962                 gggp(3)=gggp(3)+ees0pijp*zj
3963                 gggm(1)=gggm(1)+ees0mijp*xj
3964                 gggm(2)=gggm(2)+ees0mijp*yj
3965                 gggm(3)=gggm(3)+ees0mijp*zj
3966 C Derivatives due to the contact function
3967                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3968                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3969                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3970                 do k=1,3
3971 c
3972 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3973 c          following the change of gradient-summation algorithm.
3974 c
3975 cgrad                  ghalfp=0.5D0*gggp(k)
3976 cgrad                  ghalfm=0.5D0*gggm(k)
3977                   gacontp_hb1(k,num_conti,i)=!ghalfp
3978      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3979      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3980                   gacontp_hb2(k,num_conti,i)=!ghalfp
3981      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3982      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3983                   gacontp_hb3(k,num_conti,i)=gggp(k)
3984                   gacontm_hb1(k,num_conti,i)=!ghalfm
3985      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3986      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3987                   gacontm_hb2(k,num_conti,i)=!ghalfm
3988      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3989      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3990                   gacontm_hb3(k,num_conti,i)=gggm(k)
3991                 enddo
3992 C Diagnostics. Comment out or remove after debugging!
3993 cdiag           do k=1,3
3994 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3995 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3996 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3997 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3998 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3999 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4000 cdiag           enddo
4001               ENDIF ! wcorr
4002               endif  ! num_conti.le.maxconts
4003             endif  ! fcont.gt.0
4004           endif    ! j.gt.i+1
4005           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4006             do k=1,4
4007               do l=1,3
4008                 ghalf=0.5d0*agg(l,k)
4009                 aggi(l,k)=aggi(l,k)+ghalf
4010                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4011                 aggj(l,k)=aggj(l,k)+ghalf
4012               enddo
4013             enddo
4014             if (j.eq.nres-1 .and. i.lt.j-2) then
4015               do k=1,4
4016                 do l=1,3
4017                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4018                 enddo
4019               enddo
4020             endif
4021           endif
4022 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4023       return
4024       end
4025 C-----------------------------------------------------------------------------
4026       subroutine eturn3(i,eello_turn3)
4027 C Third- and fourth-order contributions from turns
4028       implicit real*8 (a-h,o-z)
4029       include 'DIMENSIONS'
4030       include 'COMMON.IOUNITS'
4031       include 'COMMON.GEO'
4032       include 'COMMON.VAR'
4033       include 'COMMON.LOCAL'
4034       include 'COMMON.CHAIN'
4035       include 'COMMON.DERIV'
4036       include 'COMMON.INTERACT'
4037       include 'COMMON.CONTACTS'
4038       include 'COMMON.TORSION'
4039       include 'COMMON.VECTORS'
4040       include 'COMMON.FFIELD'
4041       include 'COMMON.CONTROL'
4042       dimension ggg(3)
4043       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4044      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4045      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4046      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4047      &  auxgmat2(2,2),auxgmatt2(2,2)
4048       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4049      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4050       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4051      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4052      &    num_conti,j1,j2
4053       j=i+2
4054 c      write (iout,*) "eturn3",i,j,j1,j2
4055       a_temp(1,1)=a22
4056       a_temp(1,2)=a23
4057       a_temp(2,1)=a32
4058       a_temp(2,2)=a33
4059 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4060 C
4061 C               Third-order contributions
4062 C
4063 C                 (i+2)o----(i+3)
4064 C                      | |
4065 C                      | |
4066 C                 (i+1)o----i
4067 C
4068 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4069 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4070         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4071 c auxalary matices for theta gradient
4072 c auxalary matrix for i+1 and constant i+2
4073         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4074 c auxalary matrix for i+2 and constant i+1
4075         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4076         call transpose2(auxmat(1,1),auxmat1(1,1))
4077         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4078         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4079         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4080         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4081         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4082         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4083 C Derivatives in theta
4084         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4085      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4086         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4087      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4088
4089         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4090      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4091 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4092 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4093 cd     &    ' eello_turn3_num',4*eello_turn3_num
4094 C Derivatives in gamma(i)
4095         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4096         call transpose2(auxmat2(1,1),auxmat3(1,1))
4097         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4098         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4099 C Derivatives in gamma(i+1)
4100         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4101         call transpose2(auxmat2(1,1),auxmat3(1,1))
4102         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4103         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4104      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4105 C Cartesian derivatives
4106         do l=1,3
4107 c            ghalf1=0.5d0*agg(l,1)
4108 c            ghalf2=0.5d0*agg(l,2)
4109 c            ghalf3=0.5d0*agg(l,3)
4110 c            ghalf4=0.5d0*agg(l,4)
4111           a_temp(1,1)=aggi(l,1)!+ghalf1
4112           a_temp(1,2)=aggi(l,2)!+ghalf2
4113           a_temp(2,1)=aggi(l,3)!+ghalf3
4114           a_temp(2,2)=aggi(l,4)!+ghalf4
4115           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4116           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4117      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4118           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4119           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4120           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4121           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4122           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4123           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4124      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4125           a_temp(1,1)=aggj(l,1)!+ghalf1
4126           a_temp(1,2)=aggj(l,2)!+ghalf2
4127           a_temp(2,1)=aggj(l,3)!+ghalf3
4128           a_temp(2,2)=aggj(l,4)!+ghalf4
4129           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4130           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4131      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4132           a_temp(1,1)=aggj1(l,1)
4133           a_temp(1,2)=aggj1(l,2)
4134           a_temp(2,1)=aggj1(l,3)
4135           a_temp(2,2)=aggj1(l,4)
4136           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4137           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4138      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4139         enddo
4140       return
4141       end
4142 C-------------------------------------------------------------------------------
4143       subroutine eturn4(i,eello_turn4)
4144 C Third- and fourth-order contributions from turns
4145       implicit real*8 (a-h,o-z)
4146       include 'DIMENSIONS'
4147       include 'COMMON.IOUNITS'
4148       include 'COMMON.GEO'
4149       include 'COMMON.VAR'
4150       include 'COMMON.LOCAL'
4151       include 'COMMON.CHAIN'
4152       include 'COMMON.DERIV'
4153       include 'COMMON.INTERACT'
4154       include 'COMMON.CONTACTS'
4155       include 'COMMON.TORSION'
4156       include 'COMMON.VECTORS'
4157       include 'COMMON.FFIELD'
4158       include 'COMMON.CONTROL'
4159       dimension ggg(3)
4160       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4161      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4162      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4163      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4164      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4165      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4166      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4167       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4168      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4169       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4170      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4171      &    num_conti,j1,j2
4172       j=i+3
4173 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4174 C
4175 C               Fourth-order contributions
4176 C
4177 C                 (i+3)o----(i+4)
4178 C                     /  |
4179 C               (i+2)o   |
4180 C                     \  |
4181 C                 (i+1)o----i
4182 C
4183 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4184 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4185 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4186 c        write(iout,*)"WCHODZE W PROGRAM"
4187         a_temp(1,1)=a22
4188         a_temp(1,2)=a23
4189         a_temp(2,1)=a32
4190         a_temp(2,2)=a33
4191         iti1=itortyp(itype(i+1))
4192         iti2=itortyp(itype(i+2))
4193         iti3=itortyp(itype(i+3))
4194 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4195         call transpose2(EUg(1,1,i+1),e1t(1,1))
4196         call transpose2(Eug(1,1,i+2),e2t(1,1))
4197         call transpose2(Eug(1,1,i+3),e3t(1,1))
4198 C Ematrix derivative in theta
4199         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4200         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4201         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4202         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4203 c       eta1 in derivative theta
4204         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4205         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4206 c       auxgvec is derivative of Ub2 so i+3 theta
4207         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4208 c       auxalary matrix of E i+1
4209         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4210 c        s1=0.0
4211 c        gs1=0.0
4212         s1=scalar2(b1(1,i+2),auxvec(1))
4213 c derivative of theta i+2 with constant i+3
4214         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4215 c derivative of theta i+2 with constant i+2
4216         gs32=scalar2(b1(1,i+2),auxgvec(1))
4217 c derivative of E matix in theta of i+1
4218         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4219
4220         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4221 c       ea31 in derivative theta
4222         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4223         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4224 c auxilary matrix auxgvec of Ub2 with constant E matirx
4225         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4226 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4227         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4228
4229 c        s2=0.0
4230 c        gs2=0.0
4231         s2=scalar2(b1(1,i+1),auxvec(1))
4232 c derivative of theta i+1 with constant i+3
4233         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4234 c derivative of theta i+2 with constant i+1
4235         gs21=scalar2(b1(1,i+1),auxgvec(1))
4236 c derivative of theta i+3 with constant i+1
4237         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4238 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4239 c     &  gtb1(1,i+1)
4240         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4241 c two derivatives over diffetent matrices
4242 c gtae3e2 is derivative over i+3
4243         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4244 c ae3gte2 is derivative over i+2
4245         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4246         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4247 c three possible derivative over theta E matices
4248 c i+1
4249         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4250 c i+2
4251         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4252 c i+3
4253         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4254         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4255
4256         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4257         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4258         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4259
4260         eello_turn4=eello_turn4-(s1+s2+s3)
4261 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4262         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4263      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4264 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4265 cd     &    ' eello_turn4_num',8*eello_turn4_num
4266 #ifdef NEWCORR
4267         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4268      &                  -(gs13+gsE13+gsEE1)*wturn4
4269         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4270      &                    -(gs23+gs21+gsEE2)*wturn4
4271         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4272      &                    -(gs32+gsE31+gsEE3)*wturn4
4273 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4274 c     &   gs2
4275 #endif
4276         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4277      &      'eturn4',i,j,-(s1+s2+s3)
4278 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4279 c     &    ' eello_turn4_num',8*eello_turn4_num
4280 C Derivatives in gamma(i)
4281         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4282         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4283         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4284         s1=scalar2(b1(1,i+2),auxvec(1))
4285         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4286         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4287         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4288 C Derivatives in gamma(i+1)
4289         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4290         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4291         s2=scalar2(b1(1,i+1),auxvec(1))
4292         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4293         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4294         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4295         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4296 C Derivatives in gamma(i+2)
4297         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4298         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4299         s1=scalar2(b1(1,i+2),auxvec(1))
4300         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4301         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4302         s2=scalar2(b1(1,i+1),auxvec(1))
4303         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4304         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4305         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4306         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4307 C Cartesian derivatives
4308 C Derivatives of this turn contributions in DC(i+2)
4309         if (j.lt.nres-1) then
4310           do l=1,3
4311             a_temp(1,1)=agg(l,1)
4312             a_temp(1,2)=agg(l,2)
4313             a_temp(2,1)=agg(l,3)
4314             a_temp(2,2)=agg(l,4)
4315             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4316             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4317             s1=scalar2(b1(1,i+2),auxvec(1))
4318             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4319             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4320             s2=scalar2(b1(1,i+1),auxvec(1))
4321             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4322             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4323             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4324             ggg(l)=-(s1+s2+s3)
4325             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4326           enddo
4327         endif
4328 C Remaining derivatives of this turn contribution
4329         do l=1,3
4330           a_temp(1,1)=aggi(l,1)
4331           a_temp(1,2)=aggi(l,2)
4332           a_temp(2,1)=aggi(l,3)
4333           a_temp(2,2)=aggi(l,4)
4334           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4335           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4336           s1=scalar2(b1(1,i+2),auxvec(1))
4337           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4338           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4339           s2=scalar2(b1(1,i+1),auxvec(1))
4340           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4341           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4342           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4343           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4344           a_temp(1,1)=aggi1(l,1)
4345           a_temp(1,2)=aggi1(l,2)
4346           a_temp(2,1)=aggi1(l,3)
4347           a_temp(2,2)=aggi1(l,4)
4348           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4349           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4350           s1=scalar2(b1(1,i+2),auxvec(1))
4351           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4352           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4353           s2=scalar2(b1(1,i+1),auxvec(1))
4354           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4355           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4356           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4357           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4358           a_temp(1,1)=aggj(l,1)
4359           a_temp(1,2)=aggj(l,2)
4360           a_temp(2,1)=aggj(l,3)
4361           a_temp(2,2)=aggj(l,4)
4362           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4363           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4364           s1=scalar2(b1(1,i+2),auxvec(1))
4365           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4366           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4367           s2=scalar2(b1(1,i+1),auxvec(1))
4368           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4369           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4370           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4371           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4372           a_temp(1,1)=aggj1(l,1)
4373           a_temp(1,2)=aggj1(l,2)
4374           a_temp(2,1)=aggj1(l,3)
4375           a_temp(2,2)=aggj1(l,4)
4376           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4377           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4378           s1=scalar2(b1(1,i+2),auxvec(1))
4379           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4380           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4381           s2=scalar2(b1(1,i+1),auxvec(1))
4382           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4383           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4384           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4385 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4386           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4387         enddo
4388       return
4389       end
4390 C-----------------------------------------------------------------------------
4391       subroutine vecpr(u,v,w)
4392       implicit real*8(a-h,o-z)
4393       dimension u(3),v(3),w(3)
4394       w(1)=u(2)*v(3)-u(3)*v(2)
4395       w(2)=-u(1)*v(3)+u(3)*v(1)
4396       w(3)=u(1)*v(2)-u(2)*v(1)
4397       return
4398       end
4399 C-----------------------------------------------------------------------------
4400       subroutine unormderiv(u,ugrad,unorm,ungrad)
4401 C This subroutine computes the derivatives of a normalized vector u, given
4402 C the derivatives computed without normalization conditions, ugrad. Returns
4403 C ungrad.
4404       implicit none
4405       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4406       double precision vec(3)
4407       double precision scalar
4408       integer i,j
4409 c      write (2,*) 'ugrad',ugrad
4410 c      write (2,*) 'u',u
4411       do i=1,3
4412         vec(i)=scalar(ugrad(1,i),u(1))
4413       enddo
4414 c      write (2,*) 'vec',vec
4415       do i=1,3
4416         do j=1,3
4417           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4418         enddo
4419       enddo
4420 c      write (2,*) 'ungrad',ungrad
4421       return
4422       end
4423 C-----------------------------------------------------------------------------
4424       subroutine escp_soft_sphere(evdw2,evdw2_14)
4425 C
4426 C This subroutine calculates the excluded-volume interaction energy between
4427 C peptide-group centers and side chains and its gradient in virtual-bond and
4428 C side-chain vectors.
4429 C
4430       implicit real*8 (a-h,o-z)
4431       include 'DIMENSIONS'
4432       include 'COMMON.GEO'
4433       include 'COMMON.VAR'
4434       include 'COMMON.LOCAL'
4435       include 'COMMON.CHAIN'
4436       include 'COMMON.DERIV'
4437       include 'COMMON.INTERACT'
4438       include 'COMMON.FFIELD'
4439       include 'COMMON.IOUNITS'
4440       include 'COMMON.CONTROL'
4441       dimension ggg(3)
4442       evdw2=0.0D0
4443       evdw2_14=0.0d0
4444       r0_scp=4.5d0
4445 cd    print '(a)','Enter ESCP'
4446 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4447 C      do xshift=-1,1
4448 C      do yshift=-1,1
4449 C      do zshift=-1,1
4450       do i=iatscp_s,iatscp_e
4451         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4452         iteli=itel(i)
4453         xi=0.5D0*(c(1,i)+c(1,i+1))
4454         yi=0.5D0*(c(2,i)+c(2,i+1))
4455         zi=0.5D0*(c(3,i)+c(3,i+1))
4456 C Return atom into box, boxxsize is size of box in x dimension
4457 c  134   continue
4458 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4459 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4460 C Condition for being inside the proper box
4461 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4462 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4463 c        go to 134
4464 c        endif
4465 c  135   continue
4466 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4467 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4468 C Condition for being inside the proper box
4469 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4470 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4471 c        go to 135
4472 c c       endif
4473 c  136   continue
4474 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4475 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4476 cC Condition for being inside the proper box
4477 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4478 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4479 c        go to 136
4480 c        endif
4481           xi=mod(xi,boxxsize)
4482           if (xi.lt.0) xi=xi+boxxsize
4483           yi=mod(yi,boxysize)
4484           if (yi.lt.0) yi=yi+boxysize
4485           zi=mod(zi,boxzsize)
4486           if (zi.lt.0) zi=zi+boxzsize
4487 C          xi=xi+xshift*boxxsize
4488 C          yi=yi+yshift*boxysize
4489 C          zi=zi+zshift*boxzsize
4490         do iint=1,nscp_gr(i)
4491
4492         do j=iscpstart(i,iint),iscpend(i,iint)
4493           if (itype(j).eq.ntyp1) cycle
4494           itypj=iabs(itype(j))
4495 C Uncomment following three lines for SC-p interactions
4496 c         xj=c(1,nres+j)-xi
4497 c         yj=c(2,nres+j)-yi
4498 c         zj=c(3,nres+j)-zi
4499 C Uncomment following three lines for Ca-p interactions
4500           xj=c(1,j)
4501           yj=c(2,j)
4502           zj=c(3,j)
4503 c  174   continue
4504 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4505 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4506 C Condition for being inside the proper box
4507 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4508 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4509 c        go to 174
4510 c        endif
4511 c  175   continue
4512 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4513 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4514 cC Condition for being inside the proper box
4515 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4516 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4517 c        go to 175
4518 c        endif
4519 c  176   continue
4520 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4521 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4522 C Condition for being inside the proper box
4523 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4524 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4525 c        go to 176
4526           xj=mod(xj,boxxsize)
4527           if (xj.lt.0) xj=xj+boxxsize
4528           yj=mod(yj,boxysize)
4529           if (yj.lt.0) yj=yj+boxysize
4530           zj=mod(zj,boxzsize)
4531           if (zj.lt.0) zj=zj+boxzsize
4532       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4533       xj_safe=xj
4534       yj_safe=yj
4535       zj_safe=zj
4536       subchap=0
4537       do xshift=-1,1
4538       do yshift=-1,1
4539       do zshift=-1,1
4540           xj=xj_safe+xshift*boxxsize
4541           yj=yj_safe+yshift*boxysize
4542           zj=zj_safe+zshift*boxzsize
4543           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4544           if(dist_temp.lt.dist_init) then
4545             dist_init=dist_temp
4546             xj_temp=xj
4547             yj_temp=yj
4548             zj_temp=zj
4549             subchap=1
4550           endif
4551        enddo
4552        enddo
4553        enddo
4554        if (subchap.eq.1) then
4555           xj=xj_temp-xi
4556           yj=yj_temp-yi
4557           zj=zj_temp-zi
4558        else
4559           xj=xj_safe-xi
4560           yj=yj_safe-yi
4561           zj=zj_safe-zi
4562        endif
4563 c c       endif
4564 C          xj=xj-xi
4565 C          yj=yj-yi
4566 C          zj=zj-zi
4567           rij=xj*xj+yj*yj+zj*zj
4568
4569           r0ij=r0_scp
4570           r0ijsq=r0ij*r0ij
4571           if (rij.lt.r0ijsq) then
4572             evdwij=0.25d0*(rij-r0ijsq)**2
4573             fac=rij-r0ijsq
4574           else
4575             evdwij=0.0d0
4576             fac=0.0d0
4577           endif
4578           evdw2=evdw2+evdwij
4579 C
4580 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4581 C
4582           ggg(1)=xj*fac
4583           ggg(2)=yj*fac
4584           ggg(3)=zj*fac
4585 cgrad          if (j.lt.i) then
4586 cd          write (iout,*) 'j<i'
4587 C Uncomment following three lines for SC-p interactions
4588 c           do k=1,3
4589 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4590 c           enddo
4591 cgrad          else
4592 cd          write (iout,*) 'j>i'
4593 cgrad            do k=1,3
4594 cgrad              ggg(k)=-ggg(k)
4595 C Uncomment following line for SC-p interactions
4596 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4597 cgrad            enddo
4598 cgrad          endif
4599 cgrad          do k=1,3
4600 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4601 cgrad          enddo
4602 cgrad          kstart=min0(i+1,j)
4603 cgrad          kend=max0(i-1,j-1)
4604 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4605 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4606 cgrad          do k=kstart,kend
4607 cgrad            do l=1,3
4608 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4609 cgrad            enddo
4610 cgrad          enddo
4611           do k=1,3
4612             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4613             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4614           enddo
4615         enddo
4616
4617         enddo ! iint
4618       enddo ! i
4619 C      enddo !zshift
4620 C      enddo !yshift
4621 C      enddo !xshift
4622       return
4623       end
4624 C-----------------------------------------------------------------------------
4625       subroutine escp(evdw2,evdw2_14)
4626 C
4627 C This subroutine calculates the excluded-volume interaction energy between
4628 C peptide-group centers and side chains and its gradient in virtual-bond and
4629 C side-chain vectors.
4630 C
4631       implicit real*8 (a-h,o-z)
4632       include 'DIMENSIONS'
4633       include 'COMMON.GEO'
4634       include 'COMMON.VAR'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.CHAIN'
4637       include 'COMMON.DERIV'
4638       include 'COMMON.INTERACT'
4639       include 'COMMON.FFIELD'
4640       include 'COMMON.IOUNITS'
4641       include 'COMMON.CONTROL'
4642       include 'COMMON.SPLITELE'
4643       dimension ggg(3)
4644       evdw2=0.0D0
4645       evdw2_14=0.0d0
4646 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4647 cd    print '(a)','Enter ESCP'
4648 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4649 C      do xshift=-1,1
4650 C      do yshift=-1,1
4651 C      do zshift=-1,1
4652       do i=iatscp_s,iatscp_e
4653         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4654         iteli=itel(i)
4655         xi=0.5D0*(c(1,i)+c(1,i+1))
4656         yi=0.5D0*(c(2,i)+c(2,i+1))
4657         zi=0.5D0*(c(3,i)+c(3,i+1))
4658           xi=mod(xi,boxxsize)
4659           if (xi.lt.0) xi=xi+boxxsize
4660           yi=mod(yi,boxysize)
4661           if (yi.lt.0) yi=yi+boxysize
4662           zi=mod(zi,boxzsize)
4663           if (zi.lt.0) zi=zi+boxzsize
4664 c          xi=xi+xshift*boxxsize
4665 c          yi=yi+yshift*boxysize
4666 c          zi=zi+zshift*boxzsize
4667 c        print *,xi,yi,zi,'polozenie i'
4668 C Return atom into box, boxxsize is size of box in x dimension
4669 c  134   continue
4670 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4671 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4672 C Condition for being inside the proper box
4673 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4674 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4675 c        go to 134
4676 c        endif
4677 c  135   continue
4678 c          print *,xi,boxxsize,"pierwszy"
4679
4680 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4681 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4682 C Condition for being inside the proper box
4683 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4684 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4685 c        go to 135
4686 c        endif
4687 c  136   continue
4688 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4689 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4690 C Condition for being inside the proper box
4691 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4692 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4693 c        go to 136
4694 c        endif
4695         do iint=1,nscp_gr(i)
4696
4697         do j=iscpstart(i,iint),iscpend(i,iint)
4698           itypj=iabs(itype(j))
4699           if (itypj.eq.ntyp1) cycle
4700 C Uncomment following three lines for SC-p interactions
4701 c         xj=c(1,nres+j)-xi
4702 c         yj=c(2,nres+j)-yi
4703 c         zj=c(3,nres+j)-zi
4704 C Uncomment following three lines for Ca-p interactions
4705           xj=c(1,j)
4706           yj=c(2,j)
4707           zj=c(3,j)
4708           xj=mod(xj,boxxsize)
4709           if (xj.lt.0) xj=xj+boxxsize
4710           yj=mod(yj,boxysize)
4711           if (yj.lt.0) yj=yj+boxysize
4712           zj=mod(zj,boxzsize)
4713           if (zj.lt.0) zj=zj+boxzsize
4714 c  174   continue
4715 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4716 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4717 C Condition for being inside the proper box
4718 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4719 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4720 c        go to 174
4721 c        endif
4722 c  175   continue
4723 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4724 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4725 cC Condition for being inside the proper box
4726 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4727 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4728 c        go to 175
4729 c        endif
4730 c  176   continue
4731 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4732 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4733 C Condition for being inside the proper box
4734 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4735 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4736 c        go to 176
4737 c        endif
4738 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4739       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4740       xj_safe=xj
4741       yj_safe=yj
4742       zj_safe=zj
4743       subchap=0
4744       do xshift=-1,1
4745       do yshift=-1,1
4746       do zshift=-1,1
4747           xj=xj_safe+xshift*boxxsize
4748           yj=yj_safe+yshift*boxysize
4749           zj=zj_safe+zshift*boxzsize
4750           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4751           if(dist_temp.lt.dist_init) then
4752             dist_init=dist_temp
4753             xj_temp=xj
4754             yj_temp=yj
4755             zj_temp=zj
4756             subchap=1
4757           endif
4758        enddo
4759        enddo
4760        enddo
4761        if (subchap.eq.1) then
4762           xj=xj_temp-xi
4763           yj=yj_temp-yi
4764           zj=zj_temp-zi
4765        else
4766           xj=xj_safe-xi
4767           yj=yj_safe-yi
4768           zj=zj_safe-zi
4769        endif
4770 c          print *,xj,yj,zj,'polozenie j'
4771           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4772 c          print *,rrij
4773           sss=sscale(1.0d0/(dsqrt(rrij)))
4774 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4775 c          if (sss.eq.0) print *,'czasem jest OK'
4776           if (sss.le.0.0d0) cycle
4777           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4778           fac=rrij**expon2
4779           e1=fac*fac*aad(itypj,iteli)
4780           e2=fac*bad(itypj,iteli)
4781           if (iabs(j-i) .le. 2) then
4782             e1=scal14*e1
4783             e2=scal14*e2
4784             evdw2_14=evdw2_14+(e1+e2)*sss
4785           endif
4786           evdwij=e1+e2
4787           evdw2=evdw2+evdwij*sss
4788           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4789      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4790      &       bad(itypj,iteli)
4791 C
4792 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4793 C
4794           fac=-(evdwij+e1)*rrij*sss
4795           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4796           ggg(1)=xj*fac
4797           ggg(2)=yj*fac
4798           ggg(3)=zj*fac
4799 cgrad          if (j.lt.i) then
4800 cd          write (iout,*) 'j<i'
4801 C Uncomment following three lines for SC-p interactions
4802 c           do k=1,3
4803 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4804 c           enddo
4805 cgrad          else
4806 cd          write (iout,*) 'j>i'
4807 cgrad            do k=1,3
4808 cgrad              ggg(k)=-ggg(k)
4809 C Uncomment following line for SC-p interactions
4810 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4811 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4812 cgrad            enddo
4813 cgrad          endif
4814 cgrad          do k=1,3
4815 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4816 cgrad          enddo
4817 cgrad          kstart=min0(i+1,j)
4818 cgrad          kend=max0(i-1,j-1)
4819 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4820 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4821 cgrad          do k=kstart,kend
4822 cgrad            do l=1,3
4823 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4824 cgrad            enddo
4825 cgrad          enddo
4826           do k=1,3
4827             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4828             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4829           enddo
4830 c        endif !endif for sscale cutoff
4831         enddo ! j
4832
4833         enddo ! iint
4834       enddo ! i
4835 c      enddo !zshift
4836 c      enddo !yshift
4837 c      enddo !xshift
4838       do i=1,nct
4839         do j=1,3
4840           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4841           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4842           gradx_scp(j,i)=expon*gradx_scp(j,i)
4843         enddo
4844       enddo
4845 C******************************************************************************
4846 C
4847 C                              N O T E !!!
4848 C
4849 C To save time the factor EXPON has been extracted from ALL components
4850 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4851 C use!
4852 C
4853 C******************************************************************************
4854       return
4855       end
4856 C--------------------------------------------------------------------------
4857       subroutine edis(ehpb)
4858 C
4859 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4860 C
4861       implicit real*8 (a-h,o-z)
4862       include 'DIMENSIONS'
4863       include 'COMMON.SBRIDGE'
4864       include 'COMMON.CHAIN'
4865       include 'COMMON.DERIV'
4866       include 'COMMON.VAR'
4867       include 'COMMON.INTERACT'
4868       include 'COMMON.IOUNITS'
4869       dimension ggg(3)
4870       ehpb=0.0D0
4871 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4872 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4873       if (link_end.eq.0) return
4874       do i=link_start,link_end
4875 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4876 C CA-CA distance used in regularization of structure.
4877         ii=ihpb(i)
4878         jj=jhpb(i)
4879 C iii and jjj point to the residues for which the distance is assigned.
4880         if (ii.gt.nres) then
4881           iii=ii-nres
4882           jjj=jj-nres
4883         else
4884           iii=ii
4885           jjj=jj
4886         endif
4887 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4888 c     &    dhpb(i),dhpb1(i),forcon(i)
4889 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4890 C    distance and angle dependent SS bond potential.
4891         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4892      & iabs(itype(jjj)).eq.1) then
4893 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4894 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4895         if (.not.dyn_ss .and. i.le.nss) then
4896 C 15/02/13 CC dynamic SSbond - additional check
4897          if (ii.gt.nres
4898      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4899           call ssbond_ene(iii,jjj,eij)
4900           ehpb=ehpb+2*eij
4901          endif
4902 cd          write (iout,*) "eij",eij
4903         else
4904 C Calculate the distance between the two points and its difference from the
4905 C target distance.
4906           dd=dist(ii,jj)
4907             rdis=dd-dhpb(i)
4908 C Get the force constant corresponding to this distance.
4909             waga=forcon(i)
4910 C Calculate the contribution to energy.
4911             ehpb=ehpb+waga*rdis*rdis
4912 C
4913 C Evaluate gradient.
4914 C
4915             fac=waga*rdis/dd
4916 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4917 cd   &   ' waga=',waga,' fac=',fac
4918             do j=1,3
4919               ggg(j)=fac*(c(j,jj)-c(j,ii))
4920             enddo
4921 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4922 C If this is a SC-SC distance, we need to calculate the contributions to the
4923 C Cartesian gradient in the SC vectors (ghpbx).
4924           if (iii.lt.ii) then
4925           do j=1,3
4926             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4927             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4928           enddo
4929           endif
4930 cgrad        do j=iii,jjj-1
4931 cgrad          do k=1,3
4932 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4933 cgrad          enddo
4934 cgrad        enddo
4935           do k=1,3
4936             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4937             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4938           enddo
4939         endif
4940        endif
4941       enddo
4942       ehpb=0.5D0*ehpb
4943       return
4944       end
4945 C--------------------------------------------------------------------------
4946       subroutine ssbond_ene(i,j,eij)
4947 C
4948 C Calculate the distance and angle dependent SS-bond potential energy
4949 C using a free-energy function derived based on RHF/6-31G** ab initio
4950 C calculations of diethyl disulfide.
4951 C
4952 C A. Liwo and U. Kozlowska, 11/24/03
4953 C
4954       implicit real*8 (a-h,o-z)
4955       include 'DIMENSIONS'
4956       include 'COMMON.SBRIDGE'
4957       include 'COMMON.CHAIN'
4958       include 'COMMON.DERIV'
4959       include 'COMMON.LOCAL'
4960       include 'COMMON.INTERACT'
4961       include 'COMMON.VAR'
4962       include 'COMMON.IOUNITS'
4963       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4964       itypi=iabs(itype(i))
4965       xi=c(1,nres+i)
4966       yi=c(2,nres+i)
4967       zi=c(3,nres+i)
4968       dxi=dc_norm(1,nres+i)
4969       dyi=dc_norm(2,nres+i)
4970       dzi=dc_norm(3,nres+i)
4971 c      dsci_inv=dsc_inv(itypi)
4972       dsci_inv=vbld_inv(nres+i)
4973       itypj=iabs(itype(j))
4974 c      dscj_inv=dsc_inv(itypj)
4975       dscj_inv=vbld_inv(nres+j)
4976       xj=c(1,nres+j)-xi
4977       yj=c(2,nres+j)-yi
4978       zj=c(3,nres+j)-zi
4979       dxj=dc_norm(1,nres+j)
4980       dyj=dc_norm(2,nres+j)
4981       dzj=dc_norm(3,nres+j)
4982       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4983       rij=dsqrt(rrij)
4984       erij(1)=xj*rij
4985       erij(2)=yj*rij
4986       erij(3)=zj*rij
4987       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4988       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4989       om12=dxi*dxj+dyi*dyj+dzi*dzj
4990       do k=1,3
4991         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4992         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4993       enddo
4994       rij=1.0d0/rij
4995       deltad=rij-d0cm
4996       deltat1=1.0d0-om1
4997       deltat2=1.0d0+om2
4998       deltat12=om2-om1+2.0d0
4999       cosphi=om12-om1*om2
5000       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5001      &  +akct*deltad*deltat12
5002      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5003 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5004 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5005 c     &  " deltat12",deltat12," eij",eij
5006       ed=2*akcm*deltad+akct*deltat12
5007       pom1=akct*deltad
5008       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5009       eom1=-2*akth*deltat1-pom1-om2*pom2
5010       eom2= 2*akth*deltat2+pom1-om1*pom2
5011       eom12=pom2
5012       do k=1,3
5013         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5014         ghpbx(k,i)=ghpbx(k,i)-ggk
5015      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5016      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5017         ghpbx(k,j)=ghpbx(k,j)+ggk
5018      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5019      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5020         ghpbc(k,i)=ghpbc(k,i)-ggk
5021         ghpbc(k,j)=ghpbc(k,j)+ggk
5022       enddo
5023 C
5024 C Calculate the components of the gradient in DC and X
5025 C
5026 cgrad      do k=i,j-1
5027 cgrad        do l=1,3
5028 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5029 cgrad        enddo
5030 cgrad      enddo
5031       return
5032       end
5033 C--------------------------------------------------------------------------
5034       subroutine ebond(estr)
5035 c
5036 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5037 c
5038       implicit real*8 (a-h,o-z)
5039       include 'DIMENSIONS'
5040       include 'COMMON.LOCAL'
5041       include 'COMMON.GEO'
5042       include 'COMMON.INTERACT'
5043       include 'COMMON.DERIV'
5044       include 'COMMON.VAR'
5045       include 'COMMON.CHAIN'
5046       include 'COMMON.IOUNITS'
5047       include 'COMMON.NAMES'
5048       include 'COMMON.FFIELD'
5049       include 'COMMON.CONTROL'
5050       include 'COMMON.SETUP'
5051       double precision u(3),ud(3)
5052       estr=0.0d0
5053       estr1=0.0d0
5054       do i=ibondp_start,ibondp_end
5055         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5056 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5057 c          do j=1,3
5058 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5059 c     &      *dc(j,i-1)/vbld(i)
5060 c          enddo
5061 c          if (energy_dec) write(iout,*)
5062 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5063 c        else
5064 C       Checking if it involves dummy (NH3+ or COO-) group
5065          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5066 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5067         diff = vbld(i)-vbldpDUM
5068          else
5069 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5070         diff = vbld(i)-vbldp0
5071          endif
5072         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5073      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5074         estr=estr+diff*diff
5075         do j=1,3
5076           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5077         enddo
5078 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5079 c        endif
5080       enddo
5081       estr=0.5d0*AKP*estr+estr1
5082 c
5083 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5084 c
5085       do i=ibond_start,ibond_end
5086         iti=iabs(itype(i))
5087         if (iti.ne.10 .and. iti.ne.ntyp1) then
5088           nbi=nbondterm(iti)
5089           if (nbi.eq.1) then
5090             diff=vbld(i+nres)-vbldsc0(1,iti)
5091             if (energy_dec)  write (iout,*)
5092      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5093      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5094             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5095             do j=1,3
5096               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5097             enddo
5098           else
5099             do j=1,nbi
5100               diff=vbld(i+nres)-vbldsc0(j,iti)
5101               ud(j)=aksc(j,iti)*diff
5102               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5103             enddo
5104             uprod=u(1)
5105             do j=2,nbi
5106               uprod=uprod*u(j)
5107             enddo
5108             usum=0.0d0
5109             usumsqder=0.0d0
5110             do j=1,nbi
5111               uprod1=1.0d0
5112               uprod2=1.0d0
5113               do k=1,nbi
5114                 if (k.ne.j) then
5115                   uprod1=uprod1*u(k)
5116                   uprod2=uprod2*u(k)*u(k)
5117                 endif
5118               enddo
5119               usum=usum+uprod1
5120               usumsqder=usumsqder+ud(j)*uprod2
5121             enddo
5122             estr=estr+uprod/usum
5123             do j=1,3
5124              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5125             enddo
5126           endif
5127         endif
5128       enddo
5129       return
5130       end
5131 #ifdef CRYST_THETA
5132 C--------------------------------------------------------------------------
5133       subroutine ebend(etheta)
5134 C
5135 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5136 C angles gamma and its derivatives in consecutive thetas and gammas.
5137 C
5138       implicit real*8 (a-h,o-z)
5139       include 'DIMENSIONS'
5140       include 'COMMON.LOCAL'
5141       include 'COMMON.GEO'
5142       include 'COMMON.INTERACT'
5143       include 'COMMON.DERIV'
5144       include 'COMMON.VAR'
5145       include 'COMMON.CHAIN'
5146       include 'COMMON.IOUNITS'
5147       include 'COMMON.NAMES'
5148       include 'COMMON.FFIELD'
5149       include 'COMMON.CONTROL'
5150       common /calcthet/ term1,term2,termm,diffak,ratak,
5151      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5152      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5153       double precision y(2),z(2)
5154       delta=0.02d0*pi
5155 c      time11=dexp(-2*time)
5156 c      time12=1.0d0
5157       etheta=0.0D0
5158 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5159       do i=ithet_start,ithet_end
5160         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5161      &  .or.itype(i).eq.ntyp1) cycle
5162 C Zero the energy function and its derivative at 0 or pi.
5163         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5164         it=itype(i-1)
5165         ichir1=isign(1,itype(i-2))
5166         ichir2=isign(1,itype(i))
5167          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5168          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5169          if (itype(i-1).eq.10) then
5170           itype1=isign(10,itype(i-2))
5171           ichir11=isign(1,itype(i-2))
5172           ichir12=isign(1,itype(i-2))
5173           itype2=isign(10,itype(i))
5174           ichir21=isign(1,itype(i))
5175           ichir22=isign(1,itype(i))
5176          endif
5177
5178         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5179 #ifdef OSF
5180           phii=phi(i)
5181           if (phii.ne.phii) phii=150.0
5182 #else
5183           phii=phi(i)
5184 #endif
5185           y(1)=dcos(phii)
5186           y(2)=dsin(phii)
5187         else
5188           y(1)=0.0D0
5189           y(2)=0.0D0
5190         endif
5191         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5192 #ifdef OSF
5193           phii1=phi(i+1)
5194           if (phii1.ne.phii1) phii1=150.0
5195           phii1=pinorm(phii1)
5196           z(1)=cos(phii1)
5197 #else
5198           phii1=phi(i+1)
5199 #endif
5200           z(1)=dcos(phii1)
5201           z(2)=dsin(phii1)
5202         else
5203           z(1)=0.0D0
5204           z(2)=0.0D0
5205         endif
5206 C Calculate the "mean" value of theta from the part of the distribution
5207 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5208 C In following comments this theta will be referred to as t_c.
5209         thet_pred_mean=0.0d0
5210         do k=1,2
5211             athetk=athet(k,it,ichir1,ichir2)
5212             bthetk=bthet(k,it,ichir1,ichir2)
5213           if (it.eq.10) then
5214              athetk=athet(k,itype1,ichir11,ichir12)
5215              bthetk=bthet(k,itype2,ichir21,ichir22)
5216           endif
5217          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5218 c         write(iout,*) 'chuj tu', y(k),z(k)
5219         enddo
5220         dthett=thet_pred_mean*ssd
5221         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5222 C Derivatives of the "mean" values in gamma1 and gamma2.
5223         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5224      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5225          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5226      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5227          if (it.eq.10) then
5228       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5229      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5230         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5231      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5232          endif
5233         if (theta(i).gt.pi-delta) then
5234           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5235      &         E_tc0)
5236           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5237           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5238           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5239      &        E_theta)
5240           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5241      &        E_tc)
5242         else if (theta(i).lt.delta) then
5243           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5244           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5245           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5246      &        E_theta)
5247           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5248           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5249      &        E_tc)
5250         else
5251           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5252      &        E_theta,E_tc)
5253         endif
5254         etheta=etheta+ethetai
5255         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5256      &      'ebend',i,ethetai,theta(i),itype(i)
5257         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5258         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5259         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5260       enddo
5261 C Ufff.... We've done all this!!!
5262       return
5263       end
5264 C---------------------------------------------------------------------------
5265       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5266      &     E_tc)
5267       implicit real*8 (a-h,o-z)
5268       include 'DIMENSIONS'
5269       include 'COMMON.LOCAL'
5270       include 'COMMON.IOUNITS'
5271       common /calcthet/ term1,term2,termm,diffak,ratak,
5272      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5273      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5274 C Calculate the contributions to both Gaussian lobes.
5275 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5276 C The "polynomial part" of the "standard deviation" of this part of
5277 C the distributioni.
5278 ccc        write (iout,*) thetai,thet_pred_mean
5279         sig=polthet(3,it)
5280         do j=2,0,-1
5281           sig=sig*thet_pred_mean+polthet(j,it)
5282         enddo
5283 C Derivative of the "interior part" of the "standard deviation of the"
5284 C gamma-dependent Gaussian lobe in t_c.
5285         sigtc=3*polthet(3,it)
5286         do j=2,1,-1
5287           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5288         enddo
5289         sigtc=sig*sigtc
5290 C Set the parameters of both Gaussian lobes of the distribution.
5291 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5292         fac=sig*sig+sigc0(it)
5293         sigcsq=fac+fac
5294         sigc=1.0D0/sigcsq
5295 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5296         sigsqtc=-4.0D0*sigcsq*sigtc
5297 c       print *,i,sig,sigtc,sigsqtc
5298 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5299         sigtc=-sigtc/(fac*fac)
5300 C Following variable is sigma(t_c)**(-2)
5301         sigcsq=sigcsq*sigcsq
5302         sig0i=sig0(it)
5303         sig0inv=1.0D0/sig0i**2
5304         delthec=thetai-thet_pred_mean
5305         delthe0=thetai-theta0i
5306         term1=-0.5D0*sigcsq*delthec*delthec
5307         term2=-0.5D0*sig0inv*delthe0*delthe0
5308 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5309 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5310 C NaNs in taking the logarithm. We extract the largest exponent which is added
5311 C to the energy (this being the log of the distribution) at the end of energy
5312 C term evaluation for this virtual-bond angle.
5313         if (term1.gt.term2) then
5314           termm=term1
5315           term2=dexp(term2-termm)
5316           term1=1.0d0
5317         else
5318           termm=term2
5319           term1=dexp(term1-termm)
5320           term2=1.0d0
5321         endif
5322 C The ratio between the gamma-independent and gamma-dependent lobes of
5323 C the distribution is a Gaussian function of thet_pred_mean too.
5324         diffak=gthet(2,it)-thet_pred_mean
5325         ratak=diffak/gthet(3,it)**2
5326         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5327 C Let's differentiate it in thet_pred_mean NOW.
5328         aktc=ak*ratak
5329 C Now put together the distribution terms to make complete distribution.
5330         termexp=term1+ak*term2
5331         termpre=sigc+ak*sig0i
5332 C Contribution of the bending energy from this theta is just the -log of
5333 C the sum of the contributions from the two lobes and the pre-exponential
5334 C factor. Simple enough, isn't it?
5335         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5336 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5337 C NOW the derivatives!!!
5338 C 6/6/97 Take into account the deformation.
5339         E_theta=(delthec*sigcsq*term1
5340      &       +ak*delthe0*sig0inv*term2)/termexp
5341         E_tc=((sigtc+aktc*sig0i)/termpre
5342      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5343      &       aktc*term2)/termexp)
5344       return
5345       end
5346 c-----------------------------------------------------------------------------
5347       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5348       implicit real*8 (a-h,o-z)
5349       include 'DIMENSIONS'
5350       include 'COMMON.LOCAL'
5351       include 'COMMON.IOUNITS'
5352       common /calcthet/ term1,term2,termm,diffak,ratak,
5353      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5354      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5355       delthec=thetai-thet_pred_mean
5356       delthe0=thetai-theta0i
5357 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5358       t3 = thetai-thet_pred_mean
5359       t6 = t3**2
5360       t9 = term1
5361       t12 = t3*sigcsq
5362       t14 = t12+t6*sigsqtc
5363       t16 = 1.0d0
5364       t21 = thetai-theta0i
5365       t23 = t21**2
5366       t26 = term2
5367       t27 = t21*t26
5368       t32 = termexp
5369       t40 = t32**2
5370       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5371      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5372      & *(-t12*t9-ak*sig0inv*t27)
5373       return
5374       end
5375 #else
5376 C--------------------------------------------------------------------------
5377       subroutine ebend(etheta)
5378 C
5379 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5380 C angles gamma and its derivatives in consecutive thetas and gammas.
5381 C ab initio-derived potentials from
5382 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5383 C
5384       implicit real*8 (a-h,o-z)
5385       include 'DIMENSIONS'
5386       include 'COMMON.LOCAL'
5387       include 'COMMON.GEO'
5388       include 'COMMON.INTERACT'
5389       include 'COMMON.DERIV'
5390       include 'COMMON.VAR'
5391       include 'COMMON.CHAIN'
5392       include 'COMMON.IOUNITS'
5393       include 'COMMON.NAMES'
5394       include 'COMMON.FFIELD'
5395       include 'COMMON.CONTROL'
5396       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5397      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5398      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5399      & sinph1ph2(maxdouble,maxdouble)
5400       logical lprn /.false./, lprn1 /.false./
5401       etheta=0.0D0
5402       do i=ithet_start,ithet_end
5403 c        print *,i,itype(i-1),itype(i),itype(i-2)
5404         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5405      &  .or.itype(i).eq.ntyp1) cycle
5406 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5407
5408         if (iabs(itype(i+1)).eq.20) iblock=2
5409         if (iabs(itype(i+1)).ne.20) iblock=1
5410         dethetai=0.0d0
5411         dephii=0.0d0
5412         dephii1=0.0d0
5413         theti2=0.5d0*theta(i)
5414         ityp2=ithetyp((itype(i-1)))
5415         do k=1,nntheterm
5416           coskt(k)=dcos(k*theti2)
5417           sinkt(k)=dsin(k*theti2)
5418         enddo
5419         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5420 #ifdef OSF
5421           phii=phi(i)
5422           if (phii.ne.phii) phii=150.0
5423 #else
5424           phii=phi(i)
5425 #endif
5426           ityp1=ithetyp((itype(i-2)))
5427 C propagation of chirality for glycine type
5428           do k=1,nsingle
5429             cosph1(k)=dcos(k*phii)
5430             sinph1(k)=dsin(k*phii)
5431           enddo
5432         else
5433           phii=0.0d0
5434           ityp1=nthetyp+1
5435           do k=1,nsingle
5436             cosph1(k)=0.0d0
5437             sinph1(k)=0.0d0
5438           enddo
5439         endif
5440         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5441 #ifdef OSF
5442           phii1=phi(i+1)
5443           if (phii1.ne.phii1) phii1=150.0
5444           phii1=pinorm(phii1)
5445 #else
5446           phii1=phi(i+1)
5447 #endif
5448           ityp3=ithetyp((itype(i)))
5449           do k=1,nsingle
5450             cosph2(k)=dcos(k*phii1)
5451             sinph2(k)=dsin(k*phii1)
5452           enddo
5453         else
5454           phii1=0.0d0
5455           ityp3=nthetyp+1
5456           do k=1,nsingle
5457             cosph2(k)=0.0d0
5458             sinph2(k)=0.0d0
5459           enddo
5460         endif
5461         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5462         do k=1,ndouble
5463           do l=1,k-1
5464             ccl=cosph1(l)*cosph2(k-l)
5465             ssl=sinph1(l)*sinph2(k-l)
5466             scl=sinph1(l)*cosph2(k-l)
5467             csl=cosph1(l)*sinph2(k-l)
5468             cosph1ph2(l,k)=ccl-ssl
5469             cosph1ph2(k,l)=ccl+ssl
5470             sinph1ph2(l,k)=scl+csl
5471             sinph1ph2(k,l)=scl-csl
5472           enddo
5473         enddo
5474         if (lprn) then
5475         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5476      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5477         write (iout,*) "coskt and sinkt"
5478         do k=1,nntheterm
5479           write (iout,*) k,coskt(k),sinkt(k)
5480         enddo
5481         endif
5482         do k=1,ntheterm
5483           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5484           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5485      &      *coskt(k)
5486           if (lprn)
5487      &    write (iout,*) "k",k,"
5488      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5489      &     " ethetai",ethetai
5490         enddo
5491         if (lprn) then
5492         write (iout,*) "cosph and sinph"
5493         do k=1,nsingle
5494           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5495         enddo
5496         write (iout,*) "cosph1ph2 and sinph2ph2"
5497         do k=2,ndouble
5498           do l=1,k-1
5499             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5500      &         sinph1ph2(l,k),sinph1ph2(k,l)
5501           enddo
5502         enddo
5503         write(iout,*) "ethetai",ethetai
5504         endif
5505         do m=1,ntheterm2
5506           do k=1,nsingle
5507             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5508      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5509      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5510      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5511             ethetai=ethetai+sinkt(m)*aux
5512             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5513             dephii=dephii+k*sinkt(m)*(
5514      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5515      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5516             dephii1=dephii1+k*sinkt(m)*(
5517      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5518      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5519             if (lprn)
5520      &      write (iout,*) "m",m," k",k," bbthet",
5521      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5522      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5523      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5524      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5525           enddo
5526         enddo
5527         if (lprn)
5528      &  write(iout,*) "ethetai",ethetai
5529         do m=1,ntheterm3
5530           do k=2,ndouble
5531             do l=1,k-1
5532               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5533      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5534      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5535      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5536               ethetai=ethetai+sinkt(m)*aux
5537               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5538               dephii=dephii+l*sinkt(m)*(
5539      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5540      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5541      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5542      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5543               dephii1=dephii1+(k-l)*sinkt(m)*(
5544      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5545      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5546      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5547      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5548               if (lprn) then
5549               write (iout,*) "m",m," k",k," l",l," ffthet",
5550      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5551      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5552      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5553      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5554      &            " ethetai",ethetai
5555               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5556      &            cosph1ph2(k,l)*sinkt(m),
5557      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5558               endif
5559             enddo
5560           enddo
5561         enddo
5562 10      continue
5563 c        lprn1=.true.
5564         if (lprn1)
5565      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5566      &   i,theta(i)*rad2deg,phii*rad2deg,
5567      &   phii1*rad2deg,ethetai
5568 c        lprn1=.false.
5569         etheta=etheta+ethetai
5570         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5571         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5572         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5573       enddo
5574       return
5575       end
5576 #endif
5577 #ifdef CRYST_SC
5578 c-----------------------------------------------------------------------------
5579       subroutine esc(escloc)
5580 C Calculate the local energy of a side chain and its derivatives in the
5581 C corresponding virtual-bond valence angles THETA and the spherical angles
5582 C ALPHA and OMEGA.
5583       implicit real*8 (a-h,o-z)
5584       include 'DIMENSIONS'
5585       include 'COMMON.GEO'
5586       include 'COMMON.LOCAL'
5587       include 'COMMON.VAR'
5588       include 'COMMON.INTERACT'
5589       include 'COMMON.DERIV'
5590       include 'COMMON.CHAIN'
5591       include 'COMMON.IOUNITS'
5592       include 'COMMON.NAMES'
5593       include 'COMMON.FFIELD'
5594       include 'COMMON.CONTROL'
5595       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5596      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5597       common /sccalc/ time11,time12,time112,theti,it,nlobit
5598       delta=0.02d0*pi
5599       escloc=0.0D0
5600 c     write (iout,'(a)') 'ESC'
5601       do i=loc_start,loc_end
5602         it=itype(i)
5603         if (it.eq.ntyp1) cycle
5604         if (it.eq.10) goto 1
5605         nlobit=nlob(iabs(it))
5606 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5607 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5608         theti=theta(i+1)-pipol
5609         x(1)=dtan(theti)
5610         x(2)=alph(i)
5611         x(3)=omeg(i)
5612
5613         if (x(2).gt.pi-delta) then
5614           xtemp(1)=x(1)
5615           xtemp(2)=pi-delta
5616           xtemp(3)=x(3)
5617           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5618           xtemp(2)=pi
5619           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5620           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5621      &        escloci,dersc(2))
5622           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5623      &        ddersc0(1),dersc(1))
5624           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5625      &        ddersc0(3),dersc(3))
5626           xtemp(2)=pi-delta
5627           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5628           xtemp(2)=pi
5629           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5630           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5631      &            dersc0(2),esclocbi,dersc02)
5632           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5633      &            dersc12,dersc01)
5634           call splinthet(x(2),0.5d0*delta,ss,ssd)
5635           dersc0(1)=dersc01
5636           dersc0(2)=dersc02
5637           dersc0(3)=0.0d0
5638           do k=1,3
5639             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5640           enddo
5641           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5642 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5643 c    &             esclocbi,ss,ssd
5644           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5645 c         escloci=esclocbi
5646 c         write (iout,*) escloci
5647         else if (x(2).lt.delta) then
5648           xtemp(1)=x(1)
5649           xtemp(2)=delta
5650           xtemp(3)=x(3)
5651           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5652           xtemp(2)=0.0d0
5653           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5654           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5655      &        escloci,dersc(2))
5656           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5657      &        ddersc0(1),dersc(1))
5658           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5659      &        ddersc0(3),dersc(3))
5660           xtemp(2)=delta
5661           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5662           xtemp(2)=0.0d0
5663           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5664           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5665      &            dersc0(2),esclocbi,dersc02)
5666           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5667      &            dersc12,dersc01)
5668           dersc0(1)=dersc01
5669           dersc0(2)=dersc02
5670           dersc0(3)=0.0d0
5671           call splinthet(x(2),0.5d0*delta,ss,ssd)
5672           do k=1,3
5673             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5674           enddo
5675           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5676 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5677 c    &             esclocbi,ss,ssd
5678           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5679 c         write (iout,*) escloci
5680         else
5681           call enesc(x,escloci,dersc,ddummy,.false.)
5682         endif
5683
5684         escloc=escloc+escloci
5685         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5686      &     'escloc',i,escloci
5687 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5688
5689         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5690      &   wscloc*dersc(1)
5691         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5692         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5693     1   continue
5694       enddo
5695       return
5696       end
5697 C---------------------------------------------------------------------------
5698       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5699       implicit real*8 (a-h,o-z)
5700       include 'DIMENSIONS'
5701       include 'COMMON.GEO'
5702       include 'COMMON.LOCAL'
5703       include 'COMMON.IOUNITS'
5704       common /sccalc/ time11,time12,time112,theti,it,nlobit
5705       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5706       double precision contr(maxlob,-1:1)
5707       logical mixed
5708 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5709         escloc_i=0.0D0
5710         do j=1,3
5711           dersc(j)=0.0D0
5712           if (mixed) ddersc(j)=0.0d0
5713         enddo
5714         x3=x(3)
5715
5716 C Because of periodicity of the dependence of the SC energy in omega we have
5717 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5718 C To avoid underflows, first compute & store the exponents.
5719
5720         do iii=-1,1
5721
5722           x(3)=x3+iii*dwapi
5723
5724           do j=1,nlobit
5725             do k=1,3
5726               z(k)=x(k)-censc(k,j,it)
5727             enddo
5728             do k=1,3
5729               Axk=0.0D0
5730               do l=1,3
5731                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5732               enddo
5733               Ax(k,j,iii)=Axk
5734             enddo
5735             expfac=0.0D0
5736             do k=1,3
5737               expfac=expfac+Ax(k,j,iii)*z(k)
5738             enddo
5739             contr(j,iii)=expfac
5740           enddo ! j
5741
5742         enddo ! iii
5743
5744         x(3)=x3
5745 C As in the case of ebend, we want to avoid underflows in exponentiation and
5746 C subsequent NaNs and INFs in energy calculation.
5747 C Find the largest exponent
5748         emin=contr(1,-1)
5749         do iii=-1,1
5750           do j=1,nlobit
5751             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5752           enddo
5753         enddo
5754         emin=0.5D0*emin
5755 cd      print *,'it=',it,' emin=',emin
5756
5757 C Compute the contribution to SC energy and derivatives
5758         do iii=-1,1
5759
5760           do j=1,nlobit
5761 #ifdef OSF
5762             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5763             if(adexp.ne.adexp) adexp=1.0
5764             expfac=dexp(adexp)
5765 #else
5766             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5767 #endif
5768 cd          print *,'j=',j,' expfac=',expfac
5769             escloc_i=escloc_i+expfac
5770             do k=1,3
5771               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5772             enddo
5773             if (mixed) then
5774               do k=1,3,2
5775                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5776      &            +gaussc(k,2,j,it))*expfac
5777               enddo
5778             endif
5779           enddo
5780
5781         enddo ! iii
5782
5783         dersc(1)=dersc(1)/cos(theti)**2
5784         ddersc(1)=ddersc(1)/cos(theti)**2
5785         ddersc(3)=ddersc(3)
5786
5787         escloci=-(dlog(escloc_i)-emin)
5788         do j=1,3
5789           dersc(j)=dersc(j)/escloc_i
5790         enddo
5791         if (mixed) then
5792           do j=1,3,2
5793             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5794           enddo
5795         endif
5796       return
5797       end
5798 C------------------------------------------------------------------------------
5799       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5800       implicit real*8 (a-h,o-z)
5801       include 'DIMENSIONS'
5802       include 'COMMON.GEO'
5803       include 'COMMON.LOCAL'
5804       include 'COMMON.IOUNITS'
5805       common /sccalc/ time11,time12,time112,theti,it,nlobit
5806       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5807       double precision contr(maxlob)
5808       logical mixed
5809
5810       escloc_i=0.0D0
5811
5812       do j=1,3
5813         dersc(j)=0.0D0
5814       enddo
5815
5816       do j=1,nlobit
5817         do k=1,2
5818           z(k)=x(k)-censc(k,j,it)
5819         enddo
5820         z(3)=dwapi
5821         do k=1,3
5822           Axk=0.0D0
5823           do l=1,3
5824             Axk=Axk+gaussc(l,k,j,it)*z(l)
5825           enddo
5826           Ax(k,j)=Axk
5827         enddo
5828         expfac=0.0D0
5829         do k=1,3
5830           expfac=expfac+Ax(k,j)*z(k)
5831         enddo
5832         contr(j)=expfac
5833       enddo ! j
5834
5835 C As in the case of ebend, we want to avoid underflows in exponentiation and
5836 C subsequent NaNs and INFs in energy calculation.
5837 C Find the largest exponent
5838       emin=contr(1)
5839       do j=1,nlobit
5840         if (emin.gt.contr(j)) emin=contr(j)
5841       enddo
5842       emin=0.5D0*emin
5843
5844 C Compute the contribution to SC energy and derivatives
5845
5846       dersc12=0.0d0
5847       do j=1,nlobit
5848         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5849         escloc_i=escloc_i+expfac
5850         do k=1,2
5851           dersc(k)=dersc(k)+Ax(k,j)*expfac
5852         enddo
5853         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5854      &            +gaussc(1,2,j,it))*expfac
5855         dersc(3)=0.0d0
5856       enddo
5857
5858       dersc(1)=dersc(1)/cos(theti)**2
5859       dersc12=dersc12/cos(theti)**2
5860       escloci=-(dlog(escloc_i)-emin)
5861       do j=1,2
5862         dersc(j)=dersc(j)/escloc_i
5863       enddo
5864       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5865       return
5866       end
5867 #else
5868 c----------------------------------------------------------------------------------
5869       subroutine esc(escloc)
5870 C Calculate the local energy of a side chain and its derivatives in the
5871 C corresponding virtual-bond valence angles THETA and the spherical angles
5872 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5873 C added by Urszula Kozlowska. 07/11/2007
5874 C
5875       implicit real*8 (a-h,o-z)
5876       include 'DIMENSIONS'
5877       include 'COMMON.GEO'
5878       include 'COMMON.LOCAL'
5879       include 'COMMON.VAR'
5880       include 'COMMON.SCROT'
5881       include 'COMMON.INTERACT'
5882       include 'COMMON.DERIV'
5883       include 'COMMON.CHAIN'
5884       include 'COMMON.IOUNITS'
5885       include 'COMMON.NAMES'
5886       include 'COMMON.FFIELD'
5887       include 'COMMON.CONTROL'
5888       include 'COMMON.VECTORS'
5889       double precision x_prime(3),y_prime(3),z_prime(3)
5890      &    , sumene,dsc_i,dp2_i,x(65),
5891      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5892      &    de_dxx,de_dyy,de_dzz,de_dt
5893       double precision s1_t,s1_6_t,s2_t,s2_6_t
5894       double precision
5895      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5896      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5897      & dt_dCi(3),dt_dCi1(3)
5898       common /sccalc/ time11,time12,time112,theti,it,nlobit
5899       delta=0.02d0*pi
5900       escloc=0.0D0
5901       do i=loc_start,loc_end
5902         if (itype(i).eq.ntyp1) cycle
5903         costtab(i+1) =dcos(theta(i+1))
5904         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5905         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5906         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5907         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5908         cosfac=dsqrt(cosfac2)
5909         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5910         sinfac=dsqrt(sinfac2)
5911         it=iabs(itype(i))
5912         if (it.eq.10) goto 1
5913 c
5914 C  Compute the axes of tghe local cartesian coordinates system; store in
5915 c   x_prime, y_prime and z_prime
5916 c
5917         do j=1,3
5918           x_prime(j) = 0.00
5919           y_prime(j) = 0.00
5920           z_prime(j) = 0.00
5921         enddo
5922 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5923 C     &   dc_norm(3,i+nres)
5924         do j = 1,3
5925           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5926           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5927         enddo
5928         do j = 1,3
5929           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5930         enddo
5931 c       write (2,*) "i",i
5932 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5933 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5934 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5935 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5936 c      & " xy",scalar(x_prime(1),y_prime(1)),
5937 c      & " xz",scalar(x_prime(1),z_prime(1)),
5938 c      & " yy",scalar(y_prime(1),y_prime(1)),
5939 c      & " yz",scalar(y_prime(1),z_prime(1)),
5940 c      & " zz",scalar(z_prime(1),z_prime(1))
5941 c
5942 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5943 C to local coordinate system. Store in xx, yy, zz.
5944 c
5945         xx=0.0d0
5946         yy=0.0d0
5947         zz=0.0d0
5948         do j = 1,3
5949           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5950           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5951           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5952         enddo
5953
5954         xxtab(i)=xx
5955         yytab(i)=yy
5956         zztab(i)=zz
5957 C
5958 C Compute the energy of the ith side cbain
5959 C
5960 c        write (2,*) "xx",xx," yy",yy," zz",zz
5961         it=iabs(itype(i))
5962         do j = 1,65
5963           x(j) = sc_parmin(j,it)
5964         enddo
5965 #ifdef CHECK_COORD
5966 Cc diagnostics - remove later
5967         xx1 = dcos(alph(2))
5968         yy1 = dsin(alph(2))*dcos(omeg(2))
5969         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5970         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5971      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5972      &    xx1,yy1,zz1
5973 C,"  --- ", xx_w,yy_w,zz_w
5974 c end diagnostics
5975 #endif
5976         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5977      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5978      &   + x(10)*yy*zz
5979         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5980      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5981      & + x(20)*yy*zz
5982         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5983      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5984      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5985      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5986      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5987      &  +x(40)*xx*yy*zz
5988         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5989      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5990      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5991      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5992      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5993      &  +x(60)*xx*yy*zz
5994         dsc_i   = 0.743d0+x(61)
5995         dp2_i   = 1.9d0+x(62)
5996         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5997      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5998         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5999      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6000         s1=(1+x(63))/(0.1d0 + dscp1)
6001         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6002         s2=(1+x(65))/(0.1d0 + dscp2)
6003         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6004         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6005      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6006 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6007 c     &   sumene4,
6008 c     &   dscp1,dscp2,sumene
6009 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6010         escloc = escloc + sumene
6011 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6012 c     & ,zz,xx,yy
6013 c#define DEBUG
6014 #ifdef DEBUG
6015 C
6016 C This section to check the numerical derivatives of the energy of ith side
6017 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6018 C #define DEBUG in the code to turn it on.
6019 C
6020         write (2,*) "sumene               =",sumene
6021         aincr=1.0d-7
6022         xxsave=xx
6023         xx=xx+aincr
6024         write (2,*) xx,yy,zz
6025         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6026         de_dxx_num=(sumenep-sumene)/aincr
6027         xx=xxsave
6028         write (2,*) "xx+ sumene from enesc=",sumenep
6029         yysave=yy
6030         yy=yy+aincr
6031         write (2,*) xx,yy,zz
6032         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6033         de_dyy_num=(sumenep-sumene)/aincr
6034         yy=yysave
6035         write (2,*) "yy+ sumene from enesc=",sumenep
6036         zzsave=zz
6037         zz=zz+aincr
6038         write (2,*) xx,yy,zz
6039         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6040         de_dzz_num=(sumenep-sumene)/aincr
6041         zz=zzsave
6042         write (2,*) "zz+ sumene from enesc=",sumenep
6043         costsave=cost2tab(i+1)
6044         sintsave=sint2tab(i+1)
6045         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6046         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6047         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6048         de_dt_num=(sumenep-sumene)/aincr
6049         write (2,*) " t+ sumene from enesc=",sumenep
6050         cost2tab(i+1)=costsave
6051         sint2tab(i+1)=sintsave
6052 C End of diagnostics section.
6053 #endif
6054 C
6055 C Compute the gradient of esc
6056 C
6057 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6058         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6059         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6060         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6061         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6062         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6063         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6064         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6065         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6066         pom1=(sumene3*sint2tab(i+1)+sumene1)
6067      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6068         pom2=(sumene4*cost2tab(i+1)+sumene2)
6069      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6070         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6071         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6072      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6073      &  +x(40)*yy*zz
6074         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6075         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6076      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6077      &  +x(60)*yy*zz
6078         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6079      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6080      &        +(pom1+pom2)*pom_dx
6081 #ifdef DEBUG
6082         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6083 #endif
6084 C
6085         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6086         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6087      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6088      &  +x(40)*xx*zz
6089         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6090         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6091      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6092      &  +x(59)*zz**2 +x(60)*xx*zz
6093         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6094      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6095      &        +(pom1-pom2)*pom_dy
6096 #ifdef DEBUG
6097         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6098 #endif
6099 C
6100         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6101      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6102      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6103      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6104      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6105      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6106      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6107      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6108 #ifdef DEBUG
6109         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6110 #endif
6111 C
6112         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6113      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6114      &  +pom1*pom_dt1+pom2*pom_dt2
6115 #ifdef DEBUG
6116         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6117 #endif
6118 c#undef DEBUG
6119 c
6120 C
6121        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6122        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6123        cosfac2xx=cosfac2*xx
6124        sinfac2yy=sinfac2*yy
6125        do k = 1,3
6126          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6127      &      vbld_inv(i+1)
6128          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6129      &      vbld_inv(i)
6130          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6131          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6132 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6133 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6134 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6135 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6136          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6137          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6138          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6139          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6140          dZZ_Ci1(k)=0.0d0
6141          dZZ_Ci(k)=0.0d0
6142          do j=1,3
6143            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6144      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6145            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6146      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6147          enddo
6148
6149          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6150          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6151          dZZ_XYZ(k)=vbld_inv(i+nres)*
6152      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6153 c
6154          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6155          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6156        enddo
6157
6158        do k=1,3
6159          dXX_Ctab(k,i)=dXX_Ci(k)
6160          dXX_C1tab(k,i)=dXX_Ci1(k)
6161          dYY_Ctab(k,i)=dYY_Ci(k)
6162          dYY_C1tab(k,i)=dYY_Ci1(k)
6163          dZZ_Ctab(k,i)=dZZ_Ci(k)
6164          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6165          dXX_XYZtab(k,i)=dXX_XYZ(k)
6166          dYY_XYZtab(k,i)=dYY_XYZ(k)
6167          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6168        enddo
6169
6170        do k = 1,3
6171 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6172 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6173 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6174 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6175 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6176 c     &    dt_dci(k)
6177 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6178 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6179          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6180      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6181          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6182      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6183          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6184      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6185        enddo
6186 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6187 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6188
6189 C to check gradient call subroutine check_grad
6190
6191     1 continue
6192       enddo
6193       return
6194       end
6195 c------------------------------------------------------------------------------
6196       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6197       implicit none
6198       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6199      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6200       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6201      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6202      &   + x(10)*yy*zz
6203       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6204      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6205      & + x(20)*yy*zz
6206       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6207      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6208      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6209      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6210      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6211      &  +x(40)*xx*yy*zz
6212       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6213      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6214      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6215      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6216      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6217      &  +x(60)*xx*yy*zz
6218       dsc_i   = 0.743d0+x(61)
6219       dp2_i   = 1.9d0+x(62)
6220       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6221      &          *(xx*cost2+yy*sint2))
6222       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6223      &          *(xx*cost2-yy*sint2))
6224       s1=(1+x(63))/(0.1d0 + dscp1)
6225       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6226       s2=(1+x(65))/(0.1d0 + dscp2)
6227       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6228       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6229      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6230       enesc=sumene
6231       return
6232       end
6233 #endif
6234 c------------------------------------------------------------------------------
6235       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6236 C
6237 C This procedure calculates two-body contact function g(rij) and its derivative:
6238 C
6239 C           eps0ij                                     !       x < -1
6240 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6241 C            0                                         !       x > 1
6242 C
6243 C where x=(rij-r0ij)/delta
6244 C
6245 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6246 C
6247       implicit none
6248       double precision rij,r0ij,eps0ij,fcont,fprimcont
6249       double precision x,x2,x4,delta
6250 c     delta=0.02D0*r0ij
6251 c      delta=0.2D0*r0ij
6252       x=(rij-r0ij)/delta
6253       if (x.lt.-1.0D0) then
6254         fcont=eps0ij
6255         fprimcont=0.0D0
6256       else if (x.le.1.0D0) then
6257         x2=x*x
6258         x4=x2*x2
6259         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6260         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6261       else
6262         fcont=0.0D0
6263         fprimcont=0.0D0
6264       endif
6265       return
6266       end
6267 c------------------------------------------------------------------------------
6268       subroutine splinthet(theti,delta,ss,ssder)
6269       implicit real*8 (a-h,o-z)
6270       include 'DIMENSIONS'
6271       include 'COMMON.VAR'
6272       include 'COMMON.GEO'
6273       thetup=pi-delta
6274       thetlow=delta
6275       if (theti.gt.pipol) then
6276         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6277       else
6278         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6279         ssder=-ssder
6280       endif
6281       return
6282       end
6283 c------------------------------------------------------------------------------
6284       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6285       implicit none
6286       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6287       double precision ksi,ksi2,ksi3,a1,a2,a3
6288       a1=fprim0*delta/(f1-f0)
6289       a2=3.0d0-2.0d0*a1
6290       a3=a1-2.0d0
6291       ksi=(x-x0)/delta
6292       ksi2=ksi*ksi
6293       ksi3=ksi2*ksi
6294       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6295       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6296       return
6297       end
6298 c------------------------------------------------------------------------------
6299       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6300       implicit none
6301       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6302       double precision ksi,ksi2,ksi3,a1,a2,a3
6303       ksi=(x-x0)/delta
6304       ksi2=ksi*ksi
6305       ksi3=ksi2*ksi
6306       a1=fprim0x*delta
6307       a2=3*(f1x-f0x)-2*fprim0x*delta
6308       a3=fprim0x*delta-2*(f1x-f0x)
6309       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6310       return
6311       end
6312 C-----------------------------------------------------------------------------
6313 #ifdef CRYST_TOR
6314 C-----------------------------------------------------------------------------
6315       subroutine etor(etors,edihcnstr)
6316       implicit real*8 (a-h,o-z)
6317       include 'DIMENSIONS'
6318       include 'COMMON.VAR'
6319       include 'COMMON.GEO'
6320       include 'COMMON.LOCAL'
6321       include 'COMMON.TORSION'
6322       include 'COMMON.INTERACT'
6323       include 'COMMON.DERIV'
6324       include 'COMMON.CHAIN'
6325       include 'COMMON.NAMES'
6326       include 'COMMON.IOUNITS'
6327       include 'COMMON.FFIELD'
6328       include 'COMMON.TORCNSTR'
6329       include 'COMMON.CONTROL'
6330       logical lprn
6331 C Set lprn=.true. for debugging
6332       lprn=.false.
6333 c      lprn=.true.
6334       etors=0.0D0
6335       do i=iphi_start,iphi_end
6336       etors_ii=0.0D0
6337         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6338      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6339         itori=itortyp(itype(i-2))
6340         itori1=itortyp(itype(i-1))
6341         phii=phi(i)
6342         gloci=0.0D0
6343 C Proline-Proline pair is a special case...
6344         if (itori.eq.3 .and. itori1.eq.3) then
6345           if (phii.gt.-dwapi3) then
6346             cosphi=dcos(3*phii)
6347             fac=1.0D0/(1.0D0-cosphi)
6348             etorsi=v1(1,3,3)*fac
6349             etorsi=etorsi+etorsi
6350             etors=etors+etorsi-v1(1,3,3)
6351             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6352             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6353           endif
6354           do j=1,3
6355             v1ij=v1(j+1,itori,itori1)
6356             v2ij=v2(j+1,itori,itori1)
6357             cosphi=dcos(j*phii)
6358             sinphi=dsin(j*phii)
6359             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6360             if (energy_dec) etors_ii=etors_ii+
6361      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6362             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6363           enddo
6364         else
6365           do j=1,nterm_old
6366             v1ij=v1(j,itori,itori1)
6367             v2ij=v2(j,itori,itori1)
6368             cosphi=dcos(j*phii)
6369             sinphi=dsin(j*phii)
6370             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6371             if (energy_dec) etors_ii=etors_ii+
6372      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6373             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6374           enddo
6375         endif
6376         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6377              'etor',i,etors_ii
6378         if (lprn)
6379      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6380      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6381      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6382         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6383 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6384       enddo
6385 ! 6/20/98 - dihedral angle constraints
6386       edihcnstr=0.0d0
6387       do i=1,ndih_constr
6388         itori=idih_constr(i)
6389         phii=phi(itori)
6390         difi=phii-phi0(i)
6391         if (difi.gt.drange(i)) then
6392           difi=difi-drange(i)
6393           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6394           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6395         else if (difi.lt.-drange(i)) then
6396           difi=difi+drange(i)
6397           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6398           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6399         endif
6400 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6401 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6402       enddo
6403 !      write (iout,*) 'edihcnstr',edihcnstr
6404       return
6405       end
6406 c------------------------------------------------------------------------------
6407       subroutine etor_d(etors_d)
6408       etors_d=0.0d0
6409       return
6410       end
6411 c----------------------------------------------------------------------------
6412 #else
6413       subroutine etor(etors,edihcnstr)
6414       implicit real*8 (a-h,o-z)
6415       include 'DIMENSIONS'
6416       include 'COMMON.VAR'
6417       include 'COMMON.GEO'
6418       include 'COMMON.LOCAL'
6419       include 'COMMON.TORSION'
6420       include 'COMMON.INTERACT'
6421       include 'COMMON.DERIV'
6422       include 'COMMON.CHAIN'
6423       include 'COMMON.NAMES'
6424       include 'COMMON.IOUNITS'
6425       include 'COMMON.FFIELD'
6426       include 'COMMON.TORCNSTR'
6427       include 'COMMON.CONTROL'
6428       logical lprn
6429 C Set lprn=.true. for debugging
6430       lprn=.false.
6431 c     lprn=.true.
6432       etors=0.0D0
6433       do i=iphi_start,iphi_end
6434 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6435 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6436 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6437 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6438         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6439      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6440 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6441 C For introducing the NH3+ and COO- group please check the etor_d for reference
6442 C and guidance
6443         etors_ii=0.0D0
6444          if (iabs(itype(i)).eq.20) then
6445          iblock=2
6446          else
6447          iblock=1
6448          endif
6449         itori=itortyp(itype(i-2))
6450         itori1=itortyp(itype(i-1))
6451         phii=phi(i)
6452         gloci=0.0D0
6453 C Regular cosine and sine terms
6454         do j=1,nterm(itori,itori1,iblock)
6455           v1ij=v1(j,itori,itori1,iblock)
6456           v2ij=v2(j,itori,itori1,iblock)
6457           cosphi=dcos(j*phii)
6458           sinphi=dsin(j*phii)
6459           etors=etors+v1ij*cosphi+v2ij*sinphi
6460           if (energy_dec) etors_ii=etors_ii+
6461      &                v1ij*cosphi+v2ij*sinphi
6462           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6463         enddo
6464 C Lorentz terms
6465 C                         v1
6466 C  E = SUM ----------------------------------- - v1
6467 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6468 C
6469         cosphi=dcos(0.5d0*phii)
6470         sinphi=dsin(0.5d0*phii)
6471         do j=1,nlor(itori,itori1,iblock)
6472           vl1ij=vlor1(j,itori,itori1)
6473           vl2ij=vlor2(j,itori,itori1)
6474           vl3ij=vlor3(j,itori,itori1)
6475           pom=vl2ij*cosphi+vl3ij*sinphi
6476           pom1=1.0d0/(pom*pom+1.0d0)
6477           etors=etors+vl1ij*pom1
6478           if (energy_dec) etors_ii=etors_ii+
6479      &                vl1ij*pom1
6480           pom=-pom*pom1*pom1
6481           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6482         enddo
6483 C Subtract the constant term
6484         etors=etors-v0(itori,itori1,iblock)
6485           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6486      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6487         if (lprn)
6488      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6489      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6490      &  (v1(j,itori,itori1,iblock),j=1,6),
6491      &  (v2(j,itori,itori1,iblock),j=1,6)
6492         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6493 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6494       enddo
6495 ! 6/20/98 - dihedral angle constraints
6496       edihcnstr=0.0d0
6497 c      do i=1,ndih_constr
6498       do i=idihconstr_start,idihconstr_end
6499         itori=idih_constr(i)
6500         phii=phi(itori)
6501         difi=pinorm(phii-phi0(i))
6502         if (difi.gt.drange(i)) then
6503           difi=difi-drange(i)
6504           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6505           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6506         else if (difi.lt.-drange(i)) then
6507           difi=difi+drange(i)
6508           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6509           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6510         else
6511           difi=0.0
6512         endif
6513 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6514 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6515 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6516       enddo
6517 cd       write (iout,*) 'edihcnstr',edihcnstr
6518       return
6519       end
6520 c----------------------------------------------------------------------------
6521       subroutine etor_d(etors_d)
6522 C 6/23/01 Compute double torsional energy
6523       implicit real*8 (a-h,o-z)
6524       include 'DIMENSIONS'
6525       include 'COMMON.VAR'
6526       include 'COMMON.GEO'
6527       include 'COMMON.LOCAL'
6528       include 'COMMON.TORSION'
6529       include 'COMMON.INTERACT'
6530       include 'COMMON.DERIV'
6531       include 'COMMON.CHAIN'
6532       include 'COMMON.NAMES'
6533       include 'COMMON.IOUNITS'
6534       include 'COMMON.FFIELD'
6535       include 'COMMON.TORCNSTR'
6536       logical lprn
6537 C Set lprn=.true. for debugging
6538       lprn=.false.
6539 c     lprn=.true.
6540       etors_d=0.0D0
6541 c      write(iout,*) "a tu??"
6542       do i=iphid_start,iphid_end
6543 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6544 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6545 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6546 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6547 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6548          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6549      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6550      &  (itype(i+1).eq.ntyp1)) cycle
6551 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6552         itori=itortyp(itype(i-2))
6553         itori1=itortyp(itype(i-1))
6554         itori2=itortyp(itype(i))
6555         phii=phi(i)
6556         phii1=phi(i+1)
6557         gloci1=0.0D0
6558         gloci2=0.0D0
6559         iblock=1
6560         if (iabs(itype(i+1)).eq.20) iblock=2
6561 C Iblock=2 Proline type
6562 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6563 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6564 C        if (itype(i+1).eq.ntyp1) iblock=3
6565 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6566 C IS or IS NOT need for this
6567 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6568 C        is (itype(i-3).eq.ntyp1) ntblock=2
6569 C        ntblock is N-terminal blocking group
6570
6571 C Regular cosine and sine terms
6572         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6573 C Example of changes for NH3+ blocking group
6574 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6575 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6576           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6577           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6578           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6579           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6580           cosphi1=dcos(j*phii)
6581           sinphi1=dsin(j*phii)
6582           cosphi2=dcos(j*phii1)
6583           sinphi2=dsin(j*phii1)
6584           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6585      &     v2cij*cosphi2+v2sij*sinphi2
6586           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6587           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6588         enddo
6589         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6590           do l=1,k-1
6591             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6592             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6593             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6594             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6595             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6596             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6597             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6598             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6599             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6600      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6601             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6602      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6603             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6604      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6605           enddo
6606         enddo
6607         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6608         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6609       enddo
6610       return
6611       end
6612 #endif
6613 c------------------------------------------------------------------------------
6614       subroutine eback_sc_corr(esccor)
6615 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6616 c        conformational states; temporarily implemented as differences
6617 c        between UNRES torsional potentials (dependent on three types of
6618 c        residues) and the torsional potentials dependent on all 20 types
6619 c        of residues computed from AM1  energy surfaces of terminally-blocked
6620 c        amino-acid residues.
6621       implicit real*8 (a-h,o-z)
6622       include 'DIMENSIONS'
6623       include 'COMMON.VAR'
6624       include 'COMMON.GEO'
6625       include 'COMMON.LOCAL'
6626       include 'COMMON.TORSION'
6627       include 'COMMON.SCCOR'
6628       include 'COMMON.INTERACT'
6629       include 'COMMON.DERIV'
6630       include 'COMMON.CHAIN'
6631       include 'COMMON.NAMES'
6632       include 'COMMON.IOUNITS'
6633       include 'COMMON.FFIELD'
6634       include 'COMMON.CONTROL'
6635       logical lprn
6636 C Set lprn=.true. for debugging
6637       lprn=.false.
6638 c      lprn=.true.
6639 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6640       esccor=0.0D0
6641       do i=itau_start,itau_end
6642         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6643         esccor_ii=0.0D0
6644         isccori=isccortyp(itype(i-2))
6645         isccori1=isccortyp(itype(i-1))
6646 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6647         phii=phi(i)
6648         do intertyp=1,3 !intertyp
6649 cc Added 09 May 2012 (Adasko)
6650 cc  Intertyp means interaction type of backbone mainchain correlation:
6651 c   1 = SC...Ca...Ca...Ca
6652 c   2 = Ca...Ca...Ca...SC
6653 c   3 = SC...Ca...Ca...SCi
6654         gloci=0.0D0
6655         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6656      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6657      &      (itype(i-1).eq.ntyp1)))
6658      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6659      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6660      &     .or.(itype(i).eq.ntyp1)))
6661      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6662      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6663      &      (itype(i-3).eq.ntyp1)))) cycle
6664         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6665         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6666      & cycle
6667        do j=1,nterm_sccor(isccori,isccori1)
6668           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6669           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6670           cosphi=dcos(j*tauangle(intertyp,i))
6671           sinphi=dsin(j*tauangle(intertyp,i))
6672           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6673           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6674         enddo
6675 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6676         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6677         if (lprn)
6678      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6679      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6680      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6681      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6682         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6683        enddo !intertyp
6684       enddo
6685
6686       return
6687       end
6688 c----------------------------------------------------------------------------
6689       subroutine multibody(ecorr)
6690 C This subroutine calculates multi-body contributions to energy following
6691 C the idea of Skolnick et al. If side chains I and J make a contact and
6692 C at the same time side chains I+1 and J+1 make a contact, an extra
6693 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6694       implicit real*8 (a-h,o-z)
6695       include 'DIMENSIONS'
6696       include 'COMMON.IOUNITS'
6697       include 'COMMON.DERIV'
6698       include 'COMMON.INTERACT'
6699       include 'COMMON.CONTACTS'
6700       double precision gx(3),gx1(3)
6701       logical lprn
6702
6703 C Set lprn=.true. for debugging
6704       lprn=.false.
6705
6706       if (lprn) then
6707         write (iout,'(a)') 'Contact function values:'
6708         do i=nnt,nct-2
6709           write (iout,'(i2,20(1x,i2,f10.5))')
6710      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6711         enddo
6712       endif
6713       ecorr=0.0D0
6714       do i=nnt,nct
6715         do j=1,3
6716           gradcorr(j,i)=0.0D0
6717           gradxorr(j,i)=0.0D0
6718         enddo
6719       enddo
6720       do i=nnt,nct-2
6721
6722         DO ISHIFT = 3,4
6723
6724         i1=i+ishift
6725         num_conti=num_cont(i)
6726         num_conti1=num_cont(i1)
6727         do jj=1,num_conti
6728           j=jcont(jj,i)
6729           do kk=1,num_conti1
6730             j1=jcont(kk,i1)
6731             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6732 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6733 cd   &                   ' ishift=',ishift
6734 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6735 C The system gains extra energy.
6736               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6737             endif   ! j1==j+-ishift
6738           enddo     ! kk
6739         enddo       ! jj
6740
6741         ENDDO ! ISHIFT
6742
6743       enddo         ! i
6744       return
6745       end
6746 c------------------------------------------------------------------------------
6747       double precision function esccorr(i,j,k,l,jj,kk)
6748       implicit real*8 (a-h,o-z)
6749       include 'DIMENSIONS'
6750       include 'COMMON.IOUNITS'
6751       include 'COMMON.DERIV'
6752       include 'COMMON.INTERACT'
6753       include 'COMMON.CONTACTS'
6754       double precision gx(3),gx1(3)
6755       logical lprn
6756       lprn=.false.
6757       eij=facont(jj,i)
6758       ekl=facont(kk,k)
6759 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6760 C Calculate the multi-body contribution to energy.
6761 C Calculate multi-body contributions to the gradient.
6762 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6763 cd   & k,l,(gacont(m,kk,k),m=1,3)
6764       do m=1,3
6765         gx(m) =ekl*gacont(m,jj,i)
6766         gx1(m)=eij*gacont(m,kk,k)
6767         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6768         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6769         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6770         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6771       enddo
6772       do m=i,j-1
6773         do ll=1,3
6774           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6775         enddo
6776       enddo
6777       do m=k,l-1
6778         do ll=1,3
6779           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6780         enddo
6781       enddo
6782       esccorr=-eij*ekl
6783       return
6784       end
6785 c------------------------------------------------------------------------------
6786       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6787 C This subroutine calculates multi-body contributions to hydrogen-bonding
6788       implicit real*8 (a-h,o-z)
6789       include 'DIMENSIONS'
6790       include 'COMMON.IOUNITS'
6791 #ifdef MPI
6792       include "mpif.h"
6793       parameter (max_cont=maxconts)
6794       parameter (max_dim=26)
6795       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6796       double precision zapas(max_dim,maxconts,max_fg_procs),
6797      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6798       common /przechowalnia/ zapas
6799       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6800      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6801 #endif
6802       include 'COMMON.SETUP'
6803       include 'COMMON.FFIELD'
6804       include 'COMMON.DERIV'
6805       include 'COMMON.INTERACT'
6806       include 'COMMON.CONTACTS'
6807       include 'COMMON.CONTROL'
6808       include 'COMMON.LOCAL'
6809       double precision gx(3),gx1(3),time00
6810       logical lprn,ldone
6811
6812 C Set lprn=.true. for debugging
6813       lprn=.false.
6814 #ifdef MPI
6815       n_corr=0
6816       n_corr1=0
6817       if (nfgtasks.le.1) goto 30
6818       if (lprn) then
6819         write (iout,'(a)') 'Contact function values before RECEIVE:'
6820         do i=nnt,nct-2
6821           write (iout,'(2i3,50(1x,i2,f5.2))')
6822      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6823      &    j=1,num_cont_hb(i))
6824         enddo
6825       endif
6826       call flush(iout)
6827       do i=1,ntask_cont_from
6828         ncont_recv(i)=0
6829       enddo
6830       do i=1,ntask_cont_to
6831         ncont_sent(i)=0
6832       enddo
6833 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6834 c     & ntask_cont_to
6835 C Make the list of contacts to send to send to other procesors
6836 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6837 c      call flush(iout)
6838       do i=iturn3_start,iturn3_end
6839 c        write (iout,*) "make contact list turn3",i," num_cont",
6840 c     &    num_cont_hb(i)
6841         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6842       enddo
6843       do i=iturn4_start,iturn4_end
6844 c        write (iout,*) "make contact list turn4",i," num_cont",
6845 c     &   num_cont_hb(i)
6846         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6847       enddo
6848       do ii=1,nat_sent
6849         i=iat_sent(ii)
6850 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6851 c     &    num_cont_hb(i)
6852         do j=1,num_cont_hb(i)
6853         do k=1,4
6854           jjc=jcont_hb(j,i)
6855           iproc=iint_sent_local(k,jjc,ii)
6856 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6857           if (iproc.gt.0) then
6858             ncont_sent(iproc)=ncont_sent(iproc)+1
6859             nn=ncont_sent(iproc)
6860             zapas(1,nn,iproc)=i
6861             zapas(2,nn,iproc)=jjc
6862             zapas(3,nn,iproc)=facont_hb(j,i)
6863             zapas(4,nn,iproc)=ees0p(j,i)
6864             zapas(5,nn,iproc)=ees0m(j,i)
6865             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6866             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6867             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6868             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6869             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6870             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6871             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6872             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6873             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6874             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6875             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6876             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6877             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6878             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6879             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6880             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6881             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6882             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6883             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6884             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6885             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6886           endif
6887         enddo
6888         enddo
6889       enddo
6890       if (lprn) then
6891       write (iout,*)
6892      &  "Numbers of contacts to be sent to other processors",
6893      &  (ncont_sent(i),i=1,ntask_cont_to)
6894       write (iout,*) "Contacts sent"
6895       do ii=1,ntask_cont_to
6896         nn=ncont_sent(ii)
6897         iproc=itask_cont_to(ii)
6898         write (iout,*) nn," contacts to processor",iproc,
6899      &   " of CONT_TO_COMM group"
6900         do i=1,nn
6901           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6902         enddo
6903       enddo
6904       call flush(iout)
6905       endif
6906       CorrelType=477
6907       CorrelID=fg_rank+1
6908       CorrelType1=478
6909       CorrelID1=nfgtasks+fg_rank+1
6910       ireq=0
6911 C Receive the numbers of needed contacts from other processors
6912       do ii=1,ntask_cont_from
6913         iproc=itask_cont_from(ii)
6914         ireq=ireq+1
6915         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6916      &    FG_COMM,req(ireq),IERR)
6917       enddo
6918 c      write (iout,*) "IRECV ended"
6919 c      call flush(iout)
6920 C Send the number of contacts needed by other processors
6921       do ii=1,ntask_cont_to
6922         iproc=itask_cont_to(ii)
6923         ireq=ireq+1
6924         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6925      &    FG_COMM,req(ireq),IERR)
6926       enddo
6927 c      write (iout,*) "ISEND ended"
6928 c      write (iout,*) "number of requests (nn)",ireq
6929       call flush(iout)
6930       if (ireq.gt.0)
6931      &  call MPI_Waitall(ireq,req,status_array,ierr)
6932 c      write (iout,*)
6933 c     &  "Numbers of contacts to be received from other processors",
6934 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6935 c      call flush(iout)
6936 C Receive contacts
6937       ireq=0
6938       do ii=1,ntask_cont_from
6939         iproc=itask_cont_from(ii)
6940         nn=ncont_recv(ii)
6941 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6942 c     &   " of CONT_TO_COMM group"
6943         call flush(iout)
6944         if (nn.gt.0) then
6945           ireq=ireq+1
6946           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6947      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6948 c          write (iout,*) "ireq,req",ireq,req(ireq)
6949         endif
6950       enddo
6951 C Send the contacts to processors that need them
6952       do ii=1,ntask_cont_to
6953         iproc=itask_cont_to(ii)
6954         nn=ncont_sent(ii)
6955 c        write (iout,*) nn," contacts to processor",iproc,
6956 c     &   " of CONT_TO_COMM group"
6957         if (nn.gt.0) then
6958           ireq=ireq+1
6959           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6960      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6961 c          write (iout,*) "ireq,req",ireq,req(ireq)
6962 c          do i=1,nn
6963 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6964 c          enddo
6965         endif
6966       enddo
6967 c      write (iout,*) "number of requests (contacts)",ireq
6968 c      write (iout,*) "req",(req(i),i=1,4)
6969 c      call flush(iout)
6970       if (ireq.gt.0)
6971      & call MPI_Waitall(ireq,req,status_array,ierr)
6972       do iii=1,ntask_cont_from
6973         iproc=itask_cont_from(iii)
6974         nn=ncont_recv(iii)
6975         if (lprn) then
6976         write (iout,*) "Received",nn," contacts from processor",iproc,
6977      &   " of CONT_FROM_COMM group"
6978         call flush(iout)
6979         do i=1,nn
6980           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6981         enddo
6982         call flush(iout)
6983         endif
6984         do i=1,nn
6985           ii=zapas_recv(1,i,iii)
6986 c Flag the received contacts to prevent double-counting
6987           jj=-zapas_recv(2,i,iii)
6988 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6989 c          call flush(iout)
6990           nnn=num_cont_hb(ii)+1
6991           num_cont_hb(ii)=nnn
6992           jcont_hb(nnn,ii)=jj
6993           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6994           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6995           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6996           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6997           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6998           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6999           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7000           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7001           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7002           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7003           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7004           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7005           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7006           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7007           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7008           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7009           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7010           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7011           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7012           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7013           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7014           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7015           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7016           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7017         enddo
7018       enddo
7019       call flush(iout)
7020       if (lprn) then
7021         write (iout,'(a)') 'Contact function values after receive:'
7022         do i=nnt,nct-2
7023           write (iout,'(2i3,50(1x,i3,f5.2))')
7024      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7025      &    j=1,num_cont_hb(i))
7026         enddo
7027         call flush(iout)
7028       endif
7029    30 continue
7030 #endif
7031       if (lprn) then
7032         write (iout,'(a)') 'Contact function values:'
7033         do i=nnt,nct-2
7034           write (iout,'(2i3,50(1x,i3,f5.2))')
7035      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7036      &    j=1,num_cont_hb(i))
7037         enddo
7038       endif
7039       ecorr=0.0D0
7040 C Remove the loop below after debugging !!!
7041       do i=nnt,nct
7042         do j=1,3
7043           gradcorr(j,i)=0.0D0
7044           gradxorr(j,i)=0.0D0
7045         enddo
7046       enddo
7047 C Calculate the local-electrostatic correlation terms
7048       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7049         i1=i+1
7050         num_conti=num_cont_hb(i)
7051         num_conti1=num_cont_hb(i+1)
7052         do jj=1,num_conti
7053           j=jcont_hb(jj,i)
7054           jp=iabs(j)
7055           do kk=1,num_conti1
7056             j1=jcont_hb(kk,i1)
7057             jp1=iabs(j1)
7058 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7059 c     &         ' jj=',jj,' kk=',kk
7060             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7061      &          .or. j.lt.0 .and. j1.gt.0) .and.
7062      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7063 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7064 C The system gains extra energy.
7065               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7066               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7067      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7068               n_corr=n_corr+1
7069             else if (j1.eq.j) then
7070 C Contacts I-J and I-(J+1) occur simultaneously.
7071 C The system loses extra energy.
7072 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7073             endif
7074           enddo ! kk
7075           do kk=1,num_conti
7076             j1=jcont_hb(kk,i)
7077 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7078 c    &         ' jj=',jj,' kk=',kk
7079             if (j1.eq.j+1) then
7080 C Contacts I-J and (I+1)-J occur simultaneously.
7081 C The system loses extra energy.
7082 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7083             endif ! j1==j+1
7084           enddo ! kk
7085         enddo ! jj
7086       enddo ! i
7087       return
7088       end
7089 c------------------------------------------------------------------------------
7090       subroutine add_hb_contact(ii,jj,itask)
7091       implicit real*8 (a-h,o-z)
7092       include "DIMENSIONS"
7093       include "COMMON.IOUNITS"
7094       integer max_cont
7095       integer max_dim
7096       parameter (max_cont=maxconts)
7097       parameter (max_dim=26)
7098       include "COMMON.CONTACTS"
7099       double precision zapas(max_dim,maxconts,max_fg_procs),
7100      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7101       common /przechowalnia/ zapas
7102       integer i,j,ii,jj,iproc,itask(4),nn
7103 c      write (iout,*) "itask",itask
7104       do i=1,2
7105         iproc=itask(i)
7106         if (iproc.gt.0) then
7107           do j=1,num_cont_hb(ii)
7108             jjc=jcont_hb(j,ii)
7109 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7110             if (jjc.eq.jj) then
7111               ncont_sent(iproc)=ncont_sent(iproc)+1
7112               nn=ncont_sent(iproc)
7113               zapas(1,nn,iproc)=ii
7114               zapas(2,nn,iproc)=jjc
7115               zapas(3,nn,iproc)=facont_hb(j,ii)
7116               zapas(4,nn,iproc)=ees0p(j,ii)
7117               zapas(5,nn,iproc)=ees0m(j,ii)
7118               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7119               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7120               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7121               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7122               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7123               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7124               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7125               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7126               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7127               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7128               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7129               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7130               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7131               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7132               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7133               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7134               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7135               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7136               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7137               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7138               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7139               exit
7140             endif
7141           enddo
7142         endif
7143       enddo
7144       return
7145       end
7146 c------------------------------------------------------------------------------
7147       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7148      &  n_corr1)
7149 C This subroutine calculates multi-body contributions to hydrogen-bonding
7150       implicit real*8 (a-h,o-z)
7151       include 'DIMENSIONS'
7152       include 'COMMON.IOUNITS'
7153 #ifdef MPI
7154       include "mpif.h"
7155       parameter (max_cont=maxconts)
7156       parameter (max_dim=70)
7157       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7158       double precision zapas(max_dim,maxconts,max_fg_procs),
7159      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7160       common /przechowalnia/ zapas
7161       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7162      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7163 #endif
7164       include 'COMMON.SETUP'
7165       include 'COMMON.FFIELD'
7166       include 'COMMON.DERIV'
7167       include 'COMMON.LOCAL'
7168       include 'COMMON.INTERACT'
7169       include 'COMMON.CONTACTS'
7170       include 'COMMON.CHAIN'
7171       include 'COMMON.CONTROL'
7172       double precision gx(3),gx1(3)
7173       integer num_cont_hb_old(maxres)
7174       logical lprn,ldone
7175       double precision eello4,eello5,eelo6,eello_turn6
7176       external eello4,eello5,eello6,eello_turn6
7177 C Set lprn=.true. for debugging
7178       lprn=.false.
7179       eturn6=0.0d0
7180 #ifdef MPI
7181       do i=1,nres
7182         num_cont_hb_old(i)=num_cont_hb(i)
7183       enddo
7184       n_corr=0
7185       n_corr1=0
7186       if (nfgtasks.le.1) goto 30
7187       if (lprn) then
7188         write (iout,'(a)') 'Contact function values before RECEIVE:'
7189         do i=nnt,nct-2
7190           write (iout,'(2i3,50(1x,i2,f5.2))')
7191      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7192      &    j=1,num_cont_hb(i))
7193         enddo
7194       endif
7195       call flush(iout)
7196       do i=1,ntask_cont_from
7197         ncont_recv(i)=0
7198       enddo
7199       do i=1,ntask_cont_to
7200         ncont_sent(i)=0
7201       enddo
7202 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7203 c     & ntask_cont_to
7204 C Make the list of contacts to send to send to other procesors
7205       do i=iturn3_start,iturn3_end
7206 c        write (iout,*) "make contact list turn3",i," num_cont",
7207 c     &    num_cont_hb(i)
7208         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7209       enddo
7210       do i=iturn4_start,iturn4_end
7211 c        write (iout,*) "make contact list turn4",i," num_cont",
7212 c     &   num_cont_hb(i)
7213         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7214       enddo
7215       do ii=1,nat_sent
7216         i=iat_sent(ii)
7217 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7218 c     &    num_cont_hb(i)
7219         do j=1,num_cont_hb(i)
7220         do k=1,4
7221           jjc=jcont_hb(j,i)
7222           iproc=iint_sent_local(k,jjc,ii)
7223 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7224           if (iproc.ne.0) then
7225             ncont_sent(iproc)=ncont_sent(iproc)+1
7226             nn=ncont_sent(iproc)
7227             zapas(1,nn,iproc)=i
7228             zapas(2,nn,iproc)=jjc
7229             zapas(3,nn,iproc)=d_cont(j,i)
7230             ind=3
7231             do kk=1,3
7232               ind=ind+1
7233               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7234             enddo
7235             do kk=1,2
7236               do ll=1,2
7237                 ind=ind+1
7238                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7239               enddo
7240             enddo
7241             do jj=1,5
7242               do kk=1,3
7243                 do ll=1,2
7244                   do mm=1,2
7245                     ind=ind+1
7246                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7247                   enddo
7248                 enddo
7249               enddo
7250             enddo
7251           endif
7252         enddo
7253         enddo
7254       enddo
7255       if (lprn) then
7256       write (iout,*)
7257      &  "Numbers of contacts to be sent to other processors",
7258      &  (ncont_sent(i),i=1,ntask_cont_to)
7259       write (iout,*) "Contacts sent"
7260       do ii=1,ntask_cont_to
7261         nn=ncont_sent(ii)
7262         iproc=itask_cont_to(ii)
7263         write (iout,*) nn," contacts to processor",iproc,
7264      &   " of CONT_TO_COMM group"
7265         do i=1,nn
7266           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7267         enddo
7268       enddo
7269       call flush(iout)
7270       endif
7271       CorrelType=477
7272       CorrelID=fg_rank+1
7273       CorrelType1=478
7274       CorrelID1=nfgtasks+fg_rank+1
7275       ireq=0
7276 C Receive the numbers of needed contacts from other processors
7277       do ii=1,ntask_cont_from
7278         iproc=itask_cont_from(ii)
7279         ireq=ireq+1
7280         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7281      &    FG_COMM,req(ireq),IERR)
7282       enddo
7283 c      write (iout,*) "IRECV ended"
7284 c      call flush(iout)
7285 C Send the number of contacts needed by other processors
7286       do ii=1,ntask_cont_to
7287         iproc=itask_cont_to(ii)
7288         ireq=ireq+1
7289         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7290      &    FG_COMM,req(ireq),IERR)
7291       enddo
7292 c      write (iout,*) "ISEND ended"
7293 c      write (iout,*) "number of requests (nn)",ireq
7294       call flush(iout)
7295       if (ireq.gt.0)
7296      &  call MPI_Waitall(ireq,req,status_array,ierr)
7297 c      write (iout,*)
7298 c     &  "Numbers of contacts to be received from other processors",
7299 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7300 c      call flush(iout)
7301 C Receive contacts
7302       ireq=0
7303       do ii=1,ntask_cont_from
7304         iproc=itask_cont_from(ii)
7305         nn=ncont_recv(ii)
7306 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7307 c     &   " of CONT_TO_COMM group"
7308         call flush(iout)
7309         if (nn.gt.0) then
7310           ireq=ireq+1
7311           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7312      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7313 c          write (iout,*) "ireq,req",ireq,req(ireq)
7314         endif
7315       enddo
7316 C Send the contacts to processors that need them
7317       do ii=1,ntask_cont_to
7318         iproc=itask_cont_to(ii)
7319         nn=ncont_sent(ii)
7320 c        write (iout,*) nn," contacts to processor",iproc,
7321 c     &   " of CONT_TO_COMM group"
7322         if (nn.gt.0) then
7323           ireq=ireq+1
7324           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7325      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7326 c          write (iout,*) "ireq,req",ireq,req(ireq)
7327 c          do i=1,nn
7328 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7329 c          enddo
7330         endif
7331       enddo
7332 c      write (iout,*) "number of requests (contacts)",ireq
7333 c      write (iout,*) "req",(req(i),i=1,4)
7334 c      call flush(iout)
7335       if (ireq.gt.0)
7336      & call MPI_Waitall(ireq,req,status_array,ierr)
7337       do iii=1,ntask_cont_from
7338         iproc=itask_cont_from(iii)
7339         nn=ncont_recv(iii)
7340         if (lprn) then
7341         write (iout,*) "Received",nn," contacts from processor",iproc,
7342      &   " of CONT_FROM_COMM group"
7343         call flush(iout)
7344         do i=1,nn
7345           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7346         enddo
7347         call flush(iout)
7348         endif
7349         do i=1,nn
7350           ii=zapas_recv(1,i,iii)
7351 c Flag the received contacts to prevent double-counting
7352           jj=-zapas_recv(2,i,iii)
7353 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7354 c          call flush(iout)
7355           nnn=num_cont_hb(ii)+1
7356           num_cont_hb(ii)=nnn
7357           jcont_hb(nnn,ii)=jj
7358           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7359           ind=3
7360           do kk=1,3
7361             ind=ind+1
7362             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7363           enddo
7364           do kk=1,2
7365             do ll=1,2
7366               ind=ind+1
7367               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7368             enddo
7369           enddo
7370           do jj=1,5
7371             do kk=1,3
7372               do ll=1,2
7373                 do mm=1,2
7374                   ind=ind+1
7375                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7376                 enddo
7377               enddo
7378             enddo
7379           enddo
7380         enddo
7381       enddo
7382       call flush(iout)
7383       if (lprn) then
7384         write (iout,'(a)') 'Contact function values after receive:'
7385         do i=nnt,nct-2
7386           write (iout,'(2i3,50(1x,i3,5f6.3))')
7387      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7388      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7389         enddo
7390         call flush(iout)
7391       endif
7392    30 continue
7393 #endif
7394       if (lprn) then
7395         write (iout,'(a)') 'Contact function values:'
7396         do i=nnt,nct-2
7397           write (iout,'(2i3,50(1x,i2,5f6.3))')
7398      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7399      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7400         enddo
7401       endif
7402       ecorr=0.0D0
7403       ecorr5=0.0d0
7404       ecorr6=0.0d0
7405 C Remove the loop below after debugging !!!
7406       do i=nnt,nct
7407         do j=1,3
7408           gradcorr(j,i)=0.0D0
7409           gradxorr(j,i)=0.0D0
7410         enddo
7411       enddo
7412 C Calculate the dipole-dipole interaction energies
7413       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7414       do i=iatel_s,iatel_e+1
7415         num_conti=num_cont_hb(i)
7416         do jj=1,num_conti
7417           j=jcont_hb(jj,i)
7418 #ifdef MOMENT
7419           call dipole(i,j,jj)
7420 #endif
7421         enddo
7422       enddo
7423       endif
7424 C Calculate the local-electrostatic correlation terms
7425 c                write (iout,*) "gradcorr5 in eello5 before loop"
7426 c                do iii=1,nres
7427 c                  write (iout,'(i5,3f10.5)')
7428 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7429 c                enddo
7430       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7431 c        write (iout,*) "corr loop i",i
7432         i1=i+1
7433         num_conti=num_cont_hb(i)
7434         num_conti1=num_cont_hb(i+1)
7435         do jj=1,num_conti
7436           j=jcont_hb(jj,i)
7437           jp=iabs(j)
7438           do kk=1,num_conti1
7439             j1=jcont_hb(kk,i1)
7440             jp1=iabs(j1)
7441 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7442 c     &         ' jj=',jj,' kk=',kk
7443 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7444             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7445      &          .or. j.lt.0 .and. j1.gt.0) .and.
7446      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7447 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7448 C The system gains extra energy.
7449               n_corr=n_corr+1
7450               sqd1=dsqrt(d_cont(jj,i))
7451               sqd2=dsqrt(d_cont(kk,i1))
7452               sred_geom = sqd1*sqd2
7453               IF (sred_geom.lt.cutoff_corr) THEN
7454                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7455      &            ekont,fprimcont)
7456 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7457 cd     &         ' jj=',jj,' kk=',kk
7458                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7459                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7460                 do l=1,3
7461                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7462                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7463                 enddo
7464                 n_corr1=n_corr1+1
7465 cd               write (iout,*) 'sred_geom=',sred_geom,
7466 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7467 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7468 cd               write (iout,*) "g_contij",g_contij
7469 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7470 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7471                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7472                 if (wcorr4.gt.0.0d0)
7473      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7474                   if (energy_dec.and.wcorr4.gt.0.0d0)
7475      1                 write (iout,'(a6,4i5,0pf7.3)')
7476      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7477 c                write (iout,*) "gradcorr5 before eello5"
7478 c                do iii=1,nres
7479 c                  write (iout,'(i5,3f10.5)')
7480 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7481 c                enddo
7482                 if (wcorr5.gt.0.0d0)
7483      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7484 c                write (iout,*) "gradcorr5 after eello5"
7485 c                do iii=1,nres
7486 c                  write (iout,'(i5,3f10.5)')
7487 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7488 c                enddo
7489                   if (energy_dec.and.wcorr5.gt.0.0d0)
7490      1                 write (iout,'(a6,4i5,0pf7.3)')
7491      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7492 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7493 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7494                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7495      &               .or. wturn6.eq.0.0d0))then
7496 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7497                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7498                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7499      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7500 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7501 cd     &            'ecorr6=',ecorr6
7502 cd                write (iout,'(4e15.5)') sred_geom,
7503 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7504 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7505 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7506                 else if (wturn6.gt.0.0d0
7507      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7508 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7509                   eturn6=eturn6+eello_turn6(i,jj,kk)
7510                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7511      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7512 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7513                 endif
7514               ENDIF
7515 1111          continue
7516             endif
7517           enddo ! kk
7518         enddo ! jj
7519       enddo ! i
7520       do i=1,nres
7521         num_cont_hb(i)=num_cont_hb_old(i)
7522       enddo
7523 c                write (iout,*) "gradcorr5 in eello5"
7524 c                do iii=1,nres
7525 c                  write (iout,'(i5,3f10.5)')
7526 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7527 c                enddo
7528       return
7529       end
7530 c------------------------------------------------------------------------------
7531       subroutine add_hb_contact_eello(ii,jj,itask)
7532       implicit real*8 (a-h,o-z)
7533       include "DIMENSIONS"
7534       include "COMMON.IOUNITS"
7535       integer max_cont
7536       integer max_dim
7537       parameter (max_cont=maxconts)
7538       parameter (max_dim=70)
7539       include "COMMON.CONTACTS"
7540       double precision zapas(max_dim,maxconts,max_fg_procs),
7541      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7542       common /przechowalnia/ zapas
7543       integer i,j,ii,jj,iproc,itask(4),nn
7544 c      write (iout,*) "itask",itask
7545       do i=1,2
7546         iproc=itask(i)
7547         if (iproc.gt.0) then
7548           do j=1,num_cont_hb(ii)
7549             jjc=jcont_hb(j,ii)
7550 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7551             if (jjc.eq.jj) then
7552               ncont_sent(iproc)=ncont_sent(iproc)+1
7553               nn=ncont_sent(iproc)
7554               zapas(1,nn,iproc)=ii
7555               zapas(2,nn,iproc)=jjc
7556               zapas(3,nn,iproc)=d_cont(j,ii)
7557               ind=3
7558               do kk=1,3
7559                 ind=ind+1
7560                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7561               enddo
7562               do kk=1,2
7563                 do ll=1,2
7564                   ind=ind+1
7565                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7566                 enddo
7567               enddo
7568               do jj=1,5
7569                 do kk=1,3
7570                   do ll=1,2
7571                     do mm=1,2
7572                       ind=ind+1
7573                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7574                     enddo
7575                   enddo
7576                 enddo
7577               enddo
7578               exit
7579             endif
7580           enddo
7581         endif
7582       enddo
7583       return
7584       end
7585 c------------------------------------------------------------------------------
7586       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7587       implicit real*8 (a-h,o-z)
7588       include 'DIMENSIONS'
7589       include 'COMMON.IOUNITS'
7590       include 'COMMON.DERIV'
7591       include 'COMMON.INTERACT'
7592       include 'COMMON.CONTACTS'
7593       double precision gx(3),gx1(3)
7594       logical lprn
7595       lprn=.false.
7596       eij=facont_hb(jj,i)
7597       ekl=facont_hb(kk,k)
7598       ees0pij=ees0p(jj,i)
7599       ees0pkl=ees0p(kk,k)
7600       ees0mij=ees0m(jj,i)
7601       ees0mkl=ees0m(kk,k)
7602       ekont=eij*ekl
7603       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7604 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7605 C Following 4 lines for diagnostics.
7606 cd    ees0pkl=0.0D0
7607 cd    ees0pij=1.0D0
7608 cd    ees0mkl=0.0D0
7609 cd    ees0mij=1.0D0
7610 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7611 c     & 'Contacts ',i,j,
7612 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7613 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7614 c     & 'gradcorr_long'
7615 C Calculate the multi-body contribution to energy.
7616 c      ecorr=ecorr+ekont*ees
7617 C Calculate multi-body contributions to the gradient.
7618       coeffpees0pij=coeffp*ees0pij
7619       coeffmees0mij=coeffm*ees0mij
7620       coeffpees0pkl=coeffp*ees0pkl
7621       coeffmees0mkl=coeffm*ees0mkl
7622       do ll=1,3
7623 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7624         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7625      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7626      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7627         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7628      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7629      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7630 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7631         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7632      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7633      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7634         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7635      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7636      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7637         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7638      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7639      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7640         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7641         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7642         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7643      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7644      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7645         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7646         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7647 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7648       enddo
7649 c      write (iout,*)
7650 cgrad      do m=i+1,j-1
7651 cgrad        do ll=1,3
7652 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7653 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7654 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7655 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7656 cgrad        enddo
7657 cgrad      enddo
7658 cgrad      do m=k+1,l-1
7659 cgrad        do ll=1,3
7660 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7661 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7662 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7663 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7664 cgrad        enddo
7665 cgrad      enddo
7666 c      write (iout,*) "ehbcorr",ekont*ees
7667       ehbcorr=ekont*ees
7668       return
7669       end
7670 #ifdef MOMENT
7671 C---------------------------------------------------------------------------
7672       subroutine dipole(i,j,jj)
7673       implicit real*8 (a-h,o-z)
7674       include 'DIMENSIONS'
7675       include 'COMMON.IOUNITS'
7676       include 'COMMON.CHAIN'
7677       include 'COMMON.FFIELD'
7678       include 'COMMON.DERIV'
7679       include 'COMMON.INTERACT'
7680       include 'COMMON.CONTACTS'
7681       include 'COMMON.TORSION'
7682       include 'COMMON.VAR'
7683       include 'COMMON.GEO'
7684       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7685      &  auxmat(2,2)
7686       iti1 = itortyp(itype(i+1))
7687       if (j.lt.nres-1) then
7688         itj1 = itortyp(itype(j+1))
7689       else
7690         itj1=ntortyp
7691       endif
7692       do iii=1,2
7693         dipi(iii,1)=Ub2(iii,i)
7694         dipderi(iii)=Ub2der(iii,i)
7695         dipi(iii,2)=b1(iii,i+1)
7696         dipj(iii,1)=Ub2(iii,j)
7697         dipderj(iii)=Ub2der(iii,j)
7698         dipj(iii,2)=b1(iii,j+1)
7699       enddo
7700       kkk=0
7701       do iii=1,2
7702         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7703         do jjj=1,2
7704           kkk=kkk+1
7705           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7706         enddo
7707       enddo
7708       do kkk=1,5
7709         do lll=1,3
7710           mmm=0
7711           do iii=1,2
7712             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7713      &        auxvec(1))
7714             do jjj=1,2
7715               mmm=mmm+1
7716               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7717             enddo
7718           enddo
7719         enddo
7720       enddo
7721       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7722       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7723       do iii=1,2
7724         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7725       enddo
7726       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7727       do iii=1,2
7728         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7729       enddo
7730       return
7731       end
7732 #endif
7733 C---------------------------------------------------------------------------
7734       subroutine calc_eello(i,j,k,l,jj,kk)
7735 C
7736 C This subroutine computes matrices and vectors needed to calculate
7737 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7738 C
7739       implicit real*8 (a-h,o-z)
7740       include 'DIMENSIONS'
7741       include 'COMMON.IOUNITS'
7742       include 'COMMON.CHAIN'
7743       include 'COMMON.DERIV'
7744       include 'COMMON.INTERACT'
7745       include 'COMMON.CONTACTS'
7746       include 'COMMON.TORSION'
7747       include 'COMMON.VAR'
7748       include 'COMMON.GEO'
7749       include 'COMMON.FFIELD'
7750       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7751      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7752       logical lprn
7753       common /kutas/ lprn
7754 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7755 cd     & ' jj=',jj,' kk=',kk
7756 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7757 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7758 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7759       do iii=1,2
7760         do jjj=1,2
7761           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7762           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7763         enddo
7764       enddo
7765       call transpose2(aa1(1,1),aa1t(1,1))
7766       call transpose2(aa2(1,1),aa2t(1,1))
7767       do kkk=1,5
7768         do lll=1,3
7769           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7770      &      aa1tder(1,1,lll,kkk))
7771           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7772      &      aa2tder(1,1,lll,kkk))
7773         enddo
7774       enddo
7775       if (l.eq.j+1) then
7776 C parallel orientation of the two CA-CA-CA frames.
7777         if (i.gt.1) then
7778           iti=itortyp(itype(i))
7779         else
7780           iti=ntortyp
7781         endif
7782         itk1=itortyp(itype(k+1))
7783         itj=itortyp(itype(j))
7784         if (l.lt.nres-1) then
7785           itl1=itortyp(itype(l+1))
7786         else
7787           itl1=ntortyp
7788         endif
7789 C A1 kernel(j+1) A2T
7790 cd        do iii=1,2
7791 cd          write (iout,'(3f10.5,5x,3f10.5)')
7792 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7793 cd        enddo
7794         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7795      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7796      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7797 C Following matrices are needed only for 6-th order cumulants
7798         IF (wcorr6.gt.0.0d0) THEN
7799         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7800      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7801      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7802         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7803      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7804      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7805      &   ADtEAderx(1,1,1,1,1,1))
7806         lprn=.false.
7807         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7808      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7809      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7810      &   ADtEA1derx(1,1,1,1,1,1))
7811         ENDIF
7812 C End 6-th order cumulants
7813 cd        lprn=.false.
7814 cd        if (lprn) then
7815 cd        write (2,*) 'In calc_eello6'
7816 cd        do iii=1,2
7817 cd          write (2,*) 'iii=',iii
7818 cd          do kkk=1,5
7819 cd            write (2,*) 'kkk=',kkk
7820 cd            do jjj=1,2
7821 cd              write (2,'(3(2f10.5),5x)')
7822 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7823 cd            enddo
7824 cd          enddo
7825 cd        enddo
7826 cd        endif
7827         call transpose2(EUgder(1,1,k),auxmat(1,1))
7828         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7829         call transpose2(EUg(1,1,k),auxmat(1,1))
7830         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7831         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7832         do iii=1,2
7833           do kkk=1,5
7834             do lll=1,3
7835               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7836      &          EAEAderx(1,1,lll,kkk,iii,1))
7837             enddo
7838           enddo
7839         enddo
7840 C A1T kernel(i+1) A2
7841         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7842      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7843      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7844 C Following matrices are needed only for 6-th order cumulants
7845         IF (wcorr6.gt.0.0d0) THEN
7846         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7847      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7848      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7849         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7850      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7851      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7852      &   ADtEAderx(1,1,1,1,1,2))
7853         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7854      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7855      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7856      &   ADtEA1derx(1,1,1,1,1,2))
7857         ENDIF
7858 C End 6-th order cumulants
7859         call transpose2(EUgder(1,1,l),auxmat(1,1))
7860         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7861         call transpose2(EUg(1,1,l),auxmat(1,1))
7862         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7863         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7864         do iii=1,2
7865           do kkk=1,5
7866             do lll=1,3
7867               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7868      &          EAEAderx(1,1,lll,kkk,iii,2))
7869             enddo
7870           enddo
7871         enddo
7872 C AEAb1 and AEAb2
7873 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7874 C They are needed only when the fifth- or the sixth-order cumulants are
7875 C indluded.
7876         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7877         call transpose2(AEA(1,1,1),auxmat(1,1))
7878         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7879         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7880         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7881         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7882         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7883         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7884         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7885         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7886         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7887         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7888         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7889         call transpose2(AEA(1,1,2),auxmat(1,1))
7890         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7891         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7892         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7893         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7894         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7895         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7896         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7897         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7898         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7899         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7900         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7901 C Calculate the Cartesian derivatives of the vectors.
7902         do iii=1,2
7903           do kkk=1,5
7904             do lll=1,3
7905               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7906               call matvec2(auxmat(1,1),b1(1,i),
7907      &          AEAb1derx(1,lll,kkk,iii,1,1))
7908               call matvec2(auxmat(1,1),Ub2(1,i),
7909      &          AEAb2derx(1,lll,kkk,iii,1,1))
7910               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7911      &          AEAb1derx(1,lll,kkk,iii,2,1))
7912               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7913      &          AEAb2derx(1,lll,kkk,iii,2,1))
7914               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7915               call matvec2(auxmat(1,1),b1(1,j),
7916      &          AEAb1derx(1,lll,kkk,iii,1,2))
7917               call matvec2(auxmat(1,1),Ub2(1,j),
7918      &          AEAb2derx(1,lll,kkk,iii,1,2))
7919               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7920      &          AEAb1derx(1,lll,kkk,iii,2,2))
7921               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7922      &          AEAb2derx(1,lll,kkk,iii,2,2))
7923             enddo
7924           enddo
7925         enddo
7926         ENDIF
7927 C End vectors
7928       else
7929 C Antiparallel orientation of the two CA-CA-CA frames.
7930         if (i.gt.1) then
7931           iti=itortyp(itype(i))
7932         else
7933           iti=ntortyp
7934         endif
7935         itk1=itortyp(itype(k+1))
7936         itl=itortyp(itype(l))
7937         itj=itortyp(itype(j))
7938         if (j.lt.nres-1) then
7939           itj1=itortyp(itype(j+1))
7940         else
7941           itj1=ntortyp
7942         endif
7943 C A2 kernel(j-1)T A1T
7944         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7945      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7946      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7947 C Following matrices are needed only for 6-th order cumulants
7948         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7949      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7950         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7951      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7952      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7953         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7954      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7955      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7956      &   ADtEAderx(1,1,1,1,1,1))
7957         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7958      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7959      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7960      &   ADtEA1derx(1,1,1,1,1,1))
7961         ENDIF
7962 C End 6-th order cumulants
7963         call transpose2(EUgder(1,1,k),auxmat(1,1))
7964         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7965         call transpose2(EUg(1,1,k),auxmat(1,1))
7966         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7967         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7968         do iii=1,2
7969           do kkk=1,5
7970             do lll=1,3
7971               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7972      &          EAEAderx(1,1,lll,kkk,iii,1))
7973             enddo
7974           enddo
7975         enddo
7976 C A2T kernel(i+1)T A1
7977         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7978      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7979      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7980 C Following matrices are needed only for 6-th order cumulants
7981         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7982      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7983         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7984      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7985      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7986         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7987      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7988      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7989      &   ADtEAderx(1,1,1,1,1,2))
7990         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7991      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7992      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7993      &   ADtEA1derx(1,1,1,1,1,2))
7994         ENDIF
7995 C End 6-th order cumulants
7996         call transpose2(EUgder(1,1,j),auxmat(1,1))
7997         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7998         call transpose2(EUg(1,1,j),auxmat(1,1))
7999         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8000         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8001         do iii=1,2
8002           do kkk=1,5
8003             do lll=1,3
8004               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8005      &          EAEAderx(1,1,lll,kkk,iii,2))
8006             enddo
8007           enddo
8008         enddo
8009 C AEAb1 and AEAb2
8010 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8011 C They are needed only when the fifth- or the sixth-order cumulants are
8012 C indluded.
8013         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8014      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8015         call transpose2(AEA(1,1,1),auxmat(1,1))
8016         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8017         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8018         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8019         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8020         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8021         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8022         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8023         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8024         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8025         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8026         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8027         call transpose2(AEA(1,1,2),auxmat(1,1))
8028         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8029         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8030         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8031         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8032         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8033         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8034         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8035         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8036         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8037         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8038         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8039 C Calculate the Cartesian derivatives of the vectors.
8040         do iii=1,2
8041           do kkk=1,5
8042             do lll=1,3
8043               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8044               call matvec2(auxmat(1,1),b1(1,i),
8045      &          AEAb1derx(1,lll,kkk,iii,1,1))
8046               call matvec2(auxmat(1,1),Ub2(1,i),
8047      &          AEAb2derx(1,lll,kkk,iii,1,1))
8048               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8049      &          AEAb1derx(1,lll,kkk,iii,2,1))
8050               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8051      &          AEAb2derx(1,lll,kkk,iii,2,1))
8052               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8053               call matvec2(auxmat(1,1),b1(1,l),
8054      &          AEAb1derx(1,lll,kkk,iii,1,2))
8055               call matvec2(auxmat(1,1),Ub2(1,l),
8056      &          AEAb2derx(1,lll,kkk,iii,1,2))
8057               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8058      &          AEAb1derx(1,lll,kkk,iii,2,2))
8059               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8060      &          AEAb2derx(1,lll,kkk,iii,2,2))
8061             enddo
8062           enddo
8063         enddo
8064         ENDIF
8065 C End vectors
8066       endif
8067       return
8068       end
8069 C---------------------------------------------------------------------------
8070       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8071      &  KK,KKderg,AKA,AKAderg,AKAderx)
8072       implicit none
8073       integer nderg
8074       logical transp
8075       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8076      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8077      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8078       integer iii,kkk,lll
8079       integer jjj,mmm
8080       logical lprn
8081       common /kutas/ lprn
8082       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8083       do iii=1,nderg
8084         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8085      &    AKAderg(1,1,iii))
8086       enddo
8087 cd      if (lprn) write (2,*) 'In kernel'
8088       do kkk=1,5
8089 cd        if (lprn) write (2,*) 'kkk=',kkk
8090         do lll=1,3
8091           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8092      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8093 cd          if (lprn) then
8094 cd            write (2,*) 'lll=',lll
8095 cd            write (2,*) 'iii=1'
8096 cd            do jjj=1,2
8097 cd              write (2,'(3(2f10.5),5x)')
8098 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8099 cd            enddo
8100 cd          endif
8101           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8102      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8103 cd          if (lprn) then
8104 cd            write (2,*) 'lll=',lll
8105 cd            write (2,*) 'iii=2'
8106 cd            do jjj=1,2
8107 cd              write (2,'(3(2f10.5),5x)')
8108 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8109 cd            enddo
8110 cd          endif
8111         enddo
8112       enddo
8113       return
8114       end
8115 C---------------------------------------------------------------------------
8116       double precision function eello4(i,j,k,l,jj,kk)
8117       implicit real*8 (a-h,o-z)
8118       include 'DIMENSIONS'
8119       include 'COMMON.IOUNITS'
8120       include 'COMMON.CHAIN'
8121       include 'COMMON.DERIV'
8122       include 'COMMON.INTERACT'
8123       include 'COMMON.CONTACTS'
8124       include 'COMMON.TORSION'
8125       include 'COMMON.VAR'
8126       include 'COMMON.GEO'
8127       double precision pizda(2,2),ggg1(3),ggg2(3)
8128 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8129 cd        eello4=0.0d0
8130 cd        return
8131 cd      endif
8132 cd      print *,'eello4:',i,j,k,l,jj,kk
8133 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8134 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8135 cold      eij=facont_hb(jj,i)
8136 cold      ekl=facont_hb(kk,k)
8137 cold      ekont=eij*ekl
8138       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8139 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8140       gcorr_loc(k-1)=gcorr_loc(k-1)
8141      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8142       if (l.eq.j+1) then
8143         gcorr_loc(l-1)=gcorr_loc(l-1)
8144      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8145       else
8146         gcorr_loc(j-1)=gcorr_loc(j-1)
8147      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8148       endif
8149       do iii=1,2
8150         do kkk=1,5
8151           do lll=1,3
8152             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8153      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8154 cd            derx(lll,kkk,iii)=0.0d0
8155           enddo
8156         enddo
8157       enddo
8158 cd      gcorr_loc(l-1)=0.0d0
8159 cd      gcorr_loc(j-1)=0.0d0
8160 cd      gcorr_loc(k-1)=0.0d0
8161 cd      eel4=1.0d0
8162 cd      write (iout,*)'Contacts have occurred for peptide groups',
8163 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8164 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8165       if (j.lt.nres-1) then
8166         j1=j+1
8167         j2=j-1
8168       else
8169         j1=j-1
8170         j2=j-2
8171       endif
8172       if (l.lt.nres-1) then
8173         l1=l+1
8174         l2=l-1
8175       else
8176         l1=l-1
8177         l2=l-2
8178       endif
8179       do ll=1,3
8180 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8181 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8182         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8183         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8184 cgrad        ghalf=0.5d0*ggg1(ll)
8185         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8186         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8187         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8188         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8189         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8190         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8191 cgrad        ghalf=0.5d0*ggg2(ll)
8192         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8193         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8194         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8195         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8196         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8197         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8198       enddo
8199 cgrad      do m=i+1,j-1
8200 cgrad        do ll=1,3
8201 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8202 cgrad        enddo
8203 cgrad      enddo
8204 cgrad      do m=k+1,l-1
8205 cgrad        do ll=1,3
8206 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8207 cgrad        enddo
8208 cgrad      enddo
8209 cgrad      do m=i+2,j2
8210 cgrad        do ll=1,3
8211 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8212 cgrad        enddo
8213 cgrad      enddo
8214 cgrad      do m=k+2,l2
8215 cgrad        do ll=1,3
8216 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8217 cgrad        enddo
8218 cgrad      enddo
8219 cd      do iii=1,nres-3
8220 cd        write (2,*) iii,gcorr_loc(iii)
8221 cd      enddo
8222       eello4=ekont*eel4
8223 cd      write (2,*) 'ekont',ekont
8224 cd      write (iout,*) 'eello4',ekont*eel4
8225       return
8226       end
8227 C---------------------------------------------------------------------------
8228       double precision function eello5(i,j,k,l,jj,kk)
8229       implicit real*8 (a-h,o-z)
8230       include 'DIMENSIONS'
8231       include 'COMMON.IOUNITS'
8232       include 'COMMON.CHAIN'
8233       include 'COMMON.DERIV'
8234       include 'COMMON.INTERACT'
8235       include 'COMMON.CONTACTS'
8236       include 'COMMON.TORSION'
8237       include 'COMMON.VAR'
8238       include 'COMMON.GEO'
8239       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8240       double precision ggg1(3),ggg2(3)
8241 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8242 C                                                                              C
8243 C                            Parallel chains                                   C
8244 C                                                                              C
8245 C          o             o                   o             o                   C
8246 C         /l\           / \             \   / \           / \   /              C
8247 C        /   \         /   \             \ /   \         /   \ /               C
8248 C       j| o |l1       | o |              o| o |         | o |o                C
8249 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8250 C      \i/   \         /   \ /             /   \         /   \                 C
8251 C       o    k1             o                                                  C
8252 C         (I)          (II)                (III)          (IV)                 C
8253 C                                                                              C
8254 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8255 C                                                                              C
8256 C                            Antiparallel chains                               C
8257 C                                                                              C
8258 C          o             o                   o             o                   C
8259 C         /j\           / \             \   / \           / \   /              C
8260 C        /   \         /   \             \ /   \         /   \ /               C
8261 C      j1| o |l        | o |              o| o |         | o |o                C
8262 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8263 C      \i/   \         /   \ /             /   \         /   \                 C
8264 C       o     k1            o                                                  C
8265 C         (I)          (II)                (III)          (IV)                 C
8266 C                                                                              C
8267 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8268 C                                                                              C
8269 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8270 C                                                                              C
8271 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8272 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8273 cd        eello5=0.0d0
8274 cd        return
8275 cd      endif
8276 cd      write (iout,*)
8277 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8278 cd     &   ' and',k,l
8279       itk=itortyp(itype(k))
8280       itl=itortyp(itype(l))
8281       itj=itortyp(itype(j))
8282       eello5_1=0.0d0
8283       eello5_2=0.0d0
8284       eello5_3=0.0d0
8285       eello5_4=0.0d0
8286 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8287 cd     &   eel5_3_num,eel5_4_num)
8288       do iii=1,2
8289         do kkk=1,5
8290           do lll=1,3
8291             derx(lll,kkk,iii)=0.0d0
8292           enddo
8293         enddo
8294       enddo
8295 cd      eij=facont_hb(jj,i)
8296 cd      ekl=facont_hb(kk,k)
8297 cd      ekont=eij*ekl
8298 cd      write (iout,*)'Contacts have occurred for peptide groups',
8299 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8300 cd      goto 1111
8301 C Contribution from the graph I.
8302 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8303 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8304       call transpose2(EUg(1,1,k),auxmat(1,1))
8305       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8306       vv(1)=pizda(1,1)-pizda(2,2)
8307       vv(2)=pizda(1,2)+pizda(2,1)
8308       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8309      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8310 C Explicit gradient in virtual-dihedral angles.
8311       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8312      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8313      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8314       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8315       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8316       vv(1)=pizda(1,1)-pizda(2,2)
8317       vv(2)=pizda(1,2)+pizda(2,1)
8318       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8319      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8320      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8321       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8322       vv(1)=pizda(1,1)-pizda(2,2)
8323       vv(2)=pizda(1,2)+pizda(2,1)
8324       if (l.eq.j+1) then
8325         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8326      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8327      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8328       else
8329         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8330      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8331      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8332       endif
8333 C Cartesian gradient
8334       do iii=1,2
8335         do kkk=1,5
8336           do lll=1,3
8337             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8338      &        pizda(1,1))
8339             vv(1)=pizda(1,1)-pizda(2,2)
8340             vv(2)=pizda(1,2)+pizda(2,1)
8341             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8342      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8343      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8344           enddo
8345         enddo
8346       enddo
8347 c      goto 1112
8348 c1111  continue
8349 C Contribution from graph II
8350       call transpose2(EE(1,1,itk),auxmat(1,1))
8351       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8352       vv(1)=pizda(1,1)+pizda(2,2)
8353       vv(2)=pizda(2,1)-pizda(1,2)
8354       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8355      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8356 C Explicit gradient in virtual-dihedral angles.
8357       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8358      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8359       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8360       vv(1)=pizda(1,1)+pizda(2,2)
8361       vv(2)=pizda(2,1)-pizda(1,2)
8362       if (l.eq.j+1) then
8363         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8364      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8365      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8366       else
8367         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8368      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8369      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8370       endif
8371 C Cartesian gradient
8372       do iii=1,2
8373         do kkk=1,5
8374           do lll=1,3
8375             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8376      &        pizda(1,1))
8377             vv(1)=pizda(1,1)+pizda(2,2)
8378             vv(2)=pizda(2,1)-pizda(1,2)
8379             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8380      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8381      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8382           enddo
8383         enddo
8384       enddo
8385 cd      goto 1112
8386 cd1111  continue
8387       if (l.eq.j+1) then
8388 cd        goto 1110
8389 C Parallel orientation
8390 C Contribution from graph III
8391         call transpose2(EUg(1,1,l),auxmat(1,1))
8392         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8393         vv(1)=pizda(1,1)-pizda(2,2)
8394         vv(2)=pizda(1,2)+pizda(2,1)
8395         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8396      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8397 C Explicit gradient in virtual-dihedral angles.
8398         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8399      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8400      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8401         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8402         vv(1)=pizda(1,1)-pizda(2,2)
8403         vv(2)=pizda(1,2)+pizda(2,1)
8404         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8405      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8406      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8407         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8408         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8409         vv(1)=pizda(1,1)-pizda(2,2)
8410         vv(2)=pizda(1,2)+pizda(2,1)
8411         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8412      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8413      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8414 C Cartesian gradient
8415         do iii=1,2
8416           do kkk=1,5
8417             do lll=1,3
8418               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8419      &          pizda(1,1))
8420               vv(1)=pizda(1,1)-pizda(2,2)
8421               vv(2)=pizda(1,2)+pizda(2,1)
8422               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8423      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8424      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8425             enddo
8426           enddo
8427         enddo
8428 cd        goto 1112
8429 C Contribution from graph IV
8430 cd1110    continue
8431         call transpose2(EE(1,1,itl),auxmat(1,1))
8432         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8433         vv(1)=pizda(1,1)+pizda(2,2)
8434         vv(2)=pizda(2,1)-pizda(1,2)
8435         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8436      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8437 C Explicit gradient in virtual-dihedral angles.
8438         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8439      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8440         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8441         vv(1)=pizda(1,1)+pizda(2,2)
8442         vv(2)=pizda(2,1)-pizda(1,2)
8443         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8444      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8445      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8446 C Cartesian gradient
8447         do iii=1,2
8448           do kkk=1,5
8449             do lll=1,3
8450               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8451      &          pizda(1,1))
8452               vv(1)=pizda(1,1)+pizda(2,2)
8453               vv(2)=pizda(2,1)-pizda(1,2)
8454               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8455      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8456      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8457             enddo
8458           enddo
8459         enddo
8460       else
8461 C Antiparallel orientation
8462 C Contribution from graph III
8463 c        goto 1110
8464         call transpose2(EUg(1,1,j),auxmat(1,1))
8465         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8466         vv(1)=pizda(1,1)-pizda(2,2)
8467         vv(2)=pizda(1,2)+pizda(2,1)
8468         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8469      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8470 C Explicit gradient in virtual-dihedral angles.
8471         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8472      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8473      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8474         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8475         vv(1)=pizda(1,1)-pizda(2,2)
8476         vv(2)=pizda(1,2)+pizda(2,1)
8477         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8478      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8479      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8480         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8481         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8482         vv(1)=pizda(1,1)-pizda(2,2)
8483         vv(2)=pizda(1,2)+pizda(2,1)
8484         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8485      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8486      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8487 C Cartesian gradient
8488         do iii=1,2
8489           do kkk=1,5
8490             do lll=1,3
8491               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8492      &          pizda(1,1))
8493               vv(1)=pizda(1,1)-pizda(2,2)
8494               vv(2)=pizda(1,2)+pizda(2,1)
8495               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8496      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8497      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8498             enddo
8499           enddo
8500         enddo
8501 cd        goto 1112
8502 C Contribution from graph IV
8503 1110    continue
8504         call transpose2(EE(1,1,itj),auxmat(1,1))
8505         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8506         vv(1)=pizda(1,1)+pizda(2,2)
8507         vv(2)=pizda(2,1)-pizda(1,2)
8508         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8509      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8510 C Explicit gradient in virtual-dihedral angles.
8511         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8512      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8513         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8514         vv(1)=pizda(1,1)+pizda(2,2)
8515         vv(2)=pizda(2,1)-pizda(1,2)
8516         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8517      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8518      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8519 C Cartesian gradient
8520         do iii=1,2
8521           do kkk=1,5
8522             do lll=1,3
8523               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8524      &          pizda(1,1))
8525               vv(1)=pizda(1,1)+pizda(2,2)
8526               vv(2)=pizda(2,1)-pizda(1,2)
8527               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8528      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8529      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8530             enddo
8531           enddo
8532         enddo
8533       endif
8534 1112  continue
8535       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8536 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8537 cd        write (2,*) 'ijkl',i,j,k,l
8538 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8539 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8540 cd      endif
8541 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8542 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8543 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8544 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8545       if (j.lt.nres-1) then
8546         j1=j+1
8547         j2=j-1
8548       else
8549         j1=j-1
8550         j2=j-2
8551       endif
8552       if (l.lt.nres-1) then
8553         l1=l+1
8554         l2=l-1
8555       else
8556         l1=l-1
8557         l2=l-2
8558       endif
8559 cd      eij=1.0d0
8560 cd      ekl=1.0d0
8561 cd      ekont=1.0d0
8562 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8563 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8564 C        summed up outside the subrouine as for the other subroutines
8565 C        handling long-range interactions. The old code is commented out
8566 C        with "cgrad" to keep track of changes.
8567       do ll=1,3
8568 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8569 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8570         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8571         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8572 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8573 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8574 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8575 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8576 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8577 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8578 c     &   gradcorr5ij,
8579 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8580 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8581 cgrad        ghalf=0.5d0*ggg1(ll)
8582 cd        ghalf=0.0d0
8583         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8584         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8585         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8586         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8587         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8588         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8589 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8590 cgrad        ghalf=0.5d0*ggg2(ll)
8591 cd        ghalf=0.0d0
8592         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8593         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8594         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8595         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8596         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8597         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8598       enddo
8599 cd      goto 1112
8600 cgrad      do m=i+1,j-1
8601 cgrad        do ll=1,3
8602 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8603 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8604 cgrad        enddo
8605 cgrad      enddo
8606 cgrad      do m=k+1,l-1
8607 cgrad        do ll=1,3
8608 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8609 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8610 cgrad        enddo
8611 cgrad      enddo
8612 c1112  continue
8613 cgrad      do m=i+2,j2
8614 cgrad        do ll=1,3
8615 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8616 cgrad        enddo
8617 cgrad      enddo
8618 cgrad      do m=k+2,l2
8619 cgrad        do ll=1,3
8620 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8621 cgrad        enddo
8622 cgrad      enddo
8623 cd      do iii=1,nres-3
8624 cd        write (2,*) iii,g_corr5_loc(iii)
8625 cd      enddo
8626       eello5=ekont*eel5
8627 cd      write (2,*) 'ekont',ekont
8628 cd      write (iout,*) 'eello5',ekont*eel5
8629       return
8630       end
8631 c--------------------------------------------------------------------------
8632       double precision function eello6(i,j,k,l,jj,kk)
8633       implicit real*8 (a-h,o-z)
8634       include 'DIMENSIONS'
8635       include 'COMMON.IOUNITS'
8636       include 'COMMON.CHAIN'
8637       include 'COMMON.DERIV'
8638       include 'COMMON.INTERACT'
8639       include 'COMMON.CONTACTS'
8640       include 'COMMON.TORSION'
8641       include 'COMMON.VAR'
8642       include 'COMMON.GEO'
8643       include 'COMMON.FFIELD'
8644       double precision ggg1(3),ggg2(3)
8645 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8646 cd        eello6=0.0d0
8647 cd        return
8648 cd      endif
8649 cd      write (iout,*)
8650 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8651 cd     &   ' and',k,l
8652       eello6_1=0.0d0
8653       eello6_2=0.0d0
8654       eello6_3=0.0d0
8655       eello6_4=0.0d0
8656       eello6_5=0.0d0
8657       eello6_6=0.0d0
8658 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8659 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8660       do iii=1,2
8661         do kkk=1,5
8662           do lll=1,3
8663             derx(lll,kkk,iii)=0.0d0
8664           enddo
8665         enddo
8666       enddo
8667 cd      eij=facont_hb(jj,i)
8668 cd      ekl=facont_hb(kk,k)
8669 cd      ekont=eij*ekl
8670 cd      eij=1.0d0
8671 cd      ekl=1.0d0
8672 cd      ekont=1.0d0
8673       if (l.eq.j+1) then
8674         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8675         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8676         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8677         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8678         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8679         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8680       else
8681         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8682         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8683         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8684         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8685         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8686           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8687         else
8688           eello6_5=0.0d0
8689         endif
8690         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8691       endif
8692 C If turn contributions are considered, they will be handled separately.
8693       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8694 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8695 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8696 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8697 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8698 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8699 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8700 cd      goto 1112
8701       if (j.lt.nres-1) then
8702         j1=j+1
8703         j2=j-1
8704       else
8705         j1=j-1
8706         j2=j-2
8707       endif
8708       if (l.lt.nres-1) then
8709         l1=l+1
8710         l2=l-1
8711       else
8712         l1=l-1
8713         l2=l-2
8714       endif
8715       do ll=1,3
8716 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8717 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8718 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8719 cgrad        ghalf=0.5d0*ggg1(ll)
8720 cd        ghalf=0.0d0
8721         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8722         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8723         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8724         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8725         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8726         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8727         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8728         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8729 cgrad        ghalf=0.5d0*ggg2(ll)
8730 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8731 cd        ghalf=0.0d0
8732         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8733         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8734         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8735         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8736         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8737         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8738       enddo
8739 cd      goto 1112
8740 cgrad      do m=i+1,j-1
8741 cgrad        do ll=1,3
8742 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8743 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8744 cgrad        enddo
8745 cgrad      enddo
8746 cgrad      do m=k+1,l-1
8747 cgrad        do ll=1,3
8748 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8749 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8750 cgrad        enddo
8751 cgrad      enddo
8752 cgrad1112  continue
8753 cgrad      do m=i+2,j2
8754 cgrad        do ll=1,3
8755 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8756 cgrad        enddo
8757 cgrad      enddo
8758 cgrad      do m=k+2,l2
8759 cgrad        do ll=1,3
8760 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8761 cgrad        enddo
8762 cgrad      enddo
8763 cd      do iii=1,nres-3
8764 cd        write (2,*) iii,g_corr6_loc(iii)
8765 cd      enddo
8766       eello6=ekont*eel6
8767 cd      write (2,*) 'ekont',ekont
8768 cd      write (iout,*) 'eello6',ekont*eel6
8769       return
8770       end
8771 c--------------------------------------------------------------------------
8772       double precision function eello6_graph1(i,j,k,l,imat,swap)
8773       implicit real*8 (a-h,o-z)
8774       include 'DIMENSIONS'
8775       include 'COMMON.IOUNITS'
8776       include 'COMMON.CHAIN'
8777       include 'COMMON.DERIV'
8778       include 'COMMON.INTERACT'
8779       include 'COMMON.CONTACTS'
8780       include 'COMMON.TORSION'
8781       include 'COMMON.VAR'
8782       include 'COMMON.GEO'
8783       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8784       logical swap
8785       logical lprn
8786       common /kutas/ lprn
8787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8788 C                                                                              C
8789 C      Parallel       Antiparallel                                             C
8790 C                                                                              C
8791 C          o             o                                                     C
8792 C         /l\           /j\                                                    C
8793 C        /   \         /   \                                                   C
8794 C       /| o |         | o |\                                                  C
8795 C     \ j|/k\|  /   \  |/k\|l /                                                C
8796 C      \ /   \ /     \ /   \ /                                                 C
8797 C       o     o       o     o                                                  C
8798 C       i             i                                                        C
8799 C                                                                              C
8800 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8801       itk=itortyp(itype(k))
8802       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8803       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8804       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8805       call transpose2(EUgC(1,1,k),auxmat(1,1))
8806       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8807       vv1(1)=pizda1(1,1)-pizda1(2,2)
8808       vv1(2)=pizda1(1,2)+pizda1(2,1)
8809       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8810       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8811       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8812       s5=scalar2(vv(1),Dtobr2(1,i))
8813 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8814       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8815       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8816      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8817      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8818      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8819      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8820      & +scalar2(vv(1),Dtobr2der(1,i)))
8821       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8822       vv1(1)=pizda1(1,1)-pizda1(2,2)
8823       vv1(2)=pizda1(1,2)+pizda1(2,1)
8824       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8825       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8826       if (l.eq.j+1) then
8827         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8828      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8829      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8830      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8831      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8832       else
8833         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8834      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8835      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8836      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8837      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8838       endif
8839       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8840       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8841       vv1(1)=pizda1(1,1)-pizda1(2,2)
8842       vv1(2)=pizda1(1,2)+pizda1(2,1)
8843       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8844      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8845      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8846      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8847       do iii=1,2
8848         if (swap) then
8849           ind=3-iii
8850         else
8851           ind=iii
8852         endif
8853         do kkk=1,5
8854           do lll=1,3
8855             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8856             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8857             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8858             call transpose2(EUgC(1,1,k),auxmat(1,1))
8859             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8860      &        pizda1(1,1))
8861             vv1(1)=pizda1(1,1)-pizda1(2,2)
8862             vv1(2)=pizda1(1,2)+pizda1(2,1)
8863             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8864             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8865      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8866             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8867      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8868             s5=scalar2(vv(1),Dtobr2(1,i))
8869             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8870           enddo
8871         enddo
8872       enddo
8873       return
8874       end
8875 c----------------------------------------------------------------------------
8876       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8877       implicit real*8 (a-h,o-z)
8878       include 'DIMENSIONS'
8879       include 'COMMON.IOUNITS'
8880       include 'COMMON.CHAIN'
8881       include 'COMMON.DERIV'
8882       include 'COMMON.INTERACT'
8883       include 'COMMON.CONTACTS'
8884       include 'COMMON.TORSION'
8885       include 'COMMON.VAR'
8886       include 'COMMON.GEO'
8887       logical swap
8888       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8889      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8890       logical lprn
8891       common /kutas/ lprn
8892 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8893 C                                                                              C
8894 C      Parallel       Antiparallel                                             C
8895 C                                                                              C
8896 C          o             o                                                     C
8897 C     \   /l\           /j\   /                                                C
8898 C      \ /   \         /   \ /                                                 C
8899 C       o| o |         | o |o                                                  C
8900 C     \ j|/k\|      \  |/k\|l                                                  C
8901 C      \ /   \       \ /   \                                                   C
8902 C       o             o                                                        C
8903 C       i             i                                                        C
8904 C                                                                              C
8905 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8906 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8907 C AL 7/4/01 s1 would occur in the sixth-order moment,
8908 C           but not in a cluster cumulant
8909 #ifdef MOMENT
8910       s1=dip(1,jj,i)*dip(1,kk,k)
8911 #endif
8912       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8913       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8914       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8915       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8916       call transpose2(EUg(1,1,k),auxmat(1,1))
8917       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8918       vv(1)=pizda(1,1)-pizda(2,2)
8919       vv(2)=pizda(1,2)+pizda(2,1)
8920       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8921 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8922 #ifdef MOMENT
8923       eello6_graph2=-(s1+s2+s3+s4)
8924 #else
8925       eello6_graph2=-(s2+s3+s4)
8926 #endif
8927 c      eello6_graph2=-s3
8928 C Derivatives in gamma(i-1)
8929       if (i.gt.1) then
8930 #ifdef MOMENT
8931         s1=dipderg(1,jj,i)*dip(1,kk,k)
8932 #endif
8933         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8934         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8935         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8936         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8937 #ifdef MOMENT
8938         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8939 #else
8940         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8941 #endif
8942 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8943       endif
8944 C Derivatives in gamma(k-1)
8945 #ifdef MOMENT
8946       s1=dip(1,jj,i)*dipderg(1,kk,k)
8947 #endif
8948       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8949       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8950       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8951       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8952       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8953       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8954       vv(1)=pizda(1,1)-pizda(2,2)
8955       vv(2)=pizda(1,2)+pizda(2,1)
8956       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8957 #ifdef MOMENT
8958       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8959 #else
8960       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8961 #endif
8962 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8963 C Derivatives in gamma(j-1) or gamma(l-1)
8964       if (j.gt.1) then
8965 #ifdef MOMENT
8966         s1=dipderg(3,jj,i)*dip(1,kk,k)
8967 #endif
8968         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8969         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8970         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8971         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8972         vv(1)=pizda(1,1)-pizda(2,2)
8973         vv(2)=pizda(1,2)+pizda(2,1)
8974         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8975 #ifdef MOMENT
8976         if (swap) then
8977           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8978         else
8979           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8980         endif
8981 #endif
8982         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8983 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8984       endif
8985 C Derivatives in gamma(l-1) or gamma(j-1)
8986       if (l.gt.1) then
8987 #ifdef MOMENT
8988         s1=dip(1,jj,i)*dipderg(3,kk,k)
8989 #endif
8990         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8991         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8992         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8993         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8994         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8995         vv(1)=pizda(1,1)-pizda(2,2)
8996         vv(2)=pizda(1,2)+pizda(2,1)
8997         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8998 #ifdef MOMENT
8999         if (swap) then
9000           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9001         else
9002           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9003         endif
9004 #endif
9005         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9006 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9007       endif
9008 C Cartesian derivatives.
9009       if (lprn) then
9010         write (2,*) 'In eello6_graph2'
9011         do iii=1,2
9012           write (2,*) 'iii=',iii
9013           do kkk=1,5
9014             write (2,*) 'kkk=',kkk
9015             do jjj=1,2
9016               write (2,'(3(2f10.5),5x)')
9017      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9018             enddo
9019           enddo
9020         enddo
9021       endif
9022       do iii=1,2
9023         do kkk=1,5
9024           do lll=1,3
9025 #ifdef MOMENT
9026             if (iii.eq.1) then
9027               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9028             else
9029               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9030             endif
9031 #endif
9032             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9033      &        auxvec(1))
9034             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9035             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9036      &        auxvec(1))
9037             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9038             call transpose2(EUg(1,1,k),auxmat(1,1))
9039             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9040      &        pizda(1,1))
9041             vv(1)=pizda(1,1)-pizda(2,2)
9042             vv(2)=pizda(1,2)+pizda(2,1)
9043             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9044 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9045 #ifdef MOMENT
9046             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9047 #else
9048             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9049 #endif
9050             if (swap) then
9051               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9052             else
9053               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9054             endif
9055           enddo
9056         enddo
9057       enddo
9058       return
9059       end
9060 c----------------------------------------------------------------------------
9061       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9062       implicit real*8 (a-h,o-z)
9063       include 'DIMENSIONS'
9064       include 'COMMON.IOUNITS'
9065       include 'COMMON.CHAIN'
9066       include 'COMMON.DERIV'
9067       include 'COMMON.INTERACT'
9068       include 'COMMON.CONTACTS'
9069       include 'COMMON.TORSION'
9070       include 'COMMON.VAR'
9071       include 'COMMON.GEO'
9072       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9073       logical swap
9074 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9075 C                                                                              C
9076 C      Parallel       Antiparallel                                             C
9077 C                                                                              C
9078 C          o             o                                                     C
9079 C         /l\   /   \   /j\                                                    C
9080 C        /   \ /     \ /   \                                                   C
9081 C       /| o |o       o| o |\                                                  C
9082 C       j|/k\|  /      |/k\|l /                                                C
9083 C        /   \ /       /   \ /                                                 C
9084 C       /     o       /     o                                                  C
9085 C       i             i                                                        C
9086 C                                                                              C
9087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9088 C
9089 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9090 C           energy moment and not to the cluster cumulant.
9091       iti=itortyp(itype(i))
9092       if (j.lt.nres-1) then
9093         itj1=itortyp(itype(j+1))
9094       else
9095         itj1=ntortyp
9096       endif
9097       itk=itortyp(itype(k))
9098       itk1=itortyp(itype(k+1))
9099       if (l.lt.nres-1) then
9100         itl1=itortyp(itype(l+1))
9101       else
9102         itl1=ntortyp
9103       endif
9104 #ifdef MOMENT
9105       s1=dip(4,jj,i)*dip(4,kk,k)
9106 #endif
9107       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9108       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9109       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9110       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9111       call transpose2(EE(1,1,itk),auxmat(1,1))
9112       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9113       vv(1)=pizda(1,1)+pizda(2,2)
9114       vv(2)=pizda(2,1)-pizda(1,2)
9115       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9116 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9117 cd     & "sum",-(s2+s3+s4)
9118 #ifdef MOMENT
9119       eello6_graph3=-(s1+s2+s3+s4)
9120 #else
9121       eello6_graph3=-(s2+s3+s4)
9122 #endif
9123 c      eello6_graph3=-s4
9124 C Derivatives in gamma(k-1)
9125       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9126       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9127       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9128       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9129 C Derivatives in gamma(l-1)
9130       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9131       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9132       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9133       vv(1)=pizda(1,1)+pizda(2,2)
9134       vv(2)=pizda(2,1)-pizda(1,2)
9135       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9136       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9137 C Cartesian derivatives.
9138       do iii=1,2
9139         do kkk=1,5
9140           do lll=1,3
9141 #ifdef MOMENT
9142             if (iii.eq.1) then
9143               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9144             else
9145               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9146             endif
9147 #endif
9148             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9149      &        auxvec(1))
9150             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9151             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9152      &        auxvec(1))
9153             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9154             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9155      &        pizda(1,1))
9156             vv(1)=pizda(1,1)+pizda(2,2)
9157             vv(2)=pizda(2,1)-pizda(1,2)
9158             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9159 #ifdef MOMENT
9160             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9161 #else
9162             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9163 #endif
9164             if (swap) then
9165               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9166             else
9167               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9168             endif
9169 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9170           enddo
9171         enddo
9172       enddo
9173       return
9174       end
9175 c----------------------------------------------------------------------------
9176       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9177       implicit real*8 (a-h,o-z)
9178       include 'DIMENSIONS'
9179       include 'COMMON.IOUNITS'
9180       include 'COMMON.CHAIN'
9181       include 'COMMON.DERIV'
9182       include 'COMMON.INTERACT'
9183       include 'COMMON.CONTACTS'
9184       include 'COMMON.TORSION'
9185       include 'COMMON.VAR'
9186       include 'COMMON.GEO'
9187       include 'COMMON.FFIELD'
9188       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9189      & auxvec1(2),auxmat1(2,2)
9190       logical swap
9191 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9192 C                                                                              C
9193 C      Parallel       Antiparallel                                             C
9194 C                                                                              C
9195 C          o             o                                                     C
9196 C         /l\   /   \   /j\                                                    C
9197 C        /   \ /     \ /   \                                                   C
9198 C       /| o |o       o| o |\                                                  C
9199 C     \ j|/k\|      \  |/k\|l                                                  C
9200 C      \ /   \       \ /   \                                                   C
9201 C       o     \       o     \                                                  C
9202 C       i             i                                                        C
9203 C                                                                              C
9204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9205 C
9206 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9207 C           energy moment and not to the cluster cumulant.
9208 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9209       iti=itortyp(itype(i))
9210       itj=itortyp(itype(j))
9211       if (j.lt.nres-1) then
9212         itj1=itortyp(itype(j+1))
9213       else
9214         itj1=ntortyp
9215       endif
9216       itk=itortyp(itype(k))
9217       if (k.lt.nres-1) then
9218         itk1=itortyp(itype(k+1))
9219       else
9220         itk1=ntortyp
9221       endif
9222       itl=itortyp(itype(l))
9223       if (l.lt.nres-1) then
9224         itl1=itortyp(itype(l+1))
9225       else
9226         itl1=ntortyp
9227       endif
9228 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9229 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9230 cd     & ' itl',itl,' itl1',itl1
9231 #ifdef MOMENT
9232       if (imat.eq.1) then
9233         s1=dip(3,jj,i)*dip(3,kk,k)
9234       else
9235         s1=dip(2,jj,j)*dip(2,kk,l)
9236       endif
9237 #endif
9238       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9239       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9240       if (j.eq.l+1) then
9241         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9242         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9243       else
9244         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9245         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9246       endif
9247       call transpose2(EUg(1,1,k),auxmat(1,1))
9248       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9249       vv(1)=pizda(1,1)-pizda(2,2)
9250       vv(2)=pizda(2,1)+pizda(1,2)
9251       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9252 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9253 #ifdef MOMENT
9254       eello6_graph4=-(s1+s2+s3+s4)
9255 #else
9256       eello6_graph4=-(s2+s3+s4)
9257 #endif
9258 C Derivatives in gamma(i-1)
9259       if (i.gt.1) then
9260 #ifdef MOMENT
9261         if (imat.eq.1) then
9262           s1=dipderg(2,jj,i)*dip(3,kk,k)
9263         else
9264           s1=dipderg(4,jj,j)*dip(2,kk,l)
9265         endif
9266 #endif
9267         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9268         if (j.eq.l+1) then
9269           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9270           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9271         else
9272           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9273           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9274         endif
9275         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9276         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9277 cd          write (2,*) 'turn6 derivatives'
9278 #ifdef MOMENT
9279           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9280 #else
9281           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9282 #endif
9283         else
9284 #ifdef MOMENT
9285           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9286 #else
9287           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9288 #endif
9289         endif
9290       endif
9291 C Derivatives in gamma(k-1)
9292 #ifdef MOMENT
9293       if (imat.eq.1) then
9294         s1=dip(3,jj,i)*dipderg(2,kk,k)
9295       else
9296         s1=dip(2,jj,j)*dipderg(4,kk,l)
9297       endif
9298 #endif
9299       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9300       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9301       if (j.eq.l+1) then
9302         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9303         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9304       else
9305         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9306         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9307       endif
9308       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9309       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9310       vv(1)=pizda(1,1)-pizda(2,2)
9311       vv(2)=pizda(2,1)+pizda(1,2)
9312       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9313       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9314 #ifdef MOMENT
9315         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9316 #else
9317         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9318 #endif
9319       else
9320 #ifdef MOMENT
9321         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9322 #else
9323         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9324 #endif
9325       endif
9326 C Derivatives in gamma(j-1) or gamma(l-1)
9327       if (l.eq.j+1 .and. l.gt.1) then
9328         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9329         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9330         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9331         vv(1)=pizda(1,1)-pizda(2,2)
9332         vv(2)=pizda(2,1)+pizda(1,2)
9333         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9334         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9335       else if (j.gt.1) then
9336         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9337         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9338         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9339         vv(1)=pizda(1,1)-pizda(2,2)
9340         vv(2)=pizda(2,1)+pizda(1,2)
9341         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9342         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9343           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9344         else
9345           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9346         endif
9347       endif
9348 C Cartesian derivatives.
9349       do iii=1,2
9350         do kkk=1,5
9351           do lll=1,3
9352 #ifdef MOMENT
9353             if (iii.eq.1) then
9354               if (imat.eq.1) then
9355                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9356               else
9357                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9358               endif
9359             else
9360               if (imat.eq.1) then
9361                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9362               else
9363                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9364               endif
9365             endif
9366 #endif
9367             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9368      &        auxvec(1))
9369             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9370             if (j.eq.l+1) then
9371               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9372      &          b1(1,j+1),auxvec(1))
9373               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9374             else
9375               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9376      &          b1(1,l+1),auxvec(1))
9377               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9378             endif
9379             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9380      &        pizda(1,1))
9381             vv(1)=pizda(1,1)-pizda(2,2)
9382             vv(2)=pizda(2,1)+pizda(1,2)
9383             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9384             if (swap) then
9385               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9386 #ifdef MOMENT
9387                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9388      &             -(s1+s2+s4)
9389 #else
9390                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9391      &             -(s2+s4)
9392 #endif
9393                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9394               else
9395 #ifdef MOMENT
9396                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9397 #else
9398                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9399 #endif
9400                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9401               endif
9402             else
9403 #ifdef MOMENT
9404               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9405 #else
9406               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9407 #endif
9408               if (l.eq.j+1) then
9409                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9410               else
9411                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9412               endif
9413             endif
9414           enddo
9415         enddo
9416       enddo
9417       return
9418       end
9419 c----------------------------------------------------------------------------
9420       double precision function eello_turn6(i,jj,kk)
9421       implicit real*8 (a-h,o-z)
9422       include 'DIMENSIONS'
9423       include 'COMMON.IOUNITS'
9424       include 'COMMON.CHAIN'
9425       include 'COMMON.DERIV'
9426       include 'COMMON.INTERACT'
9427       include 'COMMON.CONTACTS'
9428       include 'COMMON.TORSION'
9429       include 'COMMON.VAR'
9430       include 'COMMON.GEO'
9431       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9432      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9433      &  ggg1(3),ggg2(3)
9434       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9435      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9436 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9437 C           the respective energy moment and not to the cluster cumulant.
9438       s1=0.0d0
9439       s8=0.0d0
9440       s13=0.0d0
9441 c
9442       eello_turn6=0.0d0
9443       j=i+4
9444       k=i+1
9445       l=i+3
9446       iti=itortyp(itype(i))
9447       itk=itortyp(itype(k))
9448       itk1=itortyp(itype(k+1))
9449       itl=itortyp(itype(l))
9450       itj=itortyp(itype(j))
9451 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9452 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9453 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9454 cd        eello6=0.0d0
9455 cd        return
9456 cd      endif
9457 cd      write (iout,*)
9458 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9459 cd     &   ' and',k,l
9460 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9461       do iii=1,2
9462         do kkk=1,5
9463           do lll=1,3
9464             derx_turn(lll,kkk,iii)=0.0d0
9465           enddo
9466         enddo
9467       enddo
9468 cd      eij=1.0d0
9469 cd      ekl=1.0d0
9470 cd      ekont=1.0d0
9471       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9472 cd      eello6_5=0.0d0
9473 cd      write (2,*) 'eello6_5',eello6_5
9474 #ifdef MOMENT
9475       call transpose2(AEA(1,1,1),auxmat(1,1))
9476       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9477       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9478       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9479 #endif
9480       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9481       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9482       s2 = scalar2(b1(1,k),vtemp1(1))
9483 #ifdef MOMENT
9484       call transpose2(AEA(1,1,2),atemp(1,1))
9485       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9486       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9487       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9488 #endif
9489       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9490       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9491       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9492 #ifdef MOMENT
9493       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9494       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9495       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9496       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9497       ss13 = scalar2(b1(1,k),vtemp4(1))
9498       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9499 #endif
9500 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9501 c      s1=0.0d0
9502 c      s2=0.0d0
9503 c      s8=0.0d0
9504 c      s12=0.0d0
9505 c      s13=0.0d0
9506       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9507 C Derivatives in gamma(i+2)
9508       s1d =0.0d0
9509       s8d =0.0d0
9510 #ifdef MOMENT
9511       call transpose2(AEA(1,1,1),auxmatd(1,1))
9512       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9513       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9514       call transpose2(AEAderg(1,1,2),atempd(1,1))
9515       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9516       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9517 #endif
9518       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9519       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9520       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9521 c      s1d=0.0d0
9522 c      s2d=0.0d0
9523 c      s8d=0.0d0
9524 c      s12d=0.0d0
9525 c      s13d=0.0d0
9526       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9527 C Derivatives in gamma(i+3)
9528 #ifdef MOMENT
9529       call transpose2(AEA(1,1,1),auxmatd(1,1))
9530       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9531       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9532       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9533 #endif
9534       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9535       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9536       s2d = scalar2(b1(1,k),vtemp1d(1))
9537 #ifdef MOMENT
9538       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9539       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9540 #endif
9541       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9542 #ifdef MOMENT
9543       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9544       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9545       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9546 #endif
9547 c      s1d=0.0d0
9548 c      s2d=0.0d0
9549 c      s8d=0.0d0
9550 c      s12d=0.0d0
9551 c      s13d=0.0d0
9552 #ifdef MOMENT
9553       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9554      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9555 #else
9556       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9557      &               -0.5d0*ekont*(s2d+s12d)
9558 #endif
9559 C Derivatives in gamma(i+4)
9560       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9561       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9562       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9563 #ifdef MOMENT
9564       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9565       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9566       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9567 #endif
9568 c      s1d=0.0d0
9569 c      s2d=0.0d0
9570 c      s8d=0.0d0
9571 C      s12d=0.0d0
9572 c      s13d=0.0d0
9573 #ifdef MOMENT
9574       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9575 #else
9576       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9577 #endif
9578 C Derivatives in gamma(i+5)
9579 #ifdef MOMENT
9580       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9581       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9582       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9583 #endif
9584       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9585       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9586       s2d = scalar2(b1(1,k),vtemp1d(1))
9587 #ifdef MOMENT
9588       call transpose2(AEA(1,1,2),atempd(1,1))
9589       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9590       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9591 #endif
9592       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9593       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9594 #ifdef MOMENT
9595       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9596       ss13d = scalar2(b1(1,k),vtemp4d(1))
9597       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9598 #endif
9599 c      s1d=0.0d0
9600 c      s2d=0.0d0
9601 c      s8d=0.0d0
9602 c      s12d=0.0d0
9603 c      s13d=0.0d0
9604 #ifdef MOMENT
9605       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9606      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9607 #else
9608       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9609      &               -0.5d0*ekont*(s2d+s12d)
9610 #endif
9611 C Cartesian derivatives
9612       do iii=1,2
9613         do kkk=1,5
9614           do lll=1,3
9615 #ifdef MOMENT
9616             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9617             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9618             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9619 #endif
9620             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9621             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9622      &          vtemp1d(1))
9623             s2d = scalar2(b1(1,k),vtemp1d(1))
9624 #ifdef MOMENT
9625             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9626             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9627             s8d = -(atempd(1,1)+atempd(2,2))*
9628      &           scalar2(cc(1,1,itl),vtemp2(1))
9629 #endif
9630             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9631      &           auxmatd(1,1))
9632             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9633             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9634 c      s1d=0.0d0
9635 c      s2d=0.0d0
9636 c      s8d=0.0d0
9637 c      s12d=0.0d0
9638 c      s13d=0.0d0
9639 #ifdef MOMENT
9640             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9641      &        - 0.5d0*(s1d+s2d)
9642 #else
9643             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9644      &        - 0.5d0*s2d
9645 #endif
9646 #ifdef MOMENT
9647             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9648      &        - 0.5d0*(s8d+s12d)
9649 #else
9650             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9651      &        - 0.5d0*s12d
9652 #endif
9653           enddo
9654         enddo
9655       enddo
9656 #ifdef MOMENT
9657       do kkk=1,5
9658         do lll=1,3
9659           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9660      &      achuj_tempd(1,1))
9661           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9662           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9663           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9664           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9665           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9666      &      vtemp4d(1))
9667           ss13d = scalar2(b1(1,k),vtemp4d(1))
9668           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9669           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9670         enddo
9671       enddo
9672 #endif
9673 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9674 cd     &  16*eel_turn6_num
9675 cd      goto 1112
9676       if (j.lt.nres-1) then
9677         j1=j+1
9678         j2=j-1
9679       else
9680         j1=j-1
9681         j2=j-2
9682       endif
9683       if (l.lt.nres-1) then
9684         l1=l+1
9685         l2=l-1
9686       else
9687         l1=l-1
9688         l2=l-2
9689       endif
9690       do ll=1,3
9691 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9692 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9693 cgrad        ghalf=0.5d0*ggg1(ll)
9694 cd        ghalf=0.0d0
9695         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9696         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9697         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9698      &    +ekont*derx_turn(ll,2,1)
9699         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9700         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9701      &    +ekont*derx_turn(ll,4,1)
9702         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9703         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9704         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9705 cgrad        ghalf=0.5d0*ggg2(ll)
9706 cd        ghalf=0.0d0
9707         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9708      &    +ekont*derx_turn(ll,2,2)
9709         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9710         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9711      &    +ekont*derx_turn(ll,4,2)
9712         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9713         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9714         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9715       enddo
9716 cd      goto 1112
9717 cgrad      do m=i+1,j-1
9718 cgrad        do ll=1,3
9719 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9720 cgrad        enddo
9721 cgrad      enddo
9722 cgrad      do m=k+1,l-1
9723 cgrad        do ll=1,3
9724 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9725 cgrad        enddo
9726 cgrad      enddo
9727 cgrad1112  continue
9728 cgrad      do m=i+2,j2
9729 cgrad        do ll=1,3
9730 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9731 cgrad        enddo
9732 cgrad      enddo
9733 cgrad      do m=k+2,l2
9734 cgrad        do ll=1,3
9735 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9736 cgrad        enddo
9737 cgrad      enddo
9738 cd      do iii=1,nres-3
9739 cd        write (2,*) iii,g_corr6_loc(iii)
9740 cd      enddo
9741       eello_turn6=ekont*eel_turn6
9742 cd      write (2,*) 'ekont',ekont
9743 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9744       return
9745       end
9746
9747 C-----------------------------------------------------------------------------
9748       double precision function scalar(u,v)
9749 !DIR$ INLINEALWAYS scalar
9750 #ifndef OSF
9751 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9752 #endif
9753       implicit none
9754       double precision u(3),v(3)
9755 cd      double precision sc
9756 cd      integer i
9757 cd      sc=0.0d0
9758 cd      do i=1,3
9759 cd        sc=sc+u(i)*v(i)
9760 cd      enddo
9761 cd      scalar=sc
9762
9763       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9764       return
9765       end
9766 crc-------------------------------------------------
9767       SUBROUTINE MATVEC2(A1,V1,V2)
9768 !DIR$ INLINEALWAYS MATVEC2
9769 #ifndef OSF
9770 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9771 #endif
9772       implicit real*8 (a-h,o-z)
9773       include 'DIMENSIONS'
9774       DIMENSION A1(2,2),V1(2),V2(2)
9775 c      DO 1 I=1,2
9776 c        VI=0.0
9777 c        DO 3 K=1,2
9778 c    3     VI=VI+A1(I,K)*V1(K)
9779 c        Vaux(I)=VI
9780 c    1 CONTINUE
9781
9782       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9783       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9784
9785       v2(1)=vaux1
9786       v2(2)=vaux2
9787       END
9788 C---------------------------------------
9789       SUBROUTINE MATMAT2(A1,A2,A3)
9790 #ifndef OSF
9791 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9792 #endif
9793       implicit real*8 (a-h,o-z)
9794       include 'DIMENSIONS'
9795       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9796 c      DIMENSION AI3(2,2)
9797 c        DO  J=1,2
9798 c          A3IJ=0.0
9799 c          DO K=1,2
9800 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9801 c          enddo
9802 c          A3(I,J)=A3IJ
9803 c       enddo
9804 c      enddo
9805
9806       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9807       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9808       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9809       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9810
9811       A3(1,1)=AI3_11
9812       A3(2,1)=AI3_21
9813       A3(1,2)=AI3_12
9814       A3(2,2)=AI3_22
9815       END
9816
9817 c-------------------------------------------------------------------------
9818       double precision function scalar2(u,v)
9819 !DIR$ INLINEALWAYS scalar2
9820       implicit none
9821       double precision u(2),v(2)
9822       double precision sc
9823       integer i
9824       scalar2=u(1)*v(1)+u(2)*v(2)
9825       return
9826       end
9827
9828 C-----------------------------------------------------------------------------
9829
9830       subroutine transpose2(a,at)
9831 !DIR$ INLINEALWAYS transpose2
9832 #ifndef OSF
9833 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9834 #endif
9835       implicit none
9836       double precision a(2,2),at(2,2)
9837       at(1,1)=a(1,1)
9838       at(1,2)=a(2,1)
9839       at(2,1)=a(1,2)
9840       at(2,2)=a(2,2)
9841       return
9842       end
9843 c--------------------------------------------------------------------------
9844       subroutine transpose(n,a,at)
9845       implicit none
9846       integer n,i,j
9847       double precision a(n,n),at(n,n)
9848       do i=1,n
9849         do j=1,n
9850           at(j,i)=a(i,j)
9851         enddo
9852       enddo
9853       return
9854       end
9855 C---------------------------------------------------------------------------
9856       subroutine prodmat3(a1,a2,kk,transp,prod)
9857 !DIR$ INLINEALWAYS prodmat3
9858 #ifndef OSF
9859 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9860 #endif
9861       implicit none
9862       integer i,j
9863       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9864       logical transp
9865 crc      double precision auxmat(2,2),prod_(2,2)
9866
9867       if (transp) then
9868 crc        call transpose2(kk(1,1),auxmat(1,1))
9869 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9870 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9871
9872            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9873      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9874            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9875      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9876            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9877      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9878            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9879      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9880
9881       else
9882 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9883 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9884
9885            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9886      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9887            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9888      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9889            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9890      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9891            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9892      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9893
9894       endif
9895 c      call transpose2(a2(1,1),a2t(1,1))
9896
9897 crc      print *,transp
9898 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9899 crc      print *,((prod(i,j),i=1,2),j=1,2)
9900
9901       return
9902       end
9903