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    ! dyn_ss
1667           enddo      ! j
1668         enddo        ! iint
1669       enddo          ! i
1670 C      enddo          ! zshift
1671 C      enddo          ! yshift
1672 C      enddo          ! xshift
1673 c      write (iout,*) "Number of loop steps in EGB:",ind
1674 cccc      energy_dec=.false.
1675       return
1676       end
1677 C-----------------------------------------------------------------------------
1678       subroutine egbv(evdw)
1679 C
1680 C This subroutine calculates the interaction energy of nonbonded side chains
1681 C assuming the Gay-Berne-Vorobjev potential of interaction.
1682 C
1683       implicit real*8 (a-h,o-z)
1684       include 'DIMENSIONS'
1685       include 'COMMON.GEO'
1686       include 'COMMON.VAR'
1687       include 'COMMON.LOCAL'
1688       include 'COMMON.CHAIN'
1689       include 'COMMON.DERIV'
1690       include 'COMMON.NAMES'
1691       include 'COMMON.INTERACT'
1692       include 'COMMON.IOUNITS'
1693       include 'COMMON.CALC'
1694       common /srutu/ icall
1695       logical lprn
1696       evdw=0.0D0
1697 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1698       evdw=0.0D0
1699       lprn=.false.
1700 c     if (icall.eq.0) lprn=.true.
1701       ind=0
1702       do i=iatsc_s,iatsc_e
1703         itypi=iabs(itype(i))
1704         if (itypi.eq.ntyp1) cycle
1705         itypi1=iabs(itype(i+1))
1706         xi=c(1,nres+i)
1707         yi=c(2,nres+i)
1708         zi=c(3,nres+i)
1709         dxi=dc_norm(1,nres+i)
1710         dyi=dc_norm(2,nres+i)
1711         dzi=dc_norm(3,nres+i)
1712 c        dsci_inv=dsc_inv(itypi)
1713         dsci_inv=vbld_inv(i+nres)
1714 C
1715 C Calculate SC interaction energy.
1716 C
1717         do iint=1,nint_gr(i)
1718           do j=istart(i,iint),iend(i,iint)
1719             ind=ind+1
1720             itypj=iabs(itype(j))
1721             if (itypj.eq.ntyp1) cycle
1722 c            dscj_inv=dsc_inv(itypj)
1723             dscj_inv=vbld_inv(j+nres)
1724             sig0ij=sigma(itypi,itypj)
1725             r0ij=r0(itypi,itypj)
1726             chi1=chi(itypi,itypj)
1727             chi2=chi(itypj,itypi)
1728             chi12=chi1*chi2
1729             chip1=chip(itypi)
1730             chip2=chip(itypj)
1731             chip12=chip1*chip2
1732             alf1=alp(itypi)
1733             alf2=alp(itypj)
1734             alf12=0.5D0*(alf1+alf2)
1735 C For diagnostics only!!!
1736 c           chi1=0.0D0
1737 c           chi2=0.0D0
1738 c           chi12=0.0D0
1739 c           chip1=0.0D0
1740 c           chip2=0.0D0
1741 c           chip12=0.0D0
1742 c           alf1=0.0D0
1743 c           alf2=0.0D0
1744 c           alf12=0.0D0
1745             xj=c(1,nres+j)-xi
1746             yj=c(2,nres+j)-yi
1747             zj=c(3,nres+j)-zi
1748             dxj=dc_norm(1,nres+j)
1749             dyj=dc_norm(2,nres+j)
1750             dzj=dc_norm(3,nres+j)
1751             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1752             rij=dsqrt(rrij)
1753 C Calculate angle-dependent terms of energy and contributions to their
1754 C derivatives.
1755             call sc_angular
1756             sigsq=1.0D0/sigsq
1757             sig=sig0ij*dsqrt(sigsq)
1758             rij_shift=1.0D0/rij-sig+r0ij
1759 C I hate to put IF's in the loops, but here don't have another choice!!!!
1760             if (rij_shift.le.0.0D0) then
1761               evdw=1.0D20
1762               return
1763             endif
1764             sigder=-sig*sigsq
1765 c---------------------------------------------------------------
1766             rij_shift=1.0D0/rij_shift
1767             fac=rij_shift**expon
1768             e1=fac*fac*aa(itypi,itypj)
1769             e2=fac*bb(itypi,itypj)
1770             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1771             eps2der=evdwij*eps3rt
1772             eps3der=evdwij*eps2rt
1773             fac_augm=rrij**expon
1774             e_augm=augm(itypi,itypj)*fac_augm
1775             evdwij=evdwij*eps2rt*eps3rt
1776             evdw=evdw+evdwij+e_augm
1777             if (lprn) then
1778             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1779             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1780             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1781      &        restyp(itypi),i,restyp(itypj),j,
1782      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1783      &        chi1,chi2,chip1,chip2,
1784      &        eps1,eps2rt**2,eps3rt**2,
1785      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1786      &        evdwij+e_augm
1787             endif
1788 C Calculate gradient components.
1789             e1=e1*eps1*eps2rt**2*eps3rt**2
1790             fac=-expon*(e1+evdwij)*rij_shift
1791             sigder=fac*sigder
1792             fac=rij*fac-2*expon*rrij*e_augm
1793 C Calculate the radial part of the gradient
1794             gg(1)=xj*fac
1795             gg(2)=yj*fac
1796             gg(3)=zj*fac
1797 C Calculate angular part of the gradient.
1798             call sc_grad
1799           enddo      ! j
1800         enddo        ! iint
1801       enddo          ! i
1802       end
1803 C-----------------------------------------------------------------------------
1804       subroutine sc_angular
1805 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1806 C om12. Called by ebp, egb, and egbv.
1807       implicit none
1808       include 'COMMON.CALC'
1809       include 'COMMON.IOUNITS'
1810       erij(1)=xj*rij
1811       erij(2)=yj*rij
1812       erij(3)=zj*rij
1813       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1814       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1815       om12=dxi*dxj+dyi*dyj+dzi*dzj
1816       chiom12=chi12*om12
1817 C Calculate eps1(om12) and its derivative in om12
1818       faceps1=1.0D0-om12*chiom12
1819       faceps1_inv=1.0D0/faceps1
1820       eps1=dsqrt(faceps1_inv)
1821 C Following variable is eps1*deps1/dom12
1822       eps1_om12=faceps1_inv*chiom12
1823 c diagnostics only
1824 c      faceps1_inv=om12
1825 c      eps1=om12
1826 c      eps1_om12=1.0d0
1827 c      write (iout,*) "om12",om12," eps1",eps1
1828 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1829 C and om12.
1830       om1om2=om1*om2
1831       chiom1=chi1*om1
1832       chiom2=chi2*om2
1833       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1834       sigsq=1.0D0-facsig*faceps1_inv
1835       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1836       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1837       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1838 c diagnostics only
1839 c      sigsq=1.0d0
1840 c      sigsq_om1=0.0d0
1841 c      sigsq_om2=0.0d0
1842 c      sigsq_om12=0.0d0
1843 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1844 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1845 c     &    " eps1",eps1
1846 C Calculate eps2 and its derivatives in om1, om2, and om12.
1847       chipom1=chip1*om1
1848       chipom2=chip2*om2
1849       chipom12=chip12*om12
1850       facp=1.0D0-om12*chipom12
1851       facp_inv=1.0D0/facp
1852       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1853 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1854 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1855 C Following variable is the square root of eps2
1856       eps2rt=1.0D0-facp1*facp_inv
1857 C Following three variables are the derivatives of the square root of eps
1858 C in om1, om2, and om12.
1859       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1860       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1861       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1862 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1863       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1864 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1865 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1866 c     &  " eps2rt_om12",eps2rt_om12
1867 C Calculate whole angle-dependent part of epsilon and contributions
1868 C to its derivatives
1869       return
1870       end
1871 C----------------------------------------------------------------------------
1872       subroutine sc_grad
1873       implicit real*8 (a-h,o-z)
1874       include 'DIMENSIONS'
1875       include 'COMMON.CHAIN'
1876       include 'COMMON.DERIV'
1877       include 'COMMON.CALC'
1878       include 'COMMON.IOUNITS'
1879       double precision dcosom1(3),dcosom2(3)
1880 cc      print *,'sss=',sss
1881       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1882       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1883       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1884      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1885 c diagnostics only
1886 c      eom1=0.0d0
1887 c      eom2=0.0d0
1888 c      eom12=evdwij*eps1_om12
1889 c end diagnostics
1890 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1891 c     &  " sigder",sigder
1892 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1893 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1894       do k=1,3
1895         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1896         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1897       enddo
1898       do k=1,3
1899         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1900       enddo
1901 c      write (iout,*) "gg",(gg(k),k=1,3)
1902       do k=1,3
1903         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1904      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1905      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1906         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1907      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1908      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1909 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1910 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1911 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1912 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1913       enddo
1914 C
1915 C Calculate the components of the gradient in DC and X
1916 C
1917 cgrad      do k=i,j-1
1918 cgrad        do l=1,3
1919 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1920 cgrad        enddo
1921 cgrad      enddo
1922       do l=1,3
1923         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1924         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1925       enddo
1926       return
1927       end
1928 C-----------------------------------------------------------------------
1929       subroutine e_softsphere(evdw)
1930 C
1931 C This subroutine calculates the interaction energy of nonbonded side chains
1932 C assuming the LJ potential of interaction.
1933 C
1934       implicit real*8 (a-h,o-z)
1935       include 'DIMENSIONS'
1936       parameter (accur=1.0d-10)
1937       include 'COMMON.GEO'
1938       include 'COMMON.VAR'
1939       include 'COMMON.LOCAL'
1940       include 'COMMON.CHAIN'
1941       include 'COMMON.DERIV'
1942       include 'COMMON.INTERACT'
1943       include 'COMMON.TORSION'
1944       include 'COMMON.SBRIDGE'
1945       include 'COMMON.NAMES'
1946       include 'COMMON.IOUNITS'
1947       include 'COMMON.CONTACTS'
1948       dimension gg(3)
1949 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1950       evdw=0.0D0
1951       do i=iatsc_s,iatsc_e
1952         itypi=iabs(itype(i))
1953         if (itypi.eq.ntyp1) cycle
1954         itypi1=iabs(itype(i+1))
1955         xi=c(1,nres+i)
1956         yi=c(2,nres+i)
1957         zi=c(3,nres+i)
1958 C
1959 C Calculate SC interaction energy.
1960 C
1961         do iint=1,nint_gr(i)
1962 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1963 cd   &                  'iend=',iend(i,iint)
1964           do j=istart(i,iint),iend(i,iint)
1965             itypj=iabs(itype(j))
1966             if (itypj.eq.ntyp1) cycle
1967             xj=c(1,nres+j)-xi
1968             yj=c(2,nres+j)-yi
1969             zj=c(3,nres+j)-zi
1970             rij=xj*xj+yj*yj+zj*zj
1971 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1972             r0ij=r0(itypi,itypj)
1973             r0ijsq=r0ij*r0ij
1974 c            print *,i,j,r0ij,dsqrt(rij)
1975             if (rij.lt.r0ijsq) then
1976               evdwij=0.25d0*(rij-r0ijsq)**2
1977               fac=rij-r0ijsq
1978             else
1979               evdwij=0.0d0
1980               fac=0.0d0
1981             endif
1982             evdw=evdw+evdwij
1983 C
1984 C Calculate the components of the gradient in DC and X
1985 C
1986             gg(1)=xj*fac
1987             gg(2)=yj*fac
1988             gg(3)=zj*fac
1989             do k=1,3
1990               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1991               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1992               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1993               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1994             enddo
1995 cgrad            do k=i,j-1
1996 cgrad              do l=1,3
1997 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1998 cgrad              enddo
1999 cgrad            enddo
2000           enddo ! j
2001         enddo ! iint
2002       enddo ! i
2003       return
2004       end
2005 C--------------------------------------------------------------------------
2006       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2007      &              eello_turn4)
2008 C
2009 C Soft-sphere potential of p-p interaction
2010 C
2011       implicit real*8 (a-h,o-z)
2012       include 'DIMENSIONS'
2013       include 'COMMON.CONTROL'
2014       include 'COMMON.IOUNITS'
2015       include 'COMMON.GEO'
2016       include 'COMMON.VAR'
2017       include 'COMMON.LOCAL'
2018       include 'COMMON.CHAIN'
2019       include 'COMMON.DERIV'
2020       include 'COMMON.INTERACT'
2021       include 'COMMON.CONTACTS'
2022       include 'COMMON.TORSION'
2023       include 'COMMON.VECTORS'
2024       include 'COMMON.FFIELD'
2025       dimension ggg(3)
2026 C      write(iout,*) 'In EELEC_soft_sphere'
2027       ees=0.0D0
2028       evdw1=0.0D0
2029       eel_loc=0.0d0
2030       eello_turn3=0.0d0
2031       eello_turn4=0.0d0
2032       ind=0
2033       do i=iatel_s,iatel_e
2034         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2035         dxi=dc(1,i)
2036         dyi=dc(2,i)
2037         dzi=dc(3,i)
2038         xmedi=c(1,i)+0.5d0*dxi
2039         ymedi=c(2,i)+0.5d0*dyi
2040         zmedi=c(3,i)+0.5d0*dzi
2041           xmedi=mod(xmedi,boxxsize)
2042           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2043           ymedi=mod(ymedi,boxysize)
2044           if (ymedi.lt.0) ymedi=ymedi+boxysize
2045           zmedi=mod(zmedi,boxzsize)
2046           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2047         num_conti=0
2048 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2049         do j=ielstart(i),ielend(i)
2050           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2051           ind=ind+1
2052           iteli=itel(i)
2053           itelj=itel(j)
2054           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2055           r0ij=rpp(iteli,itelj)
2056           r0ijsq=r0ij*r0ij
2057           dxj=dc(1,j)
2058           dyj=dc(2,j)
2059           dzj=dc(3,j)
2060           xj=c(1,j)+0.5D0*dxj
2061           yj=c(2,j)+0.5D0*dyj
2062           zj=c(3,j)+0.5D0*dzj
2063           xj=mod(xj,boxxsize)
2064           if (xj.lt.0) xj=xj+boxxsize
2065           yj=mod(yj,boxysize)
2066           if (yj.lt.0) yj=yj+boxysize
2067           zj=mod(zj,boxzsize)
2068           if (zj.lt.0) zj=zj+boxzsize
2069       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2070       xj_safe=xj
2071       yj_safe=yj
2072       zj_safe=zj
2073       isubchap=0
2074       do xshift=-1,1
2075       do yshift=-1,1
2076       do zshift=-1,1
2077           xj=xj_safe+xshift*boxxsize
2078           yj=yj_safe+yshift*boxysize
2079           zj=zj_safe+zshift*boxzsize
2080           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2081           if(dist_temp.lt.dist_init) then
2082             dist_init=dist_temp
2083             xj_temp=xj
2084             yj_temp=yj
2085             zj_temp=zj
2086             isubchap=1
2087           endif
2088        enddo
2089        enddo
2090        enddo
2091        if (isubchap.eq.1) then
2092           xj=xj_temp-xmedi
2093           yj=yj_temp-ymedi
2094           zj=zj_temp-zmedi
2095        else
2096           xj=xj_safe-xmedi
2097           yj=yj_safe-ymedi
2098           zj=zj_safe-zmedi
2099        endif
2100           rij=xj*xj+yj*yj+zj*zj
2101             sss=sscale(sqrt(rij))
2102             sssgrad=sscagrad(sqrt(rij))
2103           if (rij.lt.r0ijsq) then
2104             evdw1ij=0.25d0*(rij-r0ijsq)**2
2105             fac=rij-r0ijsq
2106           else
2107             evdw1ij=0.0d0
2108             fac=0.0d0
2109           endif
2110           evdw1=evdw1+evdw1ij*sss
2111 C
2112 C Calculate contributions to the Cartesian gradient.
2113 C
2114           ggg(1)=fac*xj*sssgrad
2115           ggg(2)=fac*yj*sssgrad
2116           ggg(3)=fac*zj*sssgrad
2117           do k=1,3
2118             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2119             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2120           enddo
2121 *
2122 * Loop over residues i+1 thru j-1.
2123 *
2124 cgrad          do k=i+1,j-1
2125 cgrad            do l=1,3
2126 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2127 cgrad            enddo
2128 cgrad          enddo
2129         enddo ! j
2130       enddo   ! i
2131 cgrad      do i=nnt,nct-1
2132 cgrad        do k=1,3
2133 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2134 cgrad        enddo
2135 cgrad        do j=i+1,nct-1
2136 cgrad          do k=1,3
2137 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2138 cgrad          enddo
2139 cgrad        enddo
2140 cgrad      enddo
2141       return
2142       end
2143 c------------------------------------------------------------------------------
2144       subroutine vec_and_deriv
2145       implicit real*8 (a-h,o-z)
2146       include 'DIMENSIONS'
2147 #ifdef MPI
2148       include 'mpif.h'
2149 #endif
2150       include 'COMMON.IOUNITS'
2151       include 'COMMON.GEO'
2152       include 'COMMON.VAR'
2153       include 'COMMON.LOCAL'
2154       include 'COMMON.CHAIN'
2155       include 'COMMON.VECTORS'
2156       include 'COMMON.SETUP'
2157       include 'COMMON.TIME1'
2158       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2159 C Compute the local reference systems. For reference system (i), the
2160 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2161 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2162 #ifdef PARVEC
2163       do i=ivec_start,ivec_end
2164 #else
2165       do i=1,nres-1
2166 #endif
2167           if (i.eq.nres-1) then
2168 C Case of the last full residue
2169 C Compute the Z-axis
2170             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2171             costh=dcos(pi-theta(nres))
2172             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2173             do k=1,3
2174               uz(k,i)=fac*uz(k,i)
2175             enddo
2176 C Compute the derivatives of uz
2177             uzder(1,1,1)= 0.0d0
2178             uzder(2,1,1)=-dc_norm(3,i-1)
2179             uzder(3,1,1)= dc_norm(2,i-1)
2180             uzder(1,2,1)= dc_norm(3,i-1)
2181             uzder(2,2,1)= 0.0d0
2182             uzder(3,2,1)=-dc_norm(1,i-1)
2183             uzder(1,3,1)=-dc_norm(2,i-1)
2184             uzder(2,3,1)= dc_norm(1,i-1)
2185             uzder(3,3,1)= 0.0d0
2186             uzder(1,1,2)= 0.0d0
2187             uzder(2,1,2)= dc_norm(3,i)
2188             uzder(3,1,2)=-dc_norm(2,i)
2189             uzder(1,2,2)=-dc_norm(3,i)
2190             uzder(2,2,2)= 0.0d0
2191             uzder(3,2,2)= dc_norm(1,i)
2192             uzder(1,3,2)= dc_norm(2,i)
2193             uzder(2,3,2)=-dc_norm(1,i)
2194             uzder(3,3,2)= 0.0d0
2195 C Compute the Y-axis
2196             facy=fac
2197             do k=1,3
2198               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2199             enddo
2200 C Compute the derivatives of uy
2201             do j=1,3
2202               do k=1,3
2203                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2204      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2205                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2206               enddo
2207               uyder(j,j,1)=uyder(j,j,1)-costh
2208               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2209             enddo
2210             do j=1,2
2211               do k=1,3
2212                 do l=1,3
2213                   uygrad(l,k,j,i)=uyder(l,k,j)
2214                   uzgrad(l,k,j,i)=uzder(l,k,j)
2215                 enddo
2216               enddo
2217             enddo
2218             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2219             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2220             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2221             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2222           else
2223 C Other residues
2224 C Compute the Z-axis
2225             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2226             costh=dcos(pi-theta(i+2))
2227             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2228             do k=1,3
2229               uz(k,i)=fac*uz(k,i)
2230             enddo
2231 C Compute the derivatives of uz
2232             uzder(1,1,1)= 0.0d0
2233             uzder(2,1,1)=-dc_norm(3,i+1)
2234             uzder(3,1,1)= dc_norm(2,i+1)
2235             uzder(1,2,1)= dc_norm(3,i+1)
2236             uzder(2,2,1)= 0.0d0
2237             uzder(3,2,1)=-dc_norm(1,i+1)
2238             uzder(1,3,1)=-dc_norm(2,i+1)
2239             uzder(2,3,1)= dc_norm(1,i+1)
2240             uzder(3,3,1)= 0.0d0
2241             uzder(1,1,2)= 0.0d0
2242             uzder(2,1,2)= dc_norm(3,i)
2243             uzder(3,1,2)=-dc_norm(2,i)
2244             uzder(1,2,2)=-dc_norm(3,i)
2245             uzder(2,2,2)= 0.0d0
2246             uzder(3,2,2)= dc_norm(1,i)
2247             uzder(1,3,2)= dc_norm(2,i)
2248             uzder(2,3,2)=-dc_norm(1,i)
2249             uzder(3,3,2)= 0.0d0
2250 C Compute the Y-axis
2251             facy=fac
2252             do k=1,3
2253               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2254             enddo
2255 C Compute the derivatives of uy
2256             do j=1,3
2257               do k=1,3
2258                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2259      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2260                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2261               enddo
2262               uyder(j,j,1)=uyder(j,j,1)-costh
2263               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2264             enddo
2265             do j=1,2
2266               do k=1,3
2267                 do l=1,3
2268                   uygrad(l,k,j,i)=uyder(l,k,j)
2269                   uzgrad(l,k,j,i)=uzder(l,k,j)
2270                 enddo
2271               enddo
2272             enddo
2273             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2274             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2275             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2276             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2277           endif
2278       enddo
2279       do i=1,nres-1
2280         vbld_inv_temp(1)=vbld_inv(i+1)
2281         if (i.lt.nres-1) then
2282           vbld_inv_temp(2)=vbld_inv(i+2)
2283           else
2284           vbld_inv_temp(2)=vbld_inv(i)
2285           endif
2286         do j=1,2
2287           do k=1,3
2288             do l=1,3
2289               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2290               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2291             enddo
2292           enddo
2293         enddo
2294       enddo
2295 #if defined(PARVEC) && defined(MPI)
2296       if (nfgtasks1.gt.1) then
2297         time00=MPI_Wtime()
2298 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2299 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2300 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2301         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2302      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2303      &   FG_COMM1,IERR)
2304         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2305      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2306      &   FG_COMM1,IERR)
2307         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2308      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2309      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2310         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2311      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2312      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2313         time_gather=time_gather+MPI_Wtime()-time00
2314       endif
2315 c      if (fg_rank.eq.0) then
2316 c        write (iout,*) "Arrays UY and UZ"
2317 c        do i=1,nres-1
2318 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2319 c     &     (uz(k,i),k=1,3)
2320 c        enddo
2321 c      endif
2322 #endif
2323       return
2324       end
2325 C-----------------------------------------------------------------------------
2326       subroutine check_vecgrad
2327       implicit real*8 (a-h,o-z)
2328       include 'DIMENSIONS'
2329       include 'COMMON.IOUNITS'
2330       include 'COMMON.GEO'
2331       include 'COMMON.VAR'
2332       include 'COMMON.LOCAL'
2333       include 'COMMON.CHAIN'
2334       include 'COMMON.VECTORS'
2335       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2336       dimension uyt(3,maxres),uzt(3,maxres)
2337       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2338       double precision delta /1.0d-7/
2339       call vec_and_deriv
2340 cd      do i=1,nres
2341 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2344 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2345 cd     &     (dc_norm(if90,i),if90=1,3)
2346 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2348 cd          write(iout,'(a)')
2349 cd      enddo
2350       do i=1,nres
2351         do j=1,2
2352           do k=1,3
2353             do l=1,3
2354               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2355               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2356             enddo
2357           enddo
2358         enddo
2359       enddo
2360       call vec_and_deriv
2361       do i=1,nres
2362         do j=1,3
2363           uyt(j,i)=uy(j,i)
2364           uzt(j,i)=uz(j,i)
2365         enddo
2366       enddo
2367       do i=1,nres
2368 cd        write (iout,*) 'i=',i
2369         do k=1,3
2370           erij(k)=dc_norm(k,i)
2371         enddo
2372         do j=1,3
2373           do k=1,3
2374             dc_norm(k,i)=erij(k)
2375           enddo
2376           dc_norm(j,i)=dc_norm(j,i)+delta
2377 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2378 c          do k=1,3
2379 c            dc_norm(k,i)=dc_norm(k,i)/fac
2380 c          enddo
2381 c          write (iout,*) (dc_norm(k,i),k=1,3)
2382 c          write (iout,*) (erij(k),k=1,3)
2383           call vec_and_deriv
2384           do k=1,3
2385             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2386             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2387             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2388             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2389           enddo
2390 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2391 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2392 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2393         enddo
2394         do k=1,3
2395           dc_norm(k,i)=erij(k)
2396         enddo
2397 cd        do k=1,3
2398 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2399 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2400 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2401 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2402 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2403 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2404 cd          write (iout,'(a)')
2405 cd        enddo
2406       enddo
2407       return
2408       end
2409 C--------------------------------------------------------------------------
2410       subroutine set_matrices
2411       implicit real*8 (a-h,o-z)
2412       include 'DIMENSIONS'
2413 #ifdef MPI
2414       include "mpif.h"
2415       include "COMMON.SETUP"
2416       integer IERR
2417       integer status(MPI_STATUS_SIZE)
2418 #endif
2419       include 'COMMON.IOUNITS'
2420       include 'COMMON.GEO'
2421       include 'COMMON.VAR'
2422       include 'COMMON.LOCAL'
2423       include 'COMMON.CHAIN'
2424       include 'COMMON.DERIV'
2425       include 'COMMON.INTERACT'
2426       include 'COMMON.CONTACTS'
2427       include 'COMMON.TORSION'
2428       include 'COMMON.VECTORS'
2429       include 'COMMON.FFIELD'
2430       double precision auxvec(2),auxmat(2,2)
2431 C
2432 C Compute the virtual-bond-torsional-angle dependent quantities needed
2433 C to calculate the el-loc multibody terms of various order.
2434 C
2435 c      write(iout,*) 'nphi=',nphi,nres
2436 #ifdef PARMAT
2437       do i=ivec_start+2,ivec_end+2
2438 #else
2439       do i=3,nres+1
2440 #endif
2441 #ifdef NEWCORR
2442         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2443           iti = itortyp(itype(i-2))
2444         else
2445           iti=ntortyp+1
2446         endif
2447 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2448         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2449           iti1 = itortyp(itype(i-1))
2450         else
2451           iti1=ntortyp+1
2452         endif
2453 c        write(iout,*),i
2454         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2455      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2456      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2457         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2458      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2459      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2460 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2461 c     &*(cos(theta(i)/2.0)
2462         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2463      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2464      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2465 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2466 c     &*(cos(theta(i)/2.0)
2467         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2468      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2469      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2470 c        if (ggb1(1,i).eq.0.0d0) then
2471 c        write(iout,*) 'i=',i,ggb1(1,i),
2472 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2473 c     &bnew1(2,1,iti)*cos(theta(i)),
2474 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2475 c        endif
2476         b1(2,i-2)=bnew1(1,2,iti)
2477         gtb1(2,i-2)=0.0
2478         b2(2,i-2)=bnew2(1,2,iti)
2479         gtb2(2,i-2)=0.0
2480         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2481         EE(1,2,i-2)=eeold(1,2,iti)
2482         EE(2,1,i-2)=eeold(2,1,iti)
2483         EE(2,2,i-2)=eeold(2,2,iti)
2484         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2485         gtEE(1,2,i-2)=0.0d0
2486         gtEE(2,2,i-2)=0.0d0
2487         gtEE(2,1,i-2)=0.0d0
2488 c        EE(2,2,iti)=0.0d0
2489 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2490 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2491 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2492 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2493        b1tilde(1,i-2)=b1(1,i-2)
2494        b1tilde(2,i-2)=-b1(2,i-2)
2495        b2tilde(1,i-2)=b2(1,i-2)
2496        b2tilde(2,i-2)=-b2(2,i-2)
2497 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2498 c       write(iout,*)  'b1=',b1(1,i-2)
2499 c       write (iout,*) 'theta=', theta(i-1)
2500        enddo
2501 #ifdef PARMAT
2502       do i=ivec_start+2,ivec_end+2
2503 #else
2504       do i=3,nres+1
2505 #endif
2506 #endif
2507         if (i .lt. nres+1) then
2508           sin1=dsin(phi(i))
2509           cos1=dcos(phi(i))
2510           sintab(i-2)=sin1
2511           costab(i-2)=cos1
2512           obrot(1,i-2)=cos1
2513           obrot(2,i-2)=sin1
2514           sin2=dsin(2*phi(i))
2515           cos2=dcos(2*phi(i))
2516           sintab2(i-2)=sin2
2517           costab2(i-2)=cos2
2518           obrot2(1,i-2)=cos2
2519           obrot2(2,i-2)=sin2
2520           Ug(1,1,i-2)=-cos1
2521           Ug(1,2,i-2)=-sin1
2522           Ug(2,1,i-2)=-sin1
2523           Ug(2,2,i-2)= cos1
2524           Ug2(1,1,i-2)=-cos2
2525           Ug2(1,2,i-2)=-sin2
2526           Ug2(2,1,i-2)=-sin2
2527           Ug2(2,2,i-2)= cos2
2528         else
2529           costab(i-2)=1.0d0
2530           sintab(i-2)=0.0d0
2531           obrot(1,i-2)=1.0d0
2532           obrot(2,i-2)=0.0d0
2533           obrot2(1,i-2)=0.0d0
2534           obrot2(2,i-2)=0.0d0
2535           Ug(1,1,i-2)=1.0d0
2536           Ug(1,2,i-2)=0.0d0
2537           Ug(2,1,i-2)=0.0d0
2538           Ug(2,2,i-2)=1.0d0
2539           Ug2(1,1,i-2)=0.0d0
2540           Ug2(1,2,i-2)=0.0d0
2541           Ug2(2,1,i-2)=0.0d0
2542           Ug2(2,2,i-2)=0.0d0
2543         endif
2544         if (i .gt. 3 .and. i .lt. nres+1) then
2545           obrot_der(1,i-2)=-sin1
2546           obrot_der(2,i-2)= cos1
2547           Ugder(1,1,i-2)= sin1
2548           Ugder(1,2,i-2)=-cos1
2549           Ugder(2,1,i-2)=-cos1
2550           Ugder(2,2,i-2)=-sin1
2551           dwacos2=cos2+cos2
2552           dwasin2=sin2+sin2
2553           obrot2_der(1,i-2)=-dwasin2
2554           obrot2_der(2,i-2)= dwacos2
2555           Ug2der(1,1,i-2)= dwasin2
2556           Ug2der(1,2,i-2)=-dwacos2
2557           Ug2der(2,1,i-2)=-dwacos2
2558           Ug2der(2,2,i-2)=-dwasin2
2559         else
2560           obrot_der(1,i-2)=0.0d0
2561           obrot_der(2,i-2)=0.0d0
2562           Ugder(1,1,i-2)=0.0d0
2563           Ugder(1,2,i-2)=0.0d0
2564           Ugder(2,1,i-2)=0.0d0
2565           Ugder(2,2,i-2)=0.0d0
2566           obrot2_der(1,i-2)=0.0d0
2567           obrot2_der(2,i-2)=0.0d0
2568           Ug2der(1,1,i-2)=0.0d0
2569           Ug2der(1,2,i-2)=0.0d0
2570           Ug2der(2,1,i-2)=0.0d0
2571           Ug2der(2,2,i-2)=0.0d0
2572         endif
2573 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2574         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2575           iti = itortyp(itype(i-2))
2576         else
2577           iti=ntortyp
2578         endif
2579 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2580         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2581           iti1 = itortyp(itype(i-1))
2582         else
2583           iti1=ntortyp
2584         endif
2585 cd        write (iout,*) '*******i',i,' iti1',iti
2586 cd        write (iout,*) 'b1',b1(:,iti)
2587 cd        write (iout,*) 'b2',b2(:,iti)
2588 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2589 c        if (i .gt. iatel_s+2) then
2590         if (i .gt. nnt+2) then
2591           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2592 #ifdef NEWCORR
2593           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2594 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2595 #endif
2596 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2597 c     &    EE(1,2,iti),EE(2,2,iti)
2598           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2599           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2600 c          write(iout,*) "Macierz EUG",
2601 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2602 c     &    eug(2,2,i-2)
2603           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2604      &    then
2605           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2606           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2607           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2608           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2609           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2610           endif
2611         else
2612           do k=1,2
2613             Ub2(k,i-2)=0.0d0
2614             Ctobr(k,i-2)=0.0d0
2615             Dtobr2(k,i-2)=0.0d0
2616             do l=1,2
2617               EUg(l,k,i-2)=0.0d0
2618               CUg(l,k,i-2)=0.0d0
2619               DUg(l,k,i-2)=0.0d0
2620               DtUg2(l,k,i-2)=0.0d0
2621             enddo
2622           enddo
2623         endif
2624         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2625         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2626         do k=1,2
2627           muder(k,i-2)=Ub2der(k,i-2)
2628         enddo
2629 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2630         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2631           if (itype(i-1).le.ntyp) then
2632             iti1 = itortyp(itype(i-1))
2633           else
2634             iti1=ntortyp
2635           endif
2636         else
2637           iti1=ntortyp
2638         endif
2639         do k=1,2
2640           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2641         enddo
2642 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2643 cd        write (iout,*) 'mu1',mu1(:,i-2)
2644 cd        write (iout,*) 'mu2',mu2(:,i-2)
2645         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2646      &  then
2647         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2648         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2649         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2650         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2651         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2652 C Vectors and matrices dependent on a single virtual-bond dihedral.
2653         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2654         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2655         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2656         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2657         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2658         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2659         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2660         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2661         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2662         endif
2663       enddo
2664 C Matrices dependent on two consecutive virtual-bond dihedrals.
2665 C The order of matrices is from left to right.
2666       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2667      &then
2668 c      do i=max0(ivec_start,2),ivec_end
2669       do i=2,nres-1
2670         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2671         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2672         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2673         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2674         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2675         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2676         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2677         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2678       enddo
2679       endif
2680 #if defined(MPI) && defined(PARMAT)
2681 #ifdef DEBUG
2682 c      if (fg_rank.eq.0) then
2683         write (iout,*) "Arrays UG and UGDER before GATHER"
2684         do i=1,nres-1
2685           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2686      &     ((ug(l,k,i),l=1,2),k=1,2),
2687      &     ((ugder(l,k,i),l=1,2),k=1,2)
2688         enddo
2689         write (iout,*) "Arrays UG2 and UG2DER"
2690         do i=1,nres-1
2691           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2692      &     ((ug2(l,k,i),l=1,2),k=1,2),
2693      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2694         enddo
2695         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2696         do i=1,nres-1
2697           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2698      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2699      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2700         enddo
2701         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2702         do i=1,nres-1
2703           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2704      &     costab(i),sintab(i),costab2(i),sintab2(i)
2705         enddo
2706         write (iout,*) "Array MUDER"
2707         do i=1,nres-1
2708           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2709         enddo
2710 c      endif
2711 #endif
2712       if (nfgtasks.gt.1) then
2713         time00=MPI_Wtime()
2714 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2715 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2716 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2717 #ifdef MATGATHER
2718         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2719      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2720      &   FG_COMM1,IERR)
2721         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2722      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2723      &   FG_COMM1,IERR)
2724         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2725      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2726      &   FG_COMM1,IERR)
2727         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2732      &   FG_COMM1,IERR)
2733         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2737      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2738      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2739         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2740      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2741      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2742         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2743      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2744      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2745         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2746      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2747      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2748         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2749      &  then
2750         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2757      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2758      &   FG_COMM1,IERR)
2759        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2766      &   ivec_count(fg_rank1),
2767      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2768      &   FG_COMM1,IERR)
2769         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2770      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2771      &   FG_COMM1,IERR)
2772         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2773      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2774      &   FG_COMM1,IERR)
2775         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2777      &   FG_COMM1,IERR)
2778         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2791      &   ivec_count(fg_rank1),
2792      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2793      &   FG_COMM1,IERR)
2794         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2795      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2796      &   FG_COMM1,IERR)
2797        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2798      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2799      &   FG_COMM1,IERR)
2800         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2801      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2802      &   FG_COMM1,IERR)
2803        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2804      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2807      &   ivec_count(fg_rank1),
2808      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2811      &   ivec_count(fg_rank1),
2812      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2813      &   FG_COMM1,IERR)
2814         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2815      &   ivec_count(fg_rank1),
2816      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2817      &   MPI_MAT2,FG_COMM1,IERR)
2818         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2819      &   ivec_count(fg_rank1),
2820      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2821      &   MPI_MAT2,FG_COMM1,IERR)
2822         endif
2823 #else
2824 c Passes matrix info through the ring
2825       isend=fg_rank1
2826       irecv=fg_rank1-1
2827       if (irecv.lt.0) irecv=nfgtasks1-1
2828       iprev=irecv
2829       inext=fg_rank1+1
2830       if (inext.ge.nfgtasks1) inext=0
2831       do i=1,nfgtasks1-1
2832 c        write (iout,*) "isend",isend," irecv",irecv
2833 c        call flush(iout)
2834         lensend=lentyp(isend)
2835         lenrecv=lentyp(irecv)
2836 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2837 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2838 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2839 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2840 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2841 c        write (iout,*) "Gather ROTAT1"
2842 c        call flush(iout)
2843 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2844 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2845 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2846 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2847 c        write (iout,*) "Gather ROTAT2"
2848 c        call flush(iout)
2849         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2850      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2851      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2852      &   iprev,4400+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather ROTAT_OLD"
2854 c        call flush(iout)
2855         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2856      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2857      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2858      &   iprev,5500+irecv,FG_COMM,status,IERR)
2859 c        write (iout,*) "Gather PRECOMP11"
2860 c        call flush(iout)
2861         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2862      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2863      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2864      &   iprev,6600+irecv,FG_COMM,status,IERR)
2865 c        write (iout,*) "Gather PRECOMP12"
2866 c        call flush(iout)
2867         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2868      &  then
2869         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2870      &   MPI_ROTAT2(lensend),inext,7700+isend,
2871      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2872      &   iprev,7700+irecv,FG_COMM,status,IERR)
2873 c        write (iout,*) "Gather PRECOMP21"
2874 c        call flush(iout)
2875         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2876      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2877      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2878      &   iprev,8800+irecv,FG_COMM,status,IERR)
2879 c        write (iout,*) "Gather PRECOMP22"
2880 c        call flush(iout)
2881         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2882      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2883      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2884      &   MPI_PRECOMP23(lenrecv),
2885      &   iprev,9900+irecv,FG_COMM,status,IERR)
2886 c        write (iout,*) "Gather PRECOMP23"
2887 c        call flush(iout)
2888         endif
2889         isend=irecv
2890         irecv=irecv-1
2891         if (irecv.lt.0) irecv=nfgtasks1-1
2892       enddo
2893 #endif
2894         time_gather=time_gather+MPI_Wtime()-time00
2895       endif
2896 #ifdef DEBUG
2897 c      if (fg_rank.eq.0) then
2898         write (iout,*) "Arrays UG and UGDER"
2899         do i=1,nres-1
2900           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2901      &     ((ug(l,k,i),l=1,2),k=1,2),
2902      &     ((ugder(l,k,i),l=1,2),k=1,2)
2903         enddo
2904         write (iout,*) "Arrays UG2 and UG2DER"
2905         do i=1,nres-1
2906           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2907      &     ((ug2(l,k,i),l=1,2),k=1,2),
2908      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2909         enddo
2910         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2911         do i=1,nres-1
2912           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2913      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2914      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2915         enddo
2916         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2917         do i=1,nres-1
2918           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2919      &     costab(i),sintab(i),costab2(i),sintab2(i)
2920         enddo
2921         write (iout,*) "Array MUDER"
2922         do i=1,nres-1
2923           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2924         enddo
2925 c      endif
2926 #endif
2927 #endif
2928 cd      do i=1,nres
2929 cd        iti = itortyp(itype(i))
2930 cd        write (iout,*) i
2931 cd        do j=1,2
2932 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2933 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2934 cd        enddo
2935 cd      enddo
2936       return
2937       end
2938 C--------------------------------------------------------------------------
2939       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2940 C
2941 C This subroutine calculates the average interaction energy and its gradient
2942 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2943 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2944 C The potential depends both on the distance of peptide-group centers and on
2945 C the orientation of the CA-CA virtual bonds.
2946 C
2947       implicit real*8 (a-h,o-z)
2948 #ifdef MPI
2949       include 'mpif.h'
2950 #endif
2951       include 'DIMENSIONS'
2952       include 'COMMON.CONTROL'
2953       include 'COMMON.SETUP'
2954       include 'COMMON.IOUNITS'
2955       include 'COMMON.GEO'
2956       include 'COMMON.VAR'
2957       include 'COMMON.LOCAL'
2958       include 'COMMON.CHAIN'
2959       include 'COMMON.DERIV'
2960       include 'COMMON.INTERACT'
2961       include 'COMMON.CONTACTS'
2962       include 'COMMON.TORSION'
2963       include 'COMMON.VECTORS'
2964       include 'COMMON.FFIELD'
2965       include 'COMMON.TIME1'
2966       include 'COMMON.SPLITELE'
2967       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2968      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2969       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2970      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2971       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2972      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2973      &    num_conti,j1,j2
2974 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2975 #ifdef MOMENT
2976       double precision scal_el /1.0d0/
2977 #else
2978       double precision scal_el /0.5d0/
2979 #endif
2980 C 12/13/98
2981 C 13-go grudnia roku pamietnego...
2982       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2983      &                   0.0d0,1.0d0,0.0d0,
2984      &                   0.0d0,0.0d0,1.0d0/
2985 cd      write(iout,*) 'In EELEC'
2986 cd      do i=1,nloctyp
2987 cd        write(iout,*) 'Type',i
2988 cd        write(iout,*) 'B1',B1(:,i)
2989 cd        write(iout,*) 'B2',B2(:,i)
2990 cd        write(iout,*) 'CC',CC(:,:,i)
2991 cd        write(iout,*) 'DD',DD(:,:,i)
2992 cd        write(iout,*) 'EE',EE(:,:,i)
2993 cd      enddo
2994 cd      call check_vecgrad
2995 cd      stop
2996       if (icheckgrad.eq.1) then
2997         do i=1,nres-1
2998           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2999           do k=1,3
3000             dc_norm(k,i)=dc(k,i)*fac
3001           enddo
3002 c          write (iout,*) 'i',i,' fac',fac
3003         enddo
3004       endif
3005       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3006      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3007      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3008 c        call vec_and_deriv
3009 #ifdef TIMING
3010         time01=MPI_Wtime()
3011 #endif
3012         call set_matrices
3013 #ifdef TIMING
3014         time_mat=time_mat+MPI_Wtime()-time01
3015 #endif
3016       endif
3017 cd      do i=1,nres-1
3018 cd        write (iout,*) 'i=',i
3019 cd        do k=1,3
3020 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3021 cd        enddo
3022 cd        do k=1,3
3023 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3024 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3025 cd        enddo
3026 cd      enddo
3027       t_eelecij=0.0d0
3028       ees=0.0D0
3029       evdw1=0.0D0
3030       eel_loc=0.0d0
3031       eello_turn3=0.0d0
3032       eello_turn4=0.0d0
3033       ind=0
3034       do i=1,nres
3035         num_cont_hb(i)=0
3036       enddo
3037 cd      print '(a)','Enter EELEC'
3038 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3039       do i=1,nres
3040         gel_loc_loc(i)=0.0d0
3041         gcorr_loc(i)=0.0d0
3042       enddo
3043 c
3044 c
3045 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3046 C
3047 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3048 C
3049 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3050       do i=iturn3_start,iturn3_end
3051         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3052      &  .or. itype(i+2).eq.ntyp1
3053      &  .or. itype(i+3).eq.ntyp1
3054      &  .or. itype(i-1).eq.ntyp1
3055      &  .or. itype(i+4).eq.ntyp1
3056      &  ) cycle
3057         dxi=dc(1,i)
3058         dyi=dc(2,i)
3059         dzi=dc(3,i)
3060         dx_normi=dc_norm(1,i)
3061         dy_normi=dc_norm(2,i)
3062         dz_normi=dc_norm(3,i)
3063         xmedi=c(1,i)+0.5d0*dxi
3064         ymedi=c(2,i)+0.5d0*dyi
3065         zmedi=c(3,i)+0.5d0*dzi
3066           xmedi=mod(xmedi,boxxsize)
3067           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3068           ymedi=mod(ymedi,boxysize)
3069           if (ymedi.lt.0) ymedi=ymedi+boxysize
3070           zmedi=mod(zmedi,boxzsize)
3071           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3072         num_conti=0
3073         call eelecij(i,i+2,ees,evdw1,eel_loc)
3074         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3075         num_cont_hb(i)=num_conti
3076       enddo
3077       do i=iturn4_start,iturn4_end
3078         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3079      &    .or. itype(i+3).eq.ntyp1
3080      &    .or. itype(i+4).eq.ntyp1
3081      &    .or. itype(i+5).eq.ntyp1
3082      &    .or. itype(i).eq.ntyp1
3083      &    .or. itype(i-1).eq.ntyp1
3084      &                             ) cycle
3085         dxi=dc(1,i)
3086         dyi=dc(2,i)
3087         dzi=dc(3,i)
3088         dx_normi=dc_norm(1,i)
3089         dy_normi=dc_norm(2,i)
3090         dz_normi=dc_norm(3,i)
3091         xmedi=c(1,i)+0.5d0*dxi
3092         ymedi=c(2,i)+0.5d0*dyi
3093         zmedi=c(3,i)+0.5d0*dzi
3094 C Return atom into box, boxxsize is size of box in x dimension
3095 c  194   continue
3096 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3097 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3098 C Condition for being inside the proper box
3099 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3100 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3101 c        go to 194
3102 c        endif
3103 c  195   continue
3104 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3105 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3106 C Condition for being inside the proper box
3107 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3108 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3109 c        go to 195
3110 c        endif
3111 c  196   continue
3112 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3113 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3114 C Condition for being inside the proper box
3115 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3116 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3117 c        go to 196
3118 c        endif
3119           xmedi=mod(xmedi,boxxsize)
3120           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3121           ymedi=mod(ymedi,boxysize)
3122           if (ymedi.lt.0) ymedi=ymedi+boxysize
3123           zmedi=mod(zmedi,boxzsize)
3124           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3125
3126         num_conti=num_cont_hb(i)
3127 c        write(iout,*) "JESTEM W PETLI"
3128         call eelecij(i,i+3,ees,evdw1,eel_loc)
3129         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3130      &   call eturn4(i,eello_turn4)
3131         num_cont_hb(i)=num_conti
3132       enddo   ! i
3133 C Loop over all neighbouring boxes
3134 C      do xshift=-1,1
3135 C      do yshift=-1,1
3136 C      do zshift=-1,1
3137 c
3138 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3139 c
3140       do i=iatel_s,iatel_e
3141         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3142      &  .or. itype(i+2).eq.ntyp1
3143      &  .or. itype(i-1).eq.ntyp1
3144      &                ) cycle
3145         dxi=dc(1,i)
3146         dyi=dc(2,i)
3147         dzi=dc(3,i)
3148         dx_normi=dc_norm(1,i)
3149         dy_normi=dc_norm(2,i)
3150         dz_normi=dc_norm(3,i)
3151         xmedi=c(1,i)+0.5d0*dxi
3152         ymedi=c(2,i)+0.5d0*dyi
3153         zmedi=c(3,i)+0.5d0*dzi
3154           xmedi=mod(xmedi,boxxsize)
3155           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3156           ymedi=mod(ymedi,boxysize)
3157           if (ymedi.lt.0) ymedi=ymedi+boxysize
3158           zmedi=mod(zmedi,boxzsize)
3159           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3160 C          xmedi=xmedi+xshift*boxxsize
3161 C          ymedi=ymedi+yshift*boxysize
3162 C          zmedi=zmedi+zshift*boxzsize
3163
3164 C Return tom into box, boxxsize is size of box in x dimension
3165 c  164   continue
3166 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3167 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3168 C Condition for being inside the proper box
3169 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3170 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3171 c        go to 164
3172 c        endif
3173 c  165   continue
3174 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3175 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3176 C Condition for being inside the proper box
3177 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3178 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3179 c        go to 165
3180 c        endif
3181 c  166   continue
3182 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3183 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3184 cC Condition for being inside the proper box
3185 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3186 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3187 c        go to 166
3188 c        endif
3189
3190 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3191         num_conti=num_cont_hb(i)
3192         do j=ielstart(i),ielend(i)
3193 c          write (iout,*) i,j,itype(i),itype(j)
3194           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3195      & .or.itype(j+2).eq.ntyp1
3196      & .or.itype(j-1).eq.ntyp1
3197      &) cycle
3198           call eelecij(i,j,ees,evdw1,eel_loc)
3199         enddo ! j
3200         num_cont_hb(i)=num_conti
3201       enddo   ! i
3202 C     enddo   ! zshift
3203 C      enddo   ! yshift
3204 C      enddo   ! xshift
3205
3206 c      write (iout,*) "Number of loop steps in EELEC:",ind
3207 cd      do i=1,nres
3208 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3209 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3210 cd      enddo
3211 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3212 ccc      eel_loc=eel_loc+eello_turn3
3213 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3214       return
3215       end
3216 C-------------------------------------------------------------------------------
3217       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3218       implicit real*8 (a-h,o-z)
3219       include 'DIMENSIONS'
3220 #ifdef MPI
3221       include "mpif.h"
3222 #endif
3223       include 'COMMON.CONTROL'
3224       include 'COMMON.IOUNITS'
3225       include 'COMMON.GEO'
3226       include 'COMMON.VAR'
3227       include 'COMMON.LOCAL'
3228       include 'COMMON.CHAIN'
3229       include 'COMMON.DERIV'
3230       include 'COMMON.INTERACT'
3231       include 'COMMON.CONTACTS'
3232       include 'COMMON.TORSION'
3233       include 'COMMON.VECTORS'
3234       include 'COMMON.FFIELD'
3235       include 'COMMON.TIME1'
3236       include 'COMMON.SPLITELE'
3237       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3238      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3239       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3240      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3241      &    gmuij2(4),gmuji2(4)
3242       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3243      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3244      &    num_conti,j1,j2
3245 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3246 #ifdef MOMENT
3247       double precision scal_el /1.0d0/
3248 #else
3249       double precision scal_el /0.5d0/
3250 #endif
3251 C 12/13/98
3252 C 13-go grudnia roku pamietnego...
3253       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3254      &                   0.0d0,1.0d0,0.0d0,
3255      &                   0.0d0,0.0d0,1.0d0/
3256 c          time00=MPI_Wtime()
3257 cd      write (iout,*) "eelecij",i,j
3258 c          ind=ind+1
3259           iteli=itel(i)
3260           itelj=itel(j)
3261           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3262           aaa=app(iteli,itelj)
3263           bbb=bpp(iteli,itelj)
3264           ael6i=ael6(iteli,itelj)
3265           ael3i=ael3(iteli,itelj)
3266           dxj=dc(1,j)
3267           dyj=dc(2,j)
3268           dzj=dc(3,j)
3269           dx_normj=dc_norm(1,j)
3270           dy_normj=dc_norm(2,j)
3271           dz_normj=dc_norm(3,j)
3272 C          xj=c(1,j)+0.5D0*dxj-xmedi
3273 C          yj=c(2,j)+0.5D0*dyj-ymedi
3274 C          zj=c(3,j)+0.5D0*dzj-zmedi
3275           xj=c(1,j)+0.5D0*dxj
3276           yj=c(2,j)+0.5D0*dyj
3277           zj=c(3,j)+0.5D0*dzj
3278           xj=mod(xj,boxxsize)
3279           if (xj.lt.0) xj=xj+boxxsize
3280           yj=mod(yj,boxysize)
3281           if (yj.lt.0) yj=yj+boxysize
3282           zj=mod(zj,boxzsize)
3283           if (zj.lt.0) zj=zj+boxzsize
3284           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3285       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3286       xj_safe=xj
3287       yj_safe=yj
3288       zj_safe=zj
3289       isubchap=0
3290       do xshift=-1,1
3291       do yshift=-1,1
3292       do zshift=-1,1
3293           xj=xj_safe+xshift*boxxsize
3294           yj=yj_safe+yshift*boxysize
3295           zj=zj_safe+zshift*boxzsize
3296           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3297           if(dist_temp.lt.dist_init) then
3298             dist_init=dist_temp
3299             xj_temp=xj
3300             yj_temp=yj
3301             zj_temp=zj
3302             isubchap=1
3303           endif
3304        enddo
3305        enddo
3306        enddo
3307        if (isubchap.eq.1) then
3308           xj=xj_temp-xmedi
3309           yj=yj_temp-ymedi
3310           zj=zj_temp-zmedi
3311        else
3312           xj=xj_safe-xmedi
3313           yj=yj_safe-ymedi
3314           zj=zj_safe-zmedi
3315        endif
3316 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3317 c  174   continue
3318 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3319 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3320 C Condition for being inside the proper box
3321 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3322 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3323 c        go to 174
3324 c        endif
3325 c  175   continue
3326 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3327 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3328 C Condition for being inside the proper box
3329 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3330 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3331 c        go to 175
3332 c        endif
3333 c  176   continue
3334 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3335 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3336 C Condition for being inside the proper box
3337 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3338 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3339 c        go to 176
3340 c        endif
3341 C        endif !endPBC condintion
3342 C        xj=xj-xmedi
3343 C        yj=yj-ymedi
3344 C        zj=zj-zmedi
3345           rij=xj*xj+yj*yj+zj*zj
3346
3347             sss=sscale(sqrt(rij))
3348             sssgrad=sscagrad(sqrt(rij))
3349 c            if (sss.gt.0.0d0) then
3350           rrmij=1.0D0/rij
3351           rij=dsqrt(rij)
3352           rmij=1.0D0/rij
3353           r3ij=rrmij*rmij
3354           r6ij=r3ij*r3ij
3355           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3356           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3357           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3358           fac=cosa-3.0D0*cosb*cosg
3359           ev1=aaa*r6ij*r6ij
3360 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3361           if (j.eq.i+2) ev1=scal_el*ev1
3362           ev2=bbb*r6ij
3363           fac3=ael6i*r6ij
3364           fac4=ael3i*r3ij
3365           evdwij=(ev1+ev2)
3366           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3367           el2=fac4*fac
3368 C MARYSIA
3369           eesij=(el1+el2)
3370 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3371           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3372           ees=ees+eesij
3373           evdw1=evdw1+evdwij*sss
3374 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3375 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3376 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3377 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3378
3379           if (energy_dec) then
3380               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3381      &'evdw1',i,j,evdwij
3382      &,iteli,itelj,aaa,evdw1
3383               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3384           endif
3385
3386 C
3387 C Calculate contributions to the Cartesian gradient.
3388 C
3389 #ifdef SPLITELE
3390           facvdw=-6*rrmij*(ev1+evdwij)*sss
3391           facel=-3*rrmij*(el1+eesij)
3392           fac1=fac
3393           erij(1)=xj*rmij
3394           erij(2)=yj*rmij
3395           erij(3)=zj*rmij
3396 *
3397 * Radial derivatives. First process both termini of the fragment (i,j)
3398 *
3399           ggg(1)=facel*xj
3400           ggg(2)=facel*yj
3401           ggg(3)=facel*zj
3402 c          do k=1,3
3403 c            ghalf=0.5D0*ggg(k)
3404 c            gelc(k,i)=gelc(k,i)+ghalf
3405 c            gelc(k,j)=gelc(k,j)+ghalf
3406 c          enddo
3407 c 9/28/08 AL Gradient compotents will be summed only at the end
3408           do k=1,3
3409             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3410             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3411           enddo
3412 *
3413 * Loop over residues i+1 thru j-1.
3414 *
3415 cgrad          do k=i+1,j-1
3416 cgrad            do l=1,3
3417 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3418 cgrad            enddo
3419 cgrad          enddo
3420           if (sss.gt.0.0) then
3421           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3422           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3423           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3424           else
3425           ggg(1)=0.0
3426           ggg(2)=0.0
3427           ggg(3)=0.0
3428           endif
3429 c          do k=1,3
3430 c            ghalf=0.5D0*ggg(k)
3431 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3432 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3433 c          enddo
3434 c 9/28/08 AL Gradient compotents will be summed only at the end
3435           do k=1,3
3436             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3437             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3438           enddo
3439 *
3440 * Loop over residues i+1 thru j-1.
3441 *
3442 cgrad          do k=i+1,j-1
3443 cgrad            do l=1,3
3444 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3445 cgrad            enddo
3446 cgrad          enddo
3447 #else
3448 C MARYSIA
3449           facvdw=(ev1+evdwij)*sss
3450           facel=(el1+eesij)
3451           fac1=fac
3452           fac=-3*rrmij*(facvdw+facvdw+facel)
3453           erij(1)=xj*rmij
3454           erij(2)=yj*rmij
3455           erij(3)=zj*rmij
3456 *
3457 * Radial derivatives. First process both termini of the fragment (i,j)
3458 *
3459           ggg(1)=fac*xj
3460           ggg(2)=fac*yj
3461           ggg(3)=fac*zj
3462 c          do k=1,3
3463 c            ghalf=0.5D0*ggg(k)
3464 c            gelc(k,i)=gelc(k,i)+ghalf
3465 c            gelc(k,j)=gelc(k,j)+ghalf
3466 c          enddo
3467 c 9/28/08 AL Gradient compotents will be summed only at the end
3468           do k=1,3
3469             gelc_long(k,j)=gelc(k,j)+ggg(k)
3470             gelc_long(k,i)=gelc(k,i)-ggg(k)
3471           enddo
3472 *
3473 * Loop over residues i+1 thru j-1.
3474 *
3475 cgrad          do k=i+1,j-1
3476 cgrad            do l=1,3
3477 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3478 cgrad            enddo
3479 cgrad          enddo
3480 c 9/28/08 AL Gradient compotents will be summed only at the end
3481           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3482           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3483           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3484           do k=1,3
3485             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3486             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3487           enddo
3488 #endif
3489 *
3490 * Angular part
3491 *
3492           ecosa=2.0D0*fac3*fac1+fac4
3493           fac4=-3.0D0*fac4
3494           fac3=-6.0D0*fac3
3495           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3496           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3497           do k=1,3
3498             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3499             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3500           enddo
3501 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3502 cd   &          (dcosg(k),k=1,3)
3503           do k=1,3
3504             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3505           enddo
3506 c          do k=1,3
3507 c            ghalf=0.5D0*ggg(k)
3508 c            gelc(k,i)=gelc(k,i)+ghalf
3509 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3510 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3511 c            gelc(k,j)=gelc(k,j)+ghalf
3512 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3513 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3514 c          enddo
3515 cgrad          do k=i+1,j-1
3516 cgrad            do l=1,3
3517 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3518 cgrad            enddo
3519 cgrad          enddo
3520           do k=1,3
3521             gelc(k,i)=gelc(k,i)
3522      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3523      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3524             gelc(k,j)=gelc(k,j)
3525      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3526      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3527             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3528             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3529           enddo
3530 C MARYSIA
3531 c          endif !sscale
3532           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3533      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3534      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3535 C
3536 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3537 C   energy of a peptide unit is assumed in the form of a second-order
3538 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3539 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3540 C   are computed for EVERY pair of non-contiguous peptide groups.
3541 C
3542
3543           if (j.lt.nres-1) then
3544             j1=j+1
3545             j2=j-1
3546           else
3547             j1=j-1
3548             j2=j-2
3549           endif
3550           kkk=0
3551           lll=0
3552           do k=1,2
3553             do l=1,2
3554               kkk=kkk+1
3555               muij(kkk)=mu(k,i)*mu(l,j)
3556 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3557 #ifdef NEWCORR
3558              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3559 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3560              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3561              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3562 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3563              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3564 #endif
3565             enddo
3566           enddo
3567 cd         write (iout,*) 'EELEC: i',i,' j',j
3568 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3569 cd          write(iout,*) 'muij',muij
3570           ury=scalar(uy(1,i),erij)
3571           urz=scalar(uz(1,i),erij)
3572           vry=scalar(uy(1,j),erij)
3573           vrz=scalar(uz(1,j),erij)
3574           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3575           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3576           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3577           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3578           fac=dsqrt(-ael6i)*r3ij
3579           a22=a22*fac
3580           a23=a23*fac
3581           a32=a32*fac
3582           a33=a33*fac
3583 cd          write (iout,'(4i5,4f10.5)')
3584 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3585 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3586 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3587 cd     &      uy(:,j),uz(:,j)
3588 cd          write (iout,'(4f10.5)')
3589 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3590 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3591 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3592 cd           write (iout,'(9f10.5/)')
3593 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3594 C Derivatives of the elements of A in virtual-bond vectors
3595           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3596           do k=1,3
3597             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3598             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3599             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3600             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3601             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3602             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3603             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3604             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3605             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3606             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3607             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3608             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3609           enddo
3610 C Compute radial contributions to the gradient
3611           facr=-3.0d0*rrmij
3612           a22der=a22*facr
3613           a23der=a23*facr
3614           a32der=a32*facr
3615           a33der=a33*facr
3616           agg(1,1)=a22der*xj
3617           agg(2,1)=a22der*yj
3618           agg(3,1)=a22der*zj
3619           agg(1,2)=a23der*xj
3620           agg(2,2)=a23der*yj
3621           agg(3,2)=a23der*zj
3622           agg(1,3)=a32der*xj
3623           agg(2,3)=a32der*yj
3624           agg(3,3)=a32der*zj
3625           agg(1,4)=a33der*xj
3626           agg(2,4)=a33der*yj
3627           agg(3,4)=a33der*zj
3628 C Add the contributions coming from er
3629           fac3=-3.0d0*fac
3630           do k=1,3
3631             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3632             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3633             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3634             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3635           enddo
3636           do k=1,3
3637 C Derivatives in DC(i)
3638 cgrad            ghalf1=0.5d0*agg(k,1)
3639 cgrad            ghalf2=0.5d0*agg(k,2)
3640 cgrad            ghalf3=0.5d0*agg(k,3)
3641 cgrad            ghalf4=0.5d0*agg(k,4)
3642             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3643      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3644             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3645      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3646             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3647      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3648             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3649      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3650 C Derivatives in DC(i+1)
3651             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3652      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3653             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3654      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3655             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3656      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3657             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3658      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3659 C Derivatives in DC(j)
3660             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3661      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3662             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3663      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3664             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3665      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3666             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3667      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3668 C Derivatives in DC(j+1) or DC(nres-1)
3669             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3670      &      -3.0d0*vryg(k,3)*ury)
3671             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3672      &      -3.0d0*vrzg(k,3)*ury)
3673             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3674      &      -3.0d0*vryg(k,3)*urz)
3675             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3676      &      -3.0d0*vrzg(k,3)*urz)
3677 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3678 cgrad              do l=1,4
3679 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3680 cgrad              enddo
3681 cgrad            endif
3682           enddo
3683           acipa(1,1)=a22
3684           acipa(1,2)=a23
3685           acipa(2,1)=a32
3686           acipa(2,2)=a33
3687           a22=-a22
3688           a23=-a23
3689           do l=1,2
3690             do k=1,3
3691               agg(k,l)=-agg(k,l)
3692               aggi(k,l)=-aggi(k,l)
3693               aggi1(k,l)=-aggi1(k,l)
3694               aggj(k,l)=-aggj(k,l)
3695               aggj1(k,l)=-aggj1(k,l)
3696             enddo
3697           enddo
3698           if (j.lt.nres-1) then
3699             a22=-a22
3700             a32=-a32
3701             do l=1,3,2
3702               do k=1,3
3703                 agg(k,l)=-agg(k,l)
3704                 aggi(k,l)=-aggi(k,l)
3705                 aggi1(k,l)=-aggi1(k,l)
3706                 aggj(k,l)=-aggj(k,l)
3707                 aggj1(k,l)=-aggj1(k,l)
3708               enddo
3709             enddo
3710           else
3711             a22=-a22
3712             a23=-a23
3713             a32=-a32
3714             a33=-a33
3715             do l=1,4
3716               do k=1,3
3717                 agg(k,l)=-agg(k,l)
3718                 aggi(k,l)=-aggi(k,l)
3719                 aggi1(k,l)=-aggi1(k,l)
3720                 aggj(k,l)=-aggj(k,l)
3721                 aggj1(k,l)=-aggj1(k,l)
3722               enddo
3723             enddo
3724           endif
3725           ENDIF ! WCORR
3726           IF (wel_loc.gt.0.0d0) THEN
3727 C Contribution to the local-electrostatic energy coming from the i-j pair
3728           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3729      &     +a33*muij(4)
3730 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3731 c     &                     ' eel_loc_ij',eel_loc_ij
3732 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3733 C Calculate patrial derivative for theta angle
3734 #ifdef NEWCORR
3735          geel_loc_ij=a22*gmuij1(1)
3736      &     +a23*gmuij1(2)
3737      &     +a32*gmuij1(3)
3738      &     +a33*gmuij1(4)
3739 c         write(iout,*) "derivative over thatai"
3740 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3741 c     &   a33*gmuij1(4)
3742          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3743      &      geel_loc_ij*wel_loc
3744 c         write(iout,*) "derivative over thatai-1"
3745 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3746 c     &   a33*gmuij2(4)
3747          geel_loc_ij=
3748      &     a22*gmuij2(1)
3749      &     +a23*gmuij2(2)
3750      &     +a32*gmuij2(3)
3751      &     +a33*gmuij2(4)
3752          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3753      &      geel_loc_ij*wel_loc
3754 c  Derivative over j residue
3755          geel_loc_ji=a22*gmuji1(1)
3756      &     +a23*gmuji1(2)
3757      &     +a32*gmuji1(3)
3758      &     +a33*gmuji1(4)
3759 c         write(iout,*) "derivative over thataj"
3760 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3761 c     &   a33*gmuji1(4)
3762
3763         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3764      &      geel_loc_ji*wel_loc
3765          geel_loc_ji=
3766      &     +a22*gmuji2(1)
3767      &     +a23*gmuji2(2)
3768      &     +a32*gmuji2(3)
3769      &     +a33*gmuji2(4)
3770 c         write(iout,*) "derivative over thataj-1"
3771 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3772 c     &   a33*gmuji2(4)
3773          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3774      &      geel_loc_ji*wel_loc
3775 #endif
3776 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3777
3778           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3779      &            'eelloc',i,j,eel_loc_ij
3780 c           if (eel_loc_ij.ne.0)
3781 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3782 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3783
3784           eel_loc=eel_loc+eel_loc_ij
3785 C Partial derivatives in virtual-bond dihedral angles gamma
3786           if (i.gt.1)
3787      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3788      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3789      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3790           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3791      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3792      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3793 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3794           do l=1,3
3795             ggg(l)=agg(l,1)*muij(1)+
3796      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3797             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3798             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3799 cgrad            ghalf=0.5d0*ggg(l)
3800 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3801 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3802           enddo
3803 cgrad          do k=i+1,j2
3804 cgrad            do l=1,3
3805 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3806 cgrad            enddo
3807 cgrad          enddo
3808 C Remaining derivatives of eello
3809           do l=1,3
3810             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3811      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3812             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3813      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3814             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3815      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3816             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3817      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3818           enddo
3819           ENDIF
3820 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3821 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3822           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3823      &       .and. num_conti.le.maxconts) then
3824 c            write (iout,*) i,j," entered corr"
3825 C
3826 C Calculate the contact function. The ith column of the array JCONT will
3827 C contain the numbers of atoms that make contacts with the atom I (of numbers
3828 C greater than I). The arrays FACONT and GACONT will contain the values of
3829 C the contact function and its derivative.
3830 c           r0ij=1.02D0*rpp(iteli,itelj)
3831 c           r0ij=1.11D0*rpp(iteli,itelj)
3832             r0ij=2.20D0*rpp(iteli,itelj)
3833 c           r0ij=1.55D0*rpp(iteli,itelj)
3834             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3835             if (fcont.gt.0.0D0) then
3836               num_conti=num_conti+1
3837               if (num_conti.gt.maxconts) then
3838                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3839      &                         ' will skip next contacts for this conf.'
3840               else
3841                 jcont_hb(num_conti,i)=j
3842 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3843 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3844                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3845      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3846 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3847 C  terms.
3848                 d_cont(num_conti,i)=rij
3849 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3850 C     --- Electrostatic-interaction matrix ---
3851                 a_chuj(1,1,num_conti,i)=a22
3852                 a_chuj(1,2,num_conti,i)=a23
3853                 a_chuj(2,1,num_conti,i)=a32
3854                 a_chuj(2,2,num_conti,i)=a33
3855 C     --- Gradient of rij
3856                 do kkk=1,3
3857                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3858                 enddo
3859                 kkll=0
3860                 do k=1,2
3861                   do l=1,2
3862                     kkll=kkll+1
3863                     do m=1,3
3864                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3865                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3866                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3867                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3868                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3869                     enddo
3870                   enddo
3871                 enddo
3872                 ENDIF
3873                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3874 C Calculate contact energies
3875                 cosa4=4.0D0*cosa
3876                 wij=cosa-3.0D0*cosb*cosg
3877                 cosbg1=cosb+cosg
3878                 cosbg2=cosb-cosg
3879 c               fac3=dsqrt(-ael6i)/r0ij**3
3880                 fac3=dsqrt(-ael6i)*r3ij
3881 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3882                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3883                 if (ees0tmp.gt.0) then
3884                   ees0pij=dsqrt(ees0tmp)
3885                 else
3886                   ees0pij=0
3887                 endif
3888 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3889                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3890                 if (ees0tmp.gt.0) then
3891                   ees0mij=dsqrt(ees0tmp)
3892                 else
3893                   ees0mij=0
3894                 endif
3895 c               ees0mij=0.0D0
3896                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3897                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3898 C Diagnostics. Comment out or remove after debugging!
3899 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3900 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3901 c               ees0m(num_conti,i)=0.0D0
3902 C End diagnostics.
3903 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3904 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3905 C Angular derivatives of the contact function
3906                 ees0pij1=fac3/ees0pij
3907                 ees0mij1=fac3/ees0mij
3908                 fac3p=-3.0D0*fac3*rrmij
3909                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3910                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3911 c               ees0mij1=0.0D0
3912                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3913                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3914                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3915                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3916                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3917                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3918                 ecosap=ecosa1+ecosa2
3919                 ecosbp=ecosb1+ecosb2
3920                 ecosgp=ecosg1+ecosg2
3921                 ecosam=ecosa1-ecosa2
3922                 ecosbm=ecosb1-ecosb2
3923                 ecosgm=ecosg1-ecosg2
3924 C Diagnostics
3925 c               ecosap=ecosa1
3926 c               ecosbp=ecosb1
3927 c               ecosgp=ecosg1
3928 c               ecosam=0.0D0
3929 c               ecosbm=0.0D0
3930 c               ecosgm=0.0D0
3931 C End diagnostics
3932                 facont_hb(num_conti,i)=fcont
3933                 fprimcont=fprimcont/rij
3934 cd              facont_hb(num_conti,i)=1.0D0
3935 C Following line is for diagnostics.
3936 cd              fprimcont=0.0D0
3937                 do k=1,3
3938                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3939                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3940                 enddo
3941                 do k=1,3
3942                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3943                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3944                 enddo
3945                 gggp(1)=gggp(1)+ees0pijp*xj
3946                 gggp(2)=gggp(2)+ees0pijp*yj
3947                 gggp(3)=gggp(3)+ees0pijp*zj
3948                 gggm(1)=gggm(1)+ees0mijp*xj
3949                 gggm(2)=gggm(2)+ees0mijp*yj
3950                 gggm(3)=gggm(3)+ees0mijp*zj
3951 C Derivatives due to the contact function
3952                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3953                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3954                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3955                 do k=1,3
3956 c
3957 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3958 c          following the change of gradient-summation algorithm.
3959 c
3960 cgrad                  ghalfp=0.5D0*gggp(k)
3961 cgrad                  ghalfm=0.5D0*gggm(k)
3962                   gacontp_hb1(k,num_conti,i)=!ghalfp
3963      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3964      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3965                   gacontp_hb2(k,num_conti,i)=!ghalfp
3966      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3967      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3968                   gacontp_hb3(k,num_conti,i)=gggp(k)
3969                   gacontm_hb1(k,num_conti,i)=!ghalfm
3970      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3971      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3972                   gacontm_hb2(k,num_conti,i)=!ghalfm
3973      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3974      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3975                   gacontm_hb3(k,num_conti,i)=gggm(k)
3976                 enddo
3977 C Diagnostics. Comment out or remove after debugging!
3978 cdiag           do k=1,3
3979 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3980 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3981 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3982 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3983 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3984 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3985 cdiag           enddo
3986               ENDIF ! wcorr
3987               endif  ! num_conti.le.maxconts
3988             endif  ! fcont.gt.0
3989           endif    ! j.gt.i+1
3990           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3991             do k=1,4
3992               do l=1,3
3993                 ghalf=0.5d0*agg(l,k)
3994                 aggi(l,k)=aggi(l,k)+ghalf
3995                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3996                 aggj(l,k)=aggj(l,k)+ghalf
3997               enddo
3998             enddo
3999             if (j.eq.nres-1 .and. i.lt.j-2) then
4000               do k=1,4
4001                 do l=1,3
4002                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4003                 enddo
4004               enddo
4005             endif
4006           endif
4007 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4008       return
4009       end
4010 C-----------------------------------------------------------------------------
4011       subroutine eturn3(i,eello_turn3)
4012 C Third- and fourth-order contributions from turns
4013       implicit real*8 (a-h,o-z)
4014       include 'DIMENSIONS'
4015       include 'COMMON.IOUNITS'
4016       include 'COMMON.GEO'
4017       include 'COMMON.VAR'
4018       include 'COMMON.LOCAL'
4019       include 'COMMON.CHAIN'
4020       include 'COMMON.DERIV'
4021       include 'COMMON.INTERACT'
4022       include 'COMMON.CONTACTS'
4023       include 'COMMON.TORSION'
4024       include 'COMMON.VECTORS'
4025       include 'COMMON.FFIELD'
4026       include 'COMMON.CONTROL'
4027       dimension ggg(3)
4028       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4029      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4030      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4031      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4032      &  auxgmat2(2,2),auxgmatt2(2,2)
4033       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4034      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4035       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4036      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4037      &    num_conti,j1,j2
4038       j=i+2
4039 c      write (iout,*) "eturn3",i,j,j1,j2
4040       a_temp(1,1)=a22
4041       a_temp(1,2)=a23
4042       a_temp(2,1)=a32
4043       a_temp(2,2)=a33
4044 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4045 C
4046 C               Third-order contributions
4047 C
4048 C                 (i+2)o----(i+3)
4049 C                      | |
4050 C                      | |
4051 C                 (i+1)o----i
4052 C
4053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4054 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4055         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4056 c auxalary matices for theta gradient
4057 c auxalary matrix for i+1 and constant i+2
4058         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4059 c auxalary matrix for i+2 and constant i+1
4060         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4061         call transpose2(auxmat(1,1),auxmat1(1,1))
4062         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4063         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4064         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4065         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4066         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4067         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4068 C Derivatives in theta
4069         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4070      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4071         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4072      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4073
4074         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4075      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4076 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4077 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4078 cd     &    ' eello_turn3_num',4*eello_turn3_num
4079 C Derivatives in gamma(i)
4080         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4081         call transpose2(auxmat2(1,1),auxmat3(1,1))
4082         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4083         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4084 C Derivatives in gamma(i+1)
4085         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4086         call transpose2(auxmat2(1,1),auxmat3(1,1))
4087         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4088         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4089      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4090 C Cartesian derivatives
4091         do l=1,3
4092 c            ghalf1=0.5d0*agg(l,1)
4093 c            ghalf2=0.5d0*agg(l,2)
4094 c            ghalf3=0.5d0*agg(l,3)
4095 c            ghalf4=0.5d0*agg(l,4)
4096           a_temp(1,1)=aggi(l,1)!+ghalf1
4097           a_temp(1,2)=aggi(l,2)!+ghalf2
4098           a_temp(2,1)=aggi(l,3)!+ghalf3
4099           a_temp(2,2)=aggi(l,4)!+ghalf4
4100           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4101           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4102      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4103           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4104           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4105           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4106           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4107           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4108           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4109      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4110           a_temp(1,1)=aggj(l,1)!+ghalf1
4111           a_temp(1,2)=aggj(l,2)!+ghalf2
4112           a_temp(2,1)=aggj(l,3)!+ghalf3
4113           a_temp(2,2)=aggj(l,4)!+ghalf4
4114           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4115           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4116      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4117           a_temp(1,1)=aggj1(l,1)
4118           a_temp(1,2)=aggj1(l,2)
4119           a_temp(2,1)=aggj1(l,3)
4120           a_temp(2,2)=aggj1(l,4)
4121           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4122           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4123      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4124         enddo
4125       return
4126       end
4127 C-------------------------------------------------------------------------------
4128       subroutine eturn4(i,eello_turn4)
4129 C Third- and fourth-order contributions from turns
4130       implicit real*8 (a-h,o-z)
4131       include 'DIMENSIONS'
4132       include 'COMMON.IOUNITS'
4133       include 'COMMON.GEO'
4134       include 'COMMON.VAR'
4135       include 'COMMON.LOCAL'
4136       include 'COMMON.CHAIN'
4137       include 'COMMON.DERIV'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.CONTACTS'
4140       include 'COMMON.TORSION'
4141       include 'COMMON.VECTORS'
4142       include 'COMMON.FFIELD'
4143       include 'COMMON.CONTROL'
4144       dimension ggg(3)
4145       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4146      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4147      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4148      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4149      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4150      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4151      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4152       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4153      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4154       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4155      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4156      &    num_conti,j1,j2
4157       j=i+3
4158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4159 C
4160 C               Fourth-order contributions
4161 C
4162 C                 (i+3)o----(i+4)
4163 C                     /  |
4164 C               (i+2)o   |
4165 C                     \  |
4166 C                 (i+1)o----i
4167 C
4168 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4169 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4170 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4171 c        write(iout,*)"WCHODZE W PROGRAM"
4172         a_temp(1,1)=a22
4173         a_temp(1,2)=a23
4174         a_temp(2,1)=a32
4175         a_temp(2,2)=a33
4176         iti1=itortyp(itype(i+1))
4177         iti2=itortyp(itype(i+2))
4178         iti3=itortyp(itype(i+3))
4179 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4180         call transpose2(EUg(1,1,i+1),e1t(1,1))
4181         call transpose2(Eug(1,1,i+2),e2t(1,1))
4182         call transpose2(Eug(1,1,i+3),e3t(1,1))
4183 C Ematrix derivative in theta
4184         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4185         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4186         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4187         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4188 c       eta1 in derivative theta
4189         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4190         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4191 c       auxgvec is derivative of Ub2 so i+3 theta
4192         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4193 c       auxalary matrix of E i+1
4194         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4195 c        s1=0.0
4196 c        gs1=0.0
4197         s1=scalar2(b1(1,i+2),auxvec(1))
4198 c derivative of theta i+2 with constant i+3
4199         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4200 c derivative of theta i+2 with constant i+2
4201         gs32=scalar2(b1(1,i+2),auxgvec(1))
4202 c derivative of E matix in theta of i+1
4203         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4204
4205         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4206 c       ea31 in derivative theta
4207         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4208         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4209 c auxilary matrix auxgvec of Ub2 with constant E matirx
4210         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4211 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4212         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4213
4214 c        s2=0.0
4215 c        gs2=0.0
4216         s2=scalar2(b1(1,i+1),auxvec(1))
4217 c derivative of theta i+1 with constant i+3
4218         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4219 c derivative of theta i+2 with constant i+1
4220         gs21=scalar2(b1(1,i+1),auxgvec(1))
4221 c derivative of theta i+3 with constant i+1
4222         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4223 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4224 c     &  gtb1(1,i+1)
4225         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4226 c two derivatives over diffetent matrices
4227 c gtae3e2 is derivative over i+3
4228         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4229 c ae3gte2 is derivative over i+2
4230         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4231         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4232 c three possible derivative over theta E matices
4233 c i+1
4234         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4235 c i+2
4236         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4237 c i+3
4238         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4239         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4240
4241         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4242         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4243         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4244
4245         eello_turn4=eello_turn4-(s1+s2+s3)
4246 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4247         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4248      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4249 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4250 cd     &    ' eello_turn4_num',8*eello_turn4_num
4251 #ifdef NEWCORR
4252         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4253      &                  -(gs13+gsE13+gsEE1)*wturn4
4254         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4255      &                    -(gs23+gs21+gsEE2)*wturn4
4256         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4257      &                    -(gs32+gsE31+gsEE3)*wturn4
4258 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4259 c     &   gs2
4260 #endif
4261         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4262      &      'eturn4',i,j,-(s1+s2+s3)
4263 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4264 c     &    ' eello_turn4_num',8*eello_turn4_num
4265 C Derivatives in gamma(i)
4266         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4267         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4268         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4269         s1=scalar2(b1(1,i+2),auxvec(1))
4270         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4271         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4272         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4273 C Derivatives in gamma(i+1)
4274         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4275         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4276         s2=scalar2(b1(1,i+1),auxvec(1))
4277         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4278         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4279         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4280         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4281 C Derivatives in gamma(i+2)
4282         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4283         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4284         s1=scalar2(b1(1,i+2),auxvec(1))
4285         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4286         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4287         s2=scalar2(b1(1,i+1),auxvec(1))
4288         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4289         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4290         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4291         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4292 C Cartesian derivatives
4293 C Derivatives of this turn contributions in DC(i+2)
4294         if (j.lt.nres-1) then
4295           do l=1,3
4296             a_temp(1,1)=agg(l,1)
4297             a_temp(1,2)=agg(l,2)
4298             a_temp(2,1)=agg(l,3)
4299             a_temp(2,2)=agg(l,4)
4300             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4301             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4302             s1=scalar2(b1(1,i+2),auxvec(1))
4303             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4304             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4305             s2=scalar2(b1(1,i+1),auxvec(1))
4306             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4307             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4308             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4309             ggg(l)=-(s1+s2+s3)
4310             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4311           enddo
4312         endif
4313 C Remaining derivatives of this turn contribution
4314         do l=1,3
4315           a_temp(1,1)=aggi(l,1)
4316           a_temp(1,2)=aggi(l,2)
4317           a_temp(2,1)=aggi(l,3)
4318           a_temp(2,2)=aggi(l,4)
4319           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4320           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4321           s1=scalar2(b1(1,i+2),auxvec(1))
4322           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4323           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4324           s2=scalar2(b1(1,i+1),auxvec(1))
4325           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4326           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4327           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4328           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4329           a_temp(1,1)=aggi1(l,1)
4330           a_temp(1,2)=aggi1(l,2)
4331           a_temp(2,1)=aggi1(l,3)
4332           a_temp(2,2)=aggi1(l,4)
4333           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4334           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4335           s1=scalar2(b1(1,i+2),auxvec(1))
4336           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4337           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4338           s2=scalar2(b1(1,i+1),auxvec(1))
4339           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4340           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4341           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4342           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4343           a_temp(1,1)=aggj(l,1)
4344           a_temp(1,2)=aggj(l,2)
4345           a_temp(2,1)=aggj(l,3)
4346           a_temp(2,2)=aggj(l,4)
4347           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4348           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4349           s1=scalar2(b1(1,i+2),auxvec(1))
4350           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4351           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4352           s2=scalar2(b1(1,i+1),auxvec(1))
4353           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4354           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4355           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4356           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4357           a_temp(1,1)=aggj1(l,1)
4358           a_temp(1,2)=aggj1(l,2)
4359           a_temp(2,1)=aggj1(l,3)
4360           a_temp(2,2)=aggj1(l,4)
4361           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4362           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4363           s1=scalar2(b1(1,i+2),auxvec(1))
4364           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4365           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4366           s2=scalar2(b1(1,i+1),auxvec(1))
4367           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4368           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4369           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4370 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4371           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4372         enddo
4373       return
4374       end
4375 C-----------------------------------------------------------------------------
4376       subroutine vecpr(u,v,w)
4377       implicit real*8(a-h,o-z)
4378       dimension u(3),v(3),w(3)
4379       w(1)=u(2)*v(3)-u(3)*v(2)
4380       w(2)=-u(1)*v(3)+u(3)*v(1)
4381       w(3)=u(1)*v(2)-u(2)*v(1)
4382       return
4383       end
4384 C-----------------------------------------------------------------------------
4385       subroutine unormderiv(u,ugrad,unorm,ungrad)
4386 C This subroutine computes the derivatives of a normalized vector u, given
4387 C the derivatives computed without normalization conditions, ugrad. Returns
4388 C ungrad.
4389       implicit none
4390       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4391       double precision vec(3)
4392       double precision scalar
4393       integer i,j
4394 c      write (2,*) 'ugrad',ugrad
4395 c      write (2,*) 'u',u
4396       do i=1,3
4397         vec(i)=scalar(ugrad(1,i),u(1))
4398       enddo
4399 c      write (2,*) 'vec',vec
4400       do i=1,3
4401         do j=1,3
4402           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4403         enddo
4404       enddo
4405 c      write (2,*) 'ungrad',ungrad
4406       return
4407       end
4408 C-----------------------------------------------------------------------------
4409       subroutine escp_soft_sphere(evdw2,evdw2_14)
4410 C
4411 C This subroutine calculates the excluded-volume interaction energy between
4412 C peptide-group centers and side chains and its gradient in virtual-bond and
4413 C side-chain vectors.
4414 C
4415       implicit real*8 (a-h,o-z)
4416       include 'DIMENSIONS'
4417       include 'COMMON.GEO'
4418       include 'COMMON.VAR'
4419       include 'COMMON.LOCAL'
4420       include 'COMMON.CHAIN'
4421       include 'COMMON.DERIV'
4422       include 'COMMON.INTERACT'
4423       include 'COMMON.FFIELD'
4424       include 'COMMON.IOUNITS'
4425       include 'COMMON.CONTROL'
4426       dimension ggg(3)
4427       evdw2=0.0D0
4428       evdw2_14=0.0d0
4429       r0_scp=4.5d0
4430 cd    print '(a)','Enter ESCP'
4431 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4432 C      do xshift=-1,1
4433 C      do yshift=-1,1
4434 C      do zshift=-1,1
4435       do i=iatscp_s,iatscp_e
4436         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4437         iteli=itel(i)
4438         xi=0.5D0*(c(1,i)+c(1,i+1))
4439         yi=0.5D0*(c(2,i)+c(2,i+1))
4440         zi=0.5D0*(c(3,i)+c(3,i+1))
4441 C Return atom into box, boxxsize is size of box in x dimension
4442 c  134   continue
4443 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4444 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4445 C Condition for being inside the proper box
4446 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4447 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4448 c        go to 134
4449 c        endif
4450 c  135   continue
4451 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4452 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4453 C Condition for being inside the proper box
4454 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4455 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4456 c        go to 135
4457 c c       endif
4458 c  136   continue
4459 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4460 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4461 cC Condition for being inside the proper box
4462 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4463 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4464 c        go to 136
4465 c        endif
4466           xi=mod(xi,boxxsize)
4467           if (xi.lt.0) xi=xi+boxxsize
4468           yi=mod(yi,boxysize)
4469           if (yi.lt.0) yi=yi+boxysize
4470           zi=mod(zi,boxzsize)
4471           if (zi.lt.0) zi=zi+boxzsize
4472 C          xi=xi+xshift*boxxsize
4473 C          yi=yi+yshift*boxysize
4474 C          zi=zi+zshift*boxzsize
4475         do iint=1,nscp_gr(i)
4476
4477         do j=iscpstart(i,iint),iscpend(i,iint)
4478           if (itype(j).eq.ntyp1) cycle
4479           itypj=iabs(itype(j))
4480 C Uncomment following three lines for SC-p interactions
4481 c         xj=c(1,nres+j)-xi
4482 c         yj=c(2,nres+j)-yi
4483 c         zj=c(3,nres+j)-zi
4484 C Uncomment following three lines for Ca-p interactions
4485           xj=c(1,j)
4486           yj=c(2,j)
4487           zj=c(3,j)
4488 c  174   continue
4489 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4490 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4491 C Condition for being inside the proper box
4492 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4493 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4494 c        go to 174
4495 c        endif
4496 c  175   continue
4497 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4498 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4499 cC Condition for being inside the proper box
4500 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4501 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4502 c        go to 175
4503 c        endif
4504 c  176   continue
4505 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4506 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4507 C Condition for being inside the proper box
4508 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4509 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4510 c        go to 176
4511           xj=mod(xj,boxxsize)
4512           if (xj.lt.0) xj=xj+boxxsize
4513           yj=mod(yj,boxysize)
4514           if (yj.lt.0) yj=yj+boxysize
4515           zj=mod(zj,boxzsize)
4516           if (zj.lt.0) zj=zj+boxzsize
4517       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4518       xj_safe=xj
4519       yj_safe=yj
4520       zj_safe=zj
4521       subchap=0
4522       do xshift=-1,1
4523       do yshift=-1,1
4524       do zshift=-1,1
4525           xj=xj_safe+xshift*boxxsize
4526           yj=yj_safe+yshift*boxysize
4527           zj=zj_safe+zshift*boxzsize
4528           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4529           if(dist_temp.lt.dist_init) then
4530             dist_init=dist_temp
4531             xj_temp=xj
4532             yj_temp=yj
4533             zj_temp=zj
4534             subchap=1
4535           endif
4536        enddo
4537        enddo
4538        enddo
4539        if (subchap.eq.1) then
4540           xj=xj_temp-xi
4541           yj=yj_temp-yi
4542           zj=zj_temp-zi
4543        else
4544           xj=xj_safe-xi
4545           yj=yj_safe-yi
4546           zj=zj_safe-zi
4547        endif
4548 c c       endif
4549 C          xj=xj-xi
4550 C          yj=yj-yi
4551 C          zj=zj-zi
4552           rij=xj*xj+yj*yj+zj*zj
4553
4554           r0ij=r0_scp
4555           r0ijsq=r0ij*r0ij
4556           if (rij.lt.r0ijsq) then
4557             evdwij=0.25d0*(rij-r0ijsq)**2
4558             fac=rij-r0ijsq
4559           else
4560             evdwij=0.0d0
4561             fac=0.0d0
4562           endif
4563           evdw2=evdw2+evdwij
4564 C
4565 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4566 C
4567           ggg(1)=xj*fac
4568           ggg(2)=yj*fac
4569           ggg(3)=zj*fac
4570 cgrad          if (j.lt.i) then
4571 cd          write (iout,*) 'j<i'
4572 C Uncomment following three lines for SC-p interactions
4573 c           do k=1,3
4574 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4575 c           enddo
4576 cgrad          else
4577 cd          write (iout,*) 'j>i'
4578 cgrad            do k=1,3
4579 cgrad              ggg(k)=-ggg(k)
4580 C Uncomment following line for SC-p interactions
4581 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4582 cgrad            enddo
4583 cgrad          endif
4584 cgrad          do k=1,3
4585 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4586 cgrad          enddo
4587 cgrad          kstart=min0(i+1,j)
4588 cgrad          kend=max0(i-1,j-1)
4589 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4590 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4591 cgrad          do k=kstart,kend
4592 cgrad            do l=1,3
4593 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4594 cgrad            enddo
4595 cgrad          enddo
4596           do k=1,3
4597             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4598             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4599           enddo
4600         enddo
4601
4602         enddo ! iint
4603       enddo ! i
4604 C      enddo !zshift
4605 C      enddo !yshift
4606 C      enddo !xshift
4607       return
4608       end
4609 C-----------------------------------------------------------------------------
4610       subroutine escp(evdw2,evdw2_14)
4611 C
4612 C This subroutine calculates the excluded-volume interaction energy between
4613 C peptide-group centers and side chains and its gradient in virtual-bond and
4614 C side-chain vectors.
4615 C
4616       implicit real*8 (a-h,o-z)
4617       include 'DIMENSIONS'
4618       include 'COMMON.GEO'
4619       include 'COMMON.VAR'
4620       include 'COMMON.LOCAL'
4621       include 'COMMON.CHAIN'
4622       include 'COMMON.DERIV'
4623       include 'COMMON.INTERACT'
4624       include 'COMMON.FFIELD'
4625       include 'COMMON.IOUNITS'
4626       include 'COMMON.CONTROL'
4627       include 'COMMON.SPLITELE'
4628       dimension ggg(3)
4629       evdw2=0.0D0
4630       evdw2_14=0.0d0
4631 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4632 cd    print '(a)','Enter ESCP'
4633 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4634 C      do xshift=-1,1
4635 C      do yshift=-1,1
4636 C      do zshift=-1,1
4637       do i=iatscp_s,iatscp_e
4638         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4639         iteli=itel(i)
4640         xi=0.5D0*(c(1,i)+c(1,i+1))
4641         yi=0.5D0*(c(2,i)+c(2,i+1))
4642         zi=0.5D0*(c(3,i)+c(3,i+1))
4643           xi=mod(xi,boxxsize)
4644           if (xi.lt.0) xi=xi+boxxsize
4645           yi=mod(yi,boxysize)
4646           if (yi.lt.0) yi=yi+boxysize
4647           zi=mod(zi,boxzsize)
4648           if (zi.lt.0) zi=zi+boxzsize
4649 c          xi=xi+xshift*boxxsize
4650 c          yi=yi+yshift*boxysize
4651 c          zi=zi+zshift*boxzsize
4652 c        print *,xi,yi,zi,'polozenie i'
4653 C Return atom into box, boxxsize is size of box in x dimension
4654 c  134   continue
4655 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4656 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4657 C Condition for being inside the proper box
4658 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4659 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4660 c        go to 134
4661 c        endif
4662 c  135   continue
4663 c          print *,xi,boxxsize,"pierwszy"
4664
4665 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4666 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4667 C Condition for being inside the proper box
4668 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4669 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4670 c        go to 135
4671 c        endif
4672 c  136   continue
4673 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4674 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4675 C Condition for being inside the proper box
4676 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4677 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4678 c        go to 136
4679 c        endif
4680         do iint=1,nscp_gr(i)
4681
4682         do j=iscpstart(i,iint),iscpend(i,iint)
4683           itypj=iabs(itype(j))
4684           if (itypj.eq.ntyp1) cycle
4685 C Uncomment following three lines for SC-p interactions
4686 c         xj=c(1,nres+j)-xi
4687 c         yj=c(2,nres+j)-yi
4688 c         zj=c(3,nres+j)-zi
4689 C Uncomment following three lines for Ca-p interactions
4690           xj=c(1,j)
4691           yj=c(2,j)
4692           zj=c(3,j)
4693           xj=mod(xj,boxxsize)
4694           if (xj.lt.0) xj=xj+boxxsize
4695           yj=mod(yj,boxysize)
4696           if (yj.lt.0) yj=yj+boxysize
4697           zj=mod(zj,boxzsize)
4698           if (zj.lt.0) zj=zj+boxzsize
4699 c  174   continue
4700 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4701 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4702 C Condition for being inside the proper box
4703 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4704 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4705 c        go to 174
4706 c        endif
4707 c  175   continue
4708 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4709 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4710 cC Condition for being inside the proper box
4711 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4712 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4713 c        go to 175
4714 c        endif
4715 c  176   continue
4716 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4717 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4718 C Condition for being inside the proper box
4719 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4720 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4721 c        go to 176
4722 c        endif
4723 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4724       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4725       xj_safe=xj
4726       yj_safe=yj
4727       zj_safe=zj
4728       subchap=0
4729       do xshift=-1,1
4730       do yshift=-1,1
4731       do zshift=-1,1
4732           xj=xj_safe+xshift*boxxsize
4733           yj=yj_safe+yshift*boxysize
4734           zj=zj_safe+zshift*boxzsize
4735           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4736           if(dist_temp.lt.dist_init) then
4737             dist_init=dist_temp
4738             xj_temp=xj
4739             yj_temp=yj
4740             zj_temp=zj
4741             subchap=1
4742           endif
4743        enddo
4744        enddo
4745        enddo
4746        if (subchap.eq.1) then
4747           xj=xj_temp-xi
4748           yj=yj_temp-yi
4749           zj=zj_temp-zi
4750        else
4751           xj=xj_safe-xi
4752           yj=yj_safe-yi
4753           zj=zj_safe-zi
4754        endif
4755 c          print *,xj,yj,zj,'polozenie j'
4756           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4757 c          print *,rrij
4758           sss=sscale(1.0d0/(dsqrt(rrij)))
4759 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4760 c          if (sss.eq.0) print *,'czasem jest OK'
4761           if (sss.le.0.0d0) cycle
4762           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4763           fac=rrij**expon2
4764           e1=fac*fac*aad(itypj,iteli)
4765           e2=fac*bad(itypj,iteli)
4766           if (iabs(j-i) .le. 2) then
4767             e1=scal14*e1
4768             e2=scal14*e2
4769             evdw2_14=evdw2_14+(e1+e2)*sss
4770           endif
4771           evdwij=e1+e2
4772           evdw2=evdw2+evdwij*sss
4773           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4774      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4775      &       bad(itypj,iteli)
4776 C
4777 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4778 C
4779           fac=-(evdwij+e1)*rrij*sss
4780           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4781           ggg(1)=xj*fac
4782           ggg(2)=yj*fac
4783           ggg(3)=zj*fac
4784 cgrad          if (j.lt.i) then
4785 cd          write (iout,*) 'j<i'
4786 C Uncomment following three lines for SC-p interactions
4787 c           do k=1,3
4788 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4789 c           enddo
4790 cgrad          else
4791 cd          write (iout,*) 'j>i'
4792 cgrad            do k=1,3
4793 cgrad              ggg(k)=-ggg(k)
4794 C Uncomment following line for SC-p interactions
4795 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4796 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4797 cgrad            enddo
4798 cgrad          endif
4799 cgrad          do k=1,3
4800 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4801 cgrad          enddo
4802 cgrad          kstart=min0(i+1,j)
4803 cgrad          kend=max0(i-1,j-1)
4804 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4805 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4806 cgrad          do k=kstart,kend
4807 cgrad            do l=1,3
4808 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4809 cgrad            enddo
4810 cgrad          enddo
4811           do k=1,3
4812             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4813             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4814           enddo
4815 c        endif !endif for sscale cutoff
4816         enddo ! j
4817
4818         enddo ! iint
4819       enddo ! i
4820 c      enddo !zshift
4821 c      enddo !yshift
4822 c      enddo !xshift
4823       do i=1,nct
4824         do j=1,3
4825           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4826           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4827           gradx_scp(j,i)=expon*gradx_scp(j,i)
4828         enddo
4829       enddo
4830 C******************************************************************************
4831 C
4832 C                              N O T E !!!
4833 C
4834 C To save time the factor EXPON has been extracted from ALL components
4835 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4836 C use!
4837 C
4838 C******************************************************************************
4839       return
4840       end
4841 C--------------------------------------------------------------------------
4842       subroutine edis(ehpb)
4843 C
4844 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4845 C
4846       implicit real*8 (a-h,o-z)
4847       include 'DIMENSIONS'
4848       include 'COMMON.SBRIDGE'
4849       include 'COMMON.CHAIN'
4850       include 'COMMON.DERIV'
4851       include 'COMMON.VAR'
4852       include 'COMMON.INTERACT'
4853       include 'COMMON.IOUNITS'
4854       dimension ggg(3)
4855       ehpb=0.0D0
4856 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4857 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4858       if (link_end.eq.0) return
4859       do i=link_start,link_end
4860 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4861 C CA-CA distance used in regularization of structure.
4862         ii=ihpb(i)
4863         jj=jhpb(i)
4864 C iii and jjj point to the residues for which the distance is assigned.
4865         if (ii.gt.nres) then
4866           iii=ii-nres
4867           jjj=jj-nres
4868         else
4869           iii=ii
4870           jjj=jj
4871         endif
4872 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4873 c     &    dhpb(i),dhpb1(i),forcon(i)
4874 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4875 C    distance and angle dependent SS bond potential.
4876         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4877      & iabs(itype(jjj)).eq.1) then
4878 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4879 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4880         if (.not.dyn_ss .and. i.le.nss) then
4881 C 15/02/13 CC dynamic SSbond - additional check
4882          if (ii.gt.nres
4883      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4884           call ssbond_ene(iii,jjj,eij)
4885           ehpb=ehpb+2*eij
4886          endif
4887 cd          write (iout,*) "eij",eij
4888         else
4889 C Calculate the distance between the two points and its difference from the
4890 C target distance.
4891           dd=dist(ii,jj)
4892             rdis=dd-dhpb(i)
4893 C Get the force constant corresponding to this distance.
4894             waga=forcon(i)
4895 C Calculate the contribution to energy.
4896             ehpb=ehpb+waga*rdis*rdis
4897 C
4898 C Evaluate gradient.
4899 C
4900             fac=waga*rdis/dd
4901 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4902 cd   &   ' waga=',waga,' fac=',fac
4903             do j=1,3
4904               ggg(j)=fac*(c(j,jj)-c(j,ii))
4905             enddo
4906 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4907 C If this is a SC-SC distance, we need to calculate the contributions to the
4908 C Cartesian gradient in the SC vectors (ghpbx).
4909           if (iii.lt.ii) then
4910           do j=1,3
4911             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4912             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4913           enddo
4914           endif
4915 cgrad        do j=iii,jjj-1
4916 cgrad          do k=1,3
4917 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4918 cgrad          enddo
4919 cgrad        enddo
4920           do k=1,3
4921             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4922             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4923           enddo
4924         endif
4925       enddo
4926       ehpb=0.5D0*ehpb
4927       return
4928       end
4929 C--------------------------------------------------------------------------
4930       subroutine ssbond_ene(i,j,eij)
4931 C
4932 C Calculate the distance and angle dependent SS-bond potential energy
4933 C using a free-energy function derived based on RHF/6-31G** ab initio
4934 C calculations of diethyl disulfide.
4935 C
4936 C A. Liwo and U. Kozlowska, 11/24/03
4937 C
4938       implicit real*8 (a-h,o-z)
4939       include 'DIMENSIONS'
4940       include 'COMMON.SBRIDGE'
4941       include 'COMMON.CHAIN'
4942       include 'COMMON.DERIV'
4943       include 'COMMON.LOCAL'
4944       include 'COMMON.INTERACT'
4945       include 'COMMON.VAR'
4946       include 'COMMON.IOUNITS'
4947       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4948       itypi=iabs(itype(i))
4949       xi=c(1,nres+i)
4950       yi=c(2,nres+i)
4951       zi=c(3,nres+i)
4952       dxi=dc_norm(1,nres+i)
4953       dyi=dc_norm(2,nres+i)
4954       dzi=dc_norm(3,nres+i)
4955 c      dsci_inv=dsc_inv(itypi)
4956       dsci_inv=vbld_inv(nres+i)
4957       itypj=iabs(itype(j))
4958 c      dscj_inv=dsc_inv(itypj)
4959       dscj_inv=vbld_inv(nres+j)
4960       xj=c(1,nres+j)-xi
4961       yj=c(2,nres+j)-yi
4962       zj=c(3,nres+j)-zi
4963       dxj=dc_norm(1,nres+j)
4964       dyj=dc_norm(2,nres+j)
4965       dzj=dc_norm(3,nres+j)
4966       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4967       rij=dsqrt(rrij)
4968       erij(1)=xj*rij
4969       erij(2)=yj*rij
4970       erij(3)=zj*rij
4971       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4972       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4973       om12=dxi*dxj+dyi*dyj+dzi*dzj
4974       do k=1,3
4975         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4976         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4977       enddo
4978       rij=1.0d0/rij
4979       deltad=rij-d0cm
4980       deltat1=1.0d0-om1
4981       deltat2=1.0d0+om2
4982       deltat12=om2-om1+2.0d0
4983       cosphi=om12-om1*om2
4984       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4985      &  +akct*deltad*deltat12
4986      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4987 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4988 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4989 c     &  " deltat12",deltat12," eij",eij
4990       ed=2*akcm*deltad+akct*deltat12
4991       pom1=akct*deltad
4992       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4993       eom1=-2*akth*deltat1-pom1-om2*pom2
4994       eom2= 2*akth*deltat2+pom1-om1*pom2
4995       eom12=pom2
4996       do k=1,3
4997         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4998         ghpbx(k,i)=ghpbx(k,i)-ggk
4999      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5000      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5001         ghpbx(k,j)=ghpbx(k,j)+ggk
5002      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5003      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5004         ghpbc(k,i)=ghpbc(k,i)-ggk
5005         ghpbc(k,j)=ghpbc(k,j)+ggk
5006       enddo
5007 C
5008 C Calculate the components of the gradient in DC and X
5009 C
5010 cgrad      do k=i,j-1
5011 cgrad        do l=1,3
5012 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5013 cgrad        enddo
5014 cgrad      enddo
5015       return
5016       end
5017 C--------------------------------------------------------------------------
5018       subroutine ebond(estr)
5019 c
5020 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5021 c
5022       implicit real*8 (a-h,o-z)
5023       include 'DIMENSIONS'
5024       include 'COMMON.LOCAL'
5025       include 'COMMON.GEO'
5026       include 'COMMON.INTERACT'
5027       include 'COMMON.DERIV'
5028       include 'COMMON.VAR'
5029       include 'COMMON.CHAIN'
5030       include 'COMMON.IOUNITS'
5031       include 'COMMON.NAMES'
5032       include 'COMMON.FFIELD'
5033       include 'COMMON.CONTROL'
5034       include 'COMMON.SETUP'
5035       double precision u(3),ud(3)
5036       estr=0.0d0
5037       estr1=0.0d0
5038       do i=ibondp_start,ibondp_end
5039         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5040 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5041 c          do j=1,3
5042 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5043 c     &      *dc(j,i-1)/vbld(i)
5044 c          enddo
5045 c          if (energy_dec) write(iout,*)
5046 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5047 c        else
5048 C       Checking if it involves dummy (NH3+ or COO-) group
5049          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5050 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5051         diff = vbld(i)-vbldpDUM
5052          else
5053 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5054         diff = vbld(i)-vbldp0
5055          endif
5056         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5057      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5058         estr=estr+diff*diff
5059         do j=1,3
5060           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5061         enddo
5062 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5063 c        endif
5064       enddo
5065       estr=0.5d0*AKP*estr+estr1
5066 c
5067 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5068 c
5069       do i=ibond_start,ibond_end
5070         iti=iabs(itype(i))
5071         if (iti.ne.10 .and. iti.ne.ntyp1) then
5072           nbi=nbondterm(iti)
5073           if (nbi.eq.1) then
5074             diff=vbld(i+nres)-vbldsc0(1,iti)
5075             if (energy_dec)  write (iout,*)
5076      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5077      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5078             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5079             do j=1,3
5080               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5081             enddo
5082           else
5083             do j=1,nbi
5084               diff=vbld(i+nres)-vbldsc0(j,iti)
5085               ud(j)=aksc(j,iti)*diff
5086               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5087             enddo
5088             uprod=u(1)
5089             do j=2,nbi
5090               uprod=uprod*u(j)
5091             enddo
5092             usum=0.0d0
5093             usumsqder=0.0d0
5094             do j=1,nbi
5095               uprod1=1.0d0
5096               uprod2=1.0d0
5097               do k=1,nbi
5098                 if (k.ne.j) then
5099                   uprod1=uprod1*u(k)
5100                   uprod2=uprod2*u(k)*u(k)
5101                 endif
5102               enddo
5103               usum=usum+uprod1
5104               usumsqder=usumsqder+ud(j)*uprod2
5105             enddo
5106             estr=estr+uprod/usum
5107             do j=1,3
5108              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5109             enddo
5110           endif
5111         endif
5112       enddo
5113       return
5114       end
5115 #ifdef CRYST_THETA
5116 C--------------------------------------------------------------------------
5117       subroutine ebend(etheta)
5118 C
5119 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5120 C angles gamma and its derivatives in consecutive thetas and gammas.
5121 C
5122       implicit real*8 (a-h,o-z)
5123       include 'DIMENSIONS'
5124       include 'COMMON.LOCAL'
5125       include 'COMMON.GEO'
5126       include 'COMMON.INTERACT'
5127       include 'COMMON.DERIV'
5128       include 'COMMON.VAR'
5129       include 'COMMON.CHAIN'
5130       include 'COMMON.IOUNITS'
5131       include 'COMMON.NAMES'
5132       include 'COMMON.FFIELD'
5133       include 'COMMON.CONTROL'
5134       common /calcthet/ term1,term2,termm,diffak,ratak,
5135      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5136      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5137       double precision y(2),z(2)
5138       delta=0.02d0*pi
5139 c      time11=dexp(-2*time)
5140 c      time12=1.0d0
5141       etheta=0.0D0
5142 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5143       do i=ithet_start,ithet_end
5144         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5145      &  .or.itype(i).eq.ntyp1) cycle
5146 C Zero the energy function and its derivative at 0 or pi.
5147         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5148         it=itype(i-1)
5149         ichir1=isign(1,itype(i-2))
5150         ichir2=isign(1,itype(i))
5151          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5152          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5153          if (itype(i-1).eq.10) then
5154           itype1=isign(10,itype(i-2))
5155           ichir11=isign(1,itype(i-2))
5156           ichir12=isign(1,itype(i-2))
5157           itype2=isign(10,itype(i))
5158           ichir21=isign(1,itype(i))
5159           ichir22=isign(1,itype(i))
5160          endif
5161
5162         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5163 #ifdef OSF
5164           phii=phi(i)
5165           if (phii.ne.phii) phii=150.0
5166 #else
5167           phii=phi(i)
5168 #endif
5169           y(1)=dcos(phii)
5170           y(2)=dsin(phii)
5171         else
5172           y(1)=0.0D0
5173           y(2)=0.0D0
5174         endif
5175         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5176 #ifdef OSF
5177           phii1=phi(i+1)
5178           if (phii1.ne.phii1) phii1=150.0
5179           phii1=pinorm(phii1)
5180           z(1)=cos(phii1)
5181 #else
5182           phii1=phi(i+1)
5183 #endif
5184           z(1)=dcos(phii1)
5185           z(2)=dsin(phii1)
5186         else
5187           z(1)=0.0D0
5188           z(2)=0.0D0
5189         endif
5190 C Calculate the "mean" value of theta from the part of the distribution
5191 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5192 C In following comments this theta will be referred to as t_c.
5193         thet_pred_mean=0.0d0
5194         do k=1,2
5195             athetk=athet(k,it,ichir1,ichir2)
5196             bthetk=bthet(k,it,ichir1,ichir2)
5197           if (it.eq.10) then
5198              athetk=athet(k,itype1,ichir11,ichir12)
5199              bthetk=bthet(k,itype2,ichir21,ichir22)
5200           endif
5201          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5202 c         write(iout,*) 'chuj tu', y(k),z(k)
5203         enddo
5204         dthett=thet_pred_mean*ssd
5205         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5206 C Derivatives of the "mean" values in gamma1 and gamma2.
5207         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5208      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5209          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5210      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5211          if (it.eq.10) then
5212       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5213      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5214         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5215      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5216          endif
5217         if (theta(i).gt.pi-delta) then
5218           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5219      &         E_tc0)
5220           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5221           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5222           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5223      &        E_theta)
5224           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5225      &        E_tc)
5226         else if (theta(i).lt.delta) then
5227           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5228           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5229           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5230      &        E_theta)
5231           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5232           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5233      &        E_tc)
5234         else
5235           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5236      &        E_theta,E_tc)
5237         endif
5238         etheta=etheta+ethetai
5239         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5240      &      'ebend',i,ethetai,theta(i),itype(i)
5241         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5242         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5243         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5244       enddo
5245 C Ufff.... We've done all this!!!
5246       return
5247       end
5248 C---------------------------------------------------------------------------
5249       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5250      &     E_tc)
5251       implicit real*8 (a-h,o-z)
5252       include 'DIMENSIONS'
5253       include 'COMMON.LOCAL'
5254       include 'COMMON.IOUNITS'
5255       common /calcthet/ term1,term2,termm,diffak,ratak,
5256      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5257      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5258 C Calculate the contributions to both Gaussian lobes.
5259 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5260 C The "polynomial part" of the "standard deviation" of this part of
5261 C the distributioni.
5262 ccc        write (iout,*) thetai,thet_pred_mean
5263         sig=polthet(3,it)
5264         do j=2,0,-1
5265           sig=sig*thet_pred_mean+polthet(j,it)
5266         enddo
5267 C Derivative of the "interior part" of the "standard deviation of the"
5268 C gamma-dependent Gaussian lobe in t_c.
5269         sigtc=3*polthet(3,it)
5270         do j=2,1,-1
5271           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5272         enddo
5273         sigtc=sig*sigtc
5274 C Set the parameters of both Gaussian lobes of the distribution.
5275 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5276         fac=sig*sig+sigc0(it)
5277         sigcsq=fac+fac
5278         sigc=1.0D0/sigcsq
5279 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5280         sigsqtc=-4.0D0*sigcsq*sigtc
5281 c       print *,i,sig,sigtc,sigsqtc
5282 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5283         sigtc=-sigtc/(fac*fac)
5284 C Following variable is sigma(t_c)**(-2)
5285         sigcsq=sigcsq*sigcsq
5286         sig0i=sig0(it)
5287         sig0inv=1.0D0/sig0i**2
5288         delthec=thetai-thet_pred_mean
5289         delthe0=thetai-theta0i
5290         term1=-0.5D0*sigcsq*delthec*delthec
5291         term2=-0.5D0*sig0inv*delthe0*delthe0
5292 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5293 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5294 C NaNs in taking the logarithm. We extract the largest exponent which is added
5295 C to the energy (this being the log of the distribution) at the end of energy
5296 C term evaluation for this virtual-bond angle.
5297         if (term1.gt.term2) then
5298           termm=term1
5299           term2=dexp(term2-termm)
5300           term1=1.0d0
5301         else
5302           termm=term2
5303           term1=dexp(term1-termm)
5304           term2=1.0d0
5305         endif
5306 C The ratio between the gamma-independent and gamma-dependent lobes of
5307 C the distribution is a Gaussian function of thet_pred_mean too.
5308         diffak=gthet(2,it)-thet_pred_mean
5309         ratak=diffak/gthet(3,it)**2
5310         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5311 C Let's differentiate it in thet_pred_mean NOW.
5312         aktc=ak*ratak
5313 C Now put together the distribution terms to make complete distribution.
5314         termexp=term1+ak*term2
5315         termpre=sigc+ak*sig0i
5316 C Contribution of the bending energy from this theta is just the -log of
5317 C the sum of the contributions from the two lobes and the pre-exponential
5318 C factor. Simple enough, isn't it?
5319         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5320 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5321 C NOW the derivatives!!!
5322 C 6/6/97 Take into account the deformation.
5323         E_theta=(delthec*sigcsq*term1
5324      &       +ak*delthe0*sig0inv*term2)/termexp
5325         E_tc=((sigtc+aktc*sig0i)/termpre
5326      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5327      &       aktc*term2)/termexp)
5328       return
5329       end
5330 c-----------------------------------------------------------------------------
5331       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5332       implicit real*8 (a-h,o-z)
5333       include 'DIMENSIONS'
5334       include 'COMMON.LOCAL'
5335       include 'COMMON.IOUNITS'
5336       common /calcthet/ term1,term2,termm,diffak,ratak,
5337      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5338      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5339       delthec=thetai-thet_pred_mean
5340       delthe0=thetai-theta0i
5341 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5342       t3 = thetai-thet_pred_mean
5343       t6 = t3**2
5344       t9 = term1
5345       t12 = t3*sigcsq
5346       t14 = t12+t6*sigsqtc
5347       t16 = 1.0d0
5348       t21 = thetai-theta0i
5349       t23 = t21**2
5350       t26 = term2
5351       t27 = t21*t26
5352       t32 = termexp
5353       t40 = t32**2
5354       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5355      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5356      & *(-t12*t9-ak*sig0inv*t27)
5357       return
5358       end
5359 #else
5360 C--------------------------------------------------------------------------
5361       subroutine ebend(etheta)
5362 C
5363 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5364 C angles gamma and its derivatives in consecutive thetas and gammas.
5365 C ab initio-derived potentials from
5366 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5367 C
5368       implicit real*8 (a-h,o-z)
5369       include 'DIMENSIONS'
5370       include 'COMMON.LOCAL'
5371       include 'COMMON.GEO'
5372       include 'COMMON.INTERACT'
5373       include 'COMMON.DERIV'
5374       include 'COMMON.VAR'
5375       include 'COMMON.CHAIN'
5376       include 'COMMON.IOUNITS'
5377       include 'COMMON.NAMES'
5378       include 'COMMON.FFIELD'
5379       include 'COMMON.CONTROL'
5380       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5381      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5382      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5383      & sinph1ph2(maxdouble,maxdouble)
5384       logical lprn /.false./, lprn1 /.false./
5385       etheta=0.0D0
5386       do i=ithet_start,ithet_end
5387 c        print *,i,itype(i-1),itype(i),itype(i-2)
5388         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5389      &  .or.itype(i).eq.ntyp1) cycle
5390 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5391
5392         if (iabs(itype(i+1)).eq.20) iblock=2
5393         if (iabs(itype(i+1)).ne.20) iblock=1
5394         dethetai=0.0d0
5395         dephii=0.0d0
5396         dephii1=0.0d0
5397         theti2=0.5d0*theta(i)
5398         ityp2=ithetyp((itype(i-1)))
5399         do k=1,nntheterm
5400           coskt(k)=dcos(k*theti2)
5401           sinkt(k)=dsin(k*theti2)
5402         enddo
5403         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5404 #ifdef OSF
5405           phii=phi(i)
5406           if (phii.ne.phii) phii=150.0
5407 #else
5408           phii=phi(i)
5409 #endif
5410           ityp1=ithetyp((itype(i-2)))
5411 C propagation of chirality for glycine type
5412           do k=1,nsingle
5413             cosph1(k)=dcos(k*phii)
5414             sinph1(k)=dsin(k*phii)
5415           enddo
5416         else
5417           phii=0.0d0
5418           ityp1=nthetyp+1
5419           do k=1,nsingle
5420             cosph1(k)=0.0d0
5421             sinph1(k)=0.0d0
5422           enddo
5423         endif
5424         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5425 #ifdef OSF
5426           phii1=phi(i+1)
5427           if (phii1.ne.phii1) phii1=150.0
5428           phii1=pinorm(phii1)
5429 #else
5430           phii1=phi(i+1)
5431 #endif
5432           ityp3=ithetyp((itype(i)))
5433           do k=1,nsingle
5434             cosph2(k)=dcos(k*phii1)
5435             sinph2(k)=dsin(k*phii1)
5436           enddo
5437         else
5438           phii1=0.0d0
5439           ityp3=nthetyp+1
5440           do k=1,nsingle
5441             cosph2(k)=0.0d0
5442             sinph2(k)=0.0d0
5443           enddo
5444         endif
5445         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5446         do k=1,ndouble
5447           do l=1,k-1
5448             ccl=cosph1(l)*cosph2(k-l)
5449             ssl=sinph1(l)*sinph2(k-l)
5450             scl=sinph1(l)*cosph2(k-l)
5451             csl=cosph1(l)*sinph2(k-l)
5452             cosph1ph2(l,k)=ccl-ssl
5453             cosph1ph2(k,l)=ccl+ssl
5454             sinph1ph2(l,k)=scl+csl
5455             sinph1ph2(k,l)=scl-csl
5456           enddo
5457         enddo
5458         if (lprn) then
5459         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5460      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5461         write (iout,*) "coskt and sinkt"
5462         do k=1,nntheterm
5463           write (iout,*) k,coskt(k),sinkt(k)
5464         enddo
5465         endif
5466         do k=1,ntheterm
5467           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5468           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5469      &      *coskt(k)
5470           if (lprn)
5471      &    write (iout,*) "k",k,"
5472      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5473      &     " ethetai",ethetai
5474         enddo
5475         if (lprn) then
5476         write (iout,*) "cosph and sinph"
5477         do k=1,nsingle
5478           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5479         enddo
5480         write (iout,*) "cosph1ph2 and sinph2ph2"
5481         do k=2,ndouble
5482           do l=1,k-1
5483             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5484      &         sinph1ph2(l,k),sinph1ph2(k,l)
5485           enddo
5486         enddo
5487         write(iout,*) "ethetai",ethetai
5488         endif
5489         do m=1,ntheterm2
5490           do k=1,nsingle
5491             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5492      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5493      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5494      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5495             ethetai=ethetai+sinkt(m)*aux
5496             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5497             dephii=dephii+k*sinkt(m)*(
5498      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5499      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5500             dephii1=dephii1+k*sinkt(m)*(
5501      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5502      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5503             if (lprn)
5504      &      write (iout,*) "m",m," k",k," bbthet",
5505      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5506      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5507      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5508      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5509           enddo
5510         enddo
5511         if (lprn)
5512      &  write(iout,*) "ethetai",ethetai
5513         do m=1,ntheterm3
5514           do k=2,ndouble
5515             do l=1,k-1
5516               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5517      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5518      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5519      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5520               ethetai=ethetai+sinkt(m)*aux
5521               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5522               dephii=dephii+l*sinkt(m)*(
5523      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5524      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5525      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5526      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5527               dephii1=dephii1+(k-l)*sinkt(m)*(
5528      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5529      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5530      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5531      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5532               if (lprn) then
5533               write (iout,*) "m",m," k",k," l",l," ffthet",
5534      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5535      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5536      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5537      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5538      &            " ethetai",ethetai
5539               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5540      &            cosph1ph2(k,l)*sinkt(m),
5541      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5542               endif
5543             enddo
5544           enddo
5545         enddo
5546 10      continue
5547 c        lprn1=.true.
5548         if (lprn1)
5549      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5550      &   i,theta(i)*rad2deg,phii*rad2deg,
5551      &   phii1*rad2deg,ethetai
5552 c        lprn1=.false.
5553         etheta=etheta+ethetai
5554         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5555         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5556         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5557       enddo
5558       return
5559       end
5560 #endif
5561 #ifdef CRYST_SC
5562 c-----------------------------------------------------------------------------
5563       subroutine esc(escloc)
5564 C Calculate the local energy of a side chain and its derivatives in the
5565 C corresponding virtual-bond valence angles THETA and the spherical angles
5566 C ALPHA and OMEGA.
5567       implicit real*8 (a-h,o-z)
5568       include 'DIMENSIONS'
5569       include 'COMMON.GEO'
5570       include 'COMMON.LOCAL'
5571       include 'COMMON.VAR'
5572       include 'COMMON.INTERACT'
5573       include 'COMMON.DERIV'
5574       include 'COMMON.CHAIN'
5575       include 'COMMON.IOUNITS'
5576       include 'COMMON.NAMES'
5577       include 'COMMON.FFIELD'
5578       include 'COMMON.CONTROL'
5579       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5580      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5581       common /sccalc/ time11,time12,time112,theti,it,nlobit
5582       delta=0.02d0*pi
5583       escloc=0.0D0
5584 c     write (iout,'(a)') 'ESC'
5585       do i=loc_start,loc_end
5586         it=itype(i)
5587         if (it.eq.ntyp1) cycle
5588         if (it.eq.10) goto 1
5589         nlobit=nlob(iabs(it))
5590 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5591 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5592         theti=theta(i+1)-pipol
5593         x(1)=dtan(theti)
5594         x(2)=alph(i)
5595         x(3)=omeg(i)
5596
5597         if (x(2).gt.pi-delta) then
5598           xtemp(1)=x(1)
5599           xtemp(2)=pi-delta
5600           xtemp(3)=x(3)
5601           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5602           xtemp(2)=pi
5603           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5604           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5605      &        escloci,dersc(2))
5606           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5607      &        ddersc0(1),dersc(1))
5608           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5609      &        ddersc0(3),dersc(3))
5610           xtemp(2)=pi-delta
5611           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5612           xtemp(2)=pi
5613           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5614           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5615      &            dersc0(2),esclocbi,dersc02)
5616           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5617      &            dersc12,dersc01)
5618           call splinthet(x(2),0.5d0*delta,ss,ssd)
5619           dersc0(1)=dersc01
5620           dersc0(2)=dersc02
5621           dersc0(3)=0.0d0
5622           do k=1,3
5623             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5624           enddo
5625           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5626 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5627 c    &             esclocbi,ss,ssd
5628           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5629 c         escloci=esclocbi
5630 c         write (iout,*) escloci
5631         else if (x(2).lt.delta) then
5632           xtemp(1)=x(1)
5633           xtemp(2)=delta
5634           xtemp(3)=x(3)
5635           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5636           xtemp(2)=0.0d0
5637           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5638           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5639      &        escloci,dersc(2))
5640           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5641      &        ddersc0(1),dersc(1))
5642           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5643      &        ddersc0(3),dersc(3))
5644           xtemp(2)=delta
5645           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5646           xtemp(2)=0.0d0
5647           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5648           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5649      &            dersc0(2),esclocbi,dersc02)
5650           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5651      &            dersc12,dersc01)
5652           dersc0(1)=dersc01
5653           dersc0(2)=dersc02
5654           dersc0(3)=0.0d0
5655           call splinthet(x(2),0.5d0*delta,ss,ssd)
5656           do k=1,3
5657             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5658           enddo
5659           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5660 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5661 c    &             esclocbi,ss,ssd
5662           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5663 c         write (iout,*) escloci
5664         else
5665           call enesc(x,escloci,dersc,ddummy,.false.)
5666         endif
5667
5668         escloc=escloc+escloci
5669         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5670      &     'escloc',i,escloci
5671 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5672
5673         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5674      &   wscloc*dersc(1)
5675         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5676         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5677     1   continue
5678       enddo
5679       return
5680       end
5681 C---------------------------------------------------------------------------
5682       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5683       implicit real*8 (a-h,o-z)
5684       include 'DIMENSIONS'
5685       include 'COMMON.GEO'
5686       include 'COMMON.LOCAL'
5687       include 'COMMON.IOUNITS'
5688       common /sccalc/ time11,time12,time112,theti,it,nlobit
5689       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5690       double precision contr(maxlob,-1:1)
5691       logical mixed
5692 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5693         escloc_i=0.0D0
5694         do j=1,3
5695           dersc(j)=0.0D0
5696           if (mixed) ddersc(j)=0.0d0
5697         enddo
5698         x3=x(3)
5699
5700 C Because of periodicity of the dependence of the SC energy in omega we have
5701 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5702 C To avoid underflows, first compute & store the exponents.
5703
5704         do iii=-1,1
5705
5706           x(3)=x3+iii*dwapi
5707
5708           do j=1,nlobit
5709             do k=1,3
5710               z(k)=x(k)-censc(k,j,it)
5711             enddo
5712             do k=1,3
5713               Axk=0.0D0
5714               do l=1,3
5715                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5716               enddo
5717               Ax(k,j,iii)=Axk
5718             enddo
5719             expfac=0.0D0
5720             do k=1,3
5721               expfac=expfac+Ax(k,j,iii)*z(k)
5722             enddo
5723             contr(j,iii)=expfac
5724           enddo ! j
5725
5726         enddo ! iii
5727
5728         x(3)=x3
5729 C As in the case of ebend, we want to avoid underflows in exponentiation and
5730 C subsequent NaNs and INFs in energy calculation.
5731 C Find the largest exponent
5732         emin=contr(1,-1)
5733         do iii=-1,1
5734           do j=1,nlobit
5735             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5736           enddo
5737         enddo
5738         emin=0.5D0*emin
5739 cd      print *,'it=',it,' emin=',emin
5740
5741 C Compute the contribution to SC energy and derivatives
5742         do iii=-1,1
5743
5744           do j=1,nlobit
5745 #ifdef OSF
5746             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5747             if(adexp.ne.adexp) adexp=1.0
5748             expfac=dexp(adexp)
5749 #else
5750             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5751 #endif
5752 cd          print *,'j=',j,' expfac=',expfac
5753             escloc_i=escloc_i+expfac
5754             do k=1,3
5755               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5756             enddo
5757             if (mixed) then
5758               do k=1,3,2
5759                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5760      &            +gaussc(k,2,j,it))*expfac
5761               enddo
5762             endif
5763           enddo
5764
5765         enddo ! iii
5766
5767         dersc(1)=dersc(1)/cos(theti)**2
5768         ddersc(1)=ddersc(1)/cos(theti)**2
5769         ddersc(3)=ddersc(3)
5770
5771         escloci=-(dlog(escloc_i)-emin)
5772         do j=1,3
5773           dersc(j)=dersc(j)/escloc_i
5774         enddo
5775         if (mixed) then
5776           do j=1,3,2
5777             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5778           enddo
5779         endif
5780       return
5781       end
5782 C------------------------------------------------------------------------------
5783       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5784       implicit real*8 (a-h,o-z)
5785       include 'DIMENSIONS'
5786       include 'COMMON.GEO'
5787       include 'COMMON.LOCAL'
5788       include 'COMMON.IOUNITS'
5789       common /sccalc/ time11,time12,time112,theti,it,nlobit
5790       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5791       double precision contr(maxlob)
5792       logical mixed
5793
5794       escloc_i=0.0D0
5795
5796       do j=1,3
5797         dersc(j)=0.0D0
5798       enddo
5799
5800       do j=1,nlobit
5801         do k=1,2
5802           z(k)=x(k)-censc(k,j,it)
5803         enddo
5804         z(3)=dwapi
5805         do k=1,3
5806           Axk=0.0D0
5807           do l=1,3
5808             Axk=Axk+gaussc(l,k,j,it)*z(l)
5809           enddo
5810           Ax(k,j)=Axk
5811         enddo
5812         expfac=0.0D0
5813         do k=1,3
5814           expfac=expfac+Ax(k,j)*z(k)
5815         enddo
5816         contr(j)=expfac
5817       enddo ! j
5818
5819 C As in the case of ebend, we want to avoid underflows in exponentiation and
5820 C subsequent NaNs and INFs in energy calculation.
5821 C Find the largest exponent
5822       emin=contr(1)
5823       do j=1,nlobit
5824         if (emin.gt.contr(j)) emin=contr(j)
5825       enddo
5826       emin=0.5D0*emin
5827
5828 C Compute the contribution to SC energy and derivatives
5829
5830       dersc12=0.0d0
5831       do j=1,nlobit
5832         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5833         escloc_i=escloc_i+expfac
5834         do k=1,2
5835           dersc(k)=dersc(k)+Ax(k,j)*expfac
5836         enddo
5837         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5838      &            +gaussc(1,2,j,it))*expfac
5839         dersc(3)=0.0d0
5840       enddo
5841
5842       dersc(1)=dersc(1)/cos(theti)**2
5843       dersc12=dersc12/cos(theti)**2
5844       escloci=-(dlog(escloc_i)-emin)
5845       do j=1,2
5846         dersc(j)=dersc(j)/escloc_i
5847       enddo
5848       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5849       return
5850       end
5851 #else
5852 c----------------------------------------------------------------------------------
5853       subroutine esc(escloc)
5854 C Calculate the local energy of a side chain and its derivatives in the
5855 C corresponding virtual-bond valence angles THETA and the spherical angles
5856 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5857 C added by Urszula Kozlowska. 07/11/2007
5858 C
5859       implicit real*8 (a-h,o-z)
5860       include 'DIMENSIONS'
5861       include 'COMMON.GEO'
5862       include 'COMMON.LOCAL'
5863       include 'COMMON.VAR'
5864       include 'COMMON.SCROT'
5865       include 'COMMON.INTERACT'
5866       include 'COMMON.DERIV'
5867       include 'COMMON.CHAIN'
5868       include 'COMMON.IOUNITS'
5869       include 'COMMON.NAMES'
5870       include 'COMMON.FFIELD'
5871       include 'COMMON.CONTROL'
5872       include 'COMMON.VECTORS'
5873       double precision x_prime(3),y_prime(3),z_prime(3)
5874      &    , sumene,dsc_i,dp2_i,x(65),
5875      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5876      &    de_dxx,de_dyy,de_dzz,de_dt
5877       double precision s1_t,s1_6_t,s2_t,s2_6_t
5878       double precision
5879      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5880      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5881      & dt_dCi(3),dt_dCi1(3)
5882       common /sccalc/ time11,time12,time112,theti,it,nlobit
5883       delta=0.02d0*pi
5884       escloc=0.0D0
5885       do i=loc_start,loc_end
5886         if (itype(i).eq.ntyp1) cycle
5887         costtab(i+1) =dcos(theta(i+1))
5888         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5889         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5890         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5891         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5892         cosfac=dsqrt(cosfac2)
5893         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5894         sinfac=dsqrt(sinfac2)
5895         it=iabs(itype(i))
5896         if (it.eq.10) goto 1
5897 c
5898 C  Compute the axes of tghe local cartesian coordinates system; store in
5899 c   x_prime, y_prime and z_prime
5900 c
5901         do j=1,3
5902           x_prime(j) = 0.00
5903           y_prime(j) = 0.00
5904           z_prime(j) = 0.00
5905         enddo
5906 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5907 C     &   dc_norm(3,i+nres)
5908         do j = 1,3
5909           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5910           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5911         enddo
5912         do j = 1,3
5913           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5914         enddo
5915 c       write (2,*) "i",i
5916 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5917 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5918 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5919 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5920 c      & " xy",scalar(x_prime(1),y_prime(1)),
5921 c      & " xz",scalar(x_prime(1),z_prime(1)),
5922 c      & " yy",scalar(y_prime(1),y_prime(1)),
5923 c      & " yz",scalar(y_prime(1),z_prime(1)),
5924 c      & " zz",scalar(z_prime(1),z_prime(1))
5925 c
5926 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5927 C to local coordinate system. Store in xx, yy, zz.
5928 c
5929         xx=0.0d0
5930         yy=0.0d0
5931         zz=0.0d0
5932         do j = 1,3
5933           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5934           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5935           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5936         enddo
5937
5938         xxtab(i)=xx
5939         yytab(i)=yy
5940         zztab(i)=zz
5941 C
5942 C Compute the energy of the ith side cbain
5943 C
5944 c        write (2,*) "xx",xx," yy",yy," zz",zz
5945         it=iabs(itype(i))
5946         do j = 1,65
5947           x(j) = sc_parmin(j,it)
5948         enddo
5949 #ifdef CHECK_COORD
5950 Cc diagnostics - remove later
5951         xx1 = dcos(alph(2))
5952         yy1 = dsin(alph(2))*dcos(omeg(2))
5953         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5954         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5955      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5956      &    xx1,yy1,zz1
5957 C,"  --- ", xx_w,yy_w,zz_w
5958 c end diagnostics
5959 #endif
5960         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5961      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5962      &   + x(10)*yy*zz
5963         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5964      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5965      & + x(20)*yy*zz
5966         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5967      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5968      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5969      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5970      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5971      &  +x(40)*xx*yy*zz
5972         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5973      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5974      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5975      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5976      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5977      &  +x(60)*xx*yy*zz
5978         dsc_i   = 0.743d0+x(61)
5979         dp2_i   = 1.9d0+x(62)
5980         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5981      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5982         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5983      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5984         s1=(1+x(63))/(0.1d0 + dscp1)
5985         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5986         s2=(1+x(65))/(0.1d0 + dscp2)
5987         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5988         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5989      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5990 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5991 c     &   sumene4,
5992 c     &   dscp1,dscp2,sumene
5993 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5994         escloc = escloc + sumene
5995 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5996 c     & ,zz,xx,yy
5997 c#define DEBUG
5998 #ifdef DEBUG
5999 C
6000 C This section to check the numerical derivatives of the energy of ith side
6001 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6002 C #define DEBUG in the code to turn it on.
6003 C
6004         write (2,*) "sumene               =",sumene
6005         aincr=1.0d-7
6006         xxsave=xx
6007         xx=xx+aincr
6008         write (2,*) xx,yy,zz
6009         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6010         de_dxx_num=(sumenep-sumene)/aincr
6011         xx=xxsave
6012         write (2,*) "xx+ sumene from enesc=",sumenep
6013         yysave=yy
6014         yy=yy+aincr
6015         write (2,*) xx,yy,zz
6016         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6017         de_dyy_num=(sumenep-sumene)/aincr
6018         yy=yysave
6019         write (2,*) "yy+ sumene from enesc=",sumenep
6020         zzsave=zz
6021         zz=zz+aincr
6022         write (2,*) xx,yy,zz
6023         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6024         de_dzz_num=(sumenep-sumene)/aincr
6025         zz=zzsave
6026         write (2,*) "zz+ sumene from enesc=",sumenep
6027         costsave=cost2tab(i+1)
6028         sintsave=sint2tab(i+1)
6029         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6030         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6031         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6032         de_dt_num=(sumenep-sumene)/aincr
6033         write (2,*) " t+ sumene from enesc=",sumenep
6034         cost2tab(i+1)=costsave
6035         sint2tab(i+1)=sintsave
6036 C End of diagnostics section.
6037 #endif
6038 C
6039 C Compute the gradient of esc
6040 C
6041 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6042         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6043         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6044         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6045         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6046         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6047         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6048         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6049         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6050         pom1=(sumene3*sint2tab(i+1)+sumene1)
6051      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6052         pom2=(sumene4*cost2tab(i+1)+sumene2)
6053      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6054         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6055         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6056      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6057      &  +x(40)*yy*zz
6058         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6059         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6060      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6061      &  +x(60)*yy*zz
6062         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6063      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6064      &        +(pom1+pom2)*pom_dx
6065 #ifdef DEBUG
6066         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6067 #endif
6068 C
6069         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6070         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6071      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6072      &  +x(40)*xx*zz
6073         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6074         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6075      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6076      &  +x(59)*zz**2 +x(60)*xx*zz
6077         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6078      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6079      &        +(pom1-pom2)*pom_dy
6080 #ifdef DEBUG
6081         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6082 #endif
6083 C
6084         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6085      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6086      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6087      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6088      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6089      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6090      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6091      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6092 #ifdef DEBUG
6093         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6094 #endif
6095 C
6096         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6097      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6098      &  +pom1*pom_dt1+pom2*pom_dt2
6099 #ifdef DEBUG
6100         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6101 #endif
6102 c#undef DEBUG
6103 c
6104 C
6105        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6106        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6107        cosfac2xx=cosfac2*xx
6108        sinfac2yy=sinfac2*yy
6109        do k = 1,3
6110          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6111      &      vbld_inv(i+1)
6112          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6113      &      vbld_inv(i)
6114          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6115          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6116 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6117 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6118 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6119 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6120          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6121          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6122          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6123          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6124          dZZ_Ci1(k)=0.0d0
6125          dZZ_Ci(k)=0.0d0
6126          do j=1,3
6127            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6128      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6129            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6130      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6131          enddo
6132
6133          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6134          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6135          dZZ_XYZ(k)=vbld_inv(i+nres)*
6136      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6137 c
6138          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6139          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6140        enddo
6141
6142        do k=1,3
6143          dXX_Ctab(k,i)=dXX_Ci(k)
6144          dXX_C1tab(k,i)=dXX_Ci1(k)
6145          dYY_Ctab(k,i)=dYY_Ci(k)
6146          dYY_C1tab(k,i)=dYY_Ci1(k)
6147          dZZ_Ctab(k,i)=dZZ_Ci(k)
6148          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6149          dXX_XYZtab(k,i)=dXX_XYZ(k)
6150          dYY_XYZtab(k,i)=dYY_XYZ(k)
6151          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6152        enddo
6153
6154        do k = 1,3
6155 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6156 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6157 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6158 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6159 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6160 c     &    dt_dci(k)
6161 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6162 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6163          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6164      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6165          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6166      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6167          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6168      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6169        enddo
6170 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6171 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6172
6173 C to check gradient call subroutine check_grad
6174
6175     1 continue
6176       enddo
6177       return
6178       end
6179 c------------------------------------------------------------------------------
6180       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6181       implicit none
6182       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6183      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6184       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6185      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6186      &   + x(10)*yy*zz
6187       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6188      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6189      & + x(20)*yy*zz
6190       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6191      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6192      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6193      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6194      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6195      &  +x(40)*xx*yy*zz
6196       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6197      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6198      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6199      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6200      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6201      &  +x(60)*xx*yy*zz
6202       dsc_i   = 0.743d0+x(61)
6203       dp2_i   = 1.9d0+x(62)
6204       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6205      &          *(xx*cost2+yy*sint2))
6206       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6207      &          *(xx*cost2-yy*sint2))
6208       s1=(1+x(63))/(0.1d0 + dscp1)
6209       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6210       s2=(1+x(65))/(0.1d0 + dscp2)
6211       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6212       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6213      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6214       enesc=sumene
6215       return
6216       end
6217 #endif
6218 c------------------------------------------------------------------------------
6219       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6220 C
6221 C This procedure calculates two-body contact function g(rij) and its derivative:
6222 C
6223 C           eps0ij                                     !       x < -1
6224 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6225 C            0                                         !       x > 1
6226 C
6227 C where x=(rij-r0ij)/delta
6228 C
6229 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6230 C
6231       implicit none
6232       double precision rij,r0ij,eps0ij,fcont,fprimcont
6233       double precision x,x2,x4,delta
6234 c     delta=0.02D0*r0ij
6235 c      delta=0.2D0*r0ij
6236       x=(rij-r0ij)/delta
6237       if (x.lt.-1.0D0) then
6238         fcont=eps0ij
6239         fprimcont=0.0D0
6240       else if (x.le.1.0D0) then
6241         x2=x*x
6242         x4=x2*x2
6243         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6244         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6245       else
6246         fcont=0.0D0
6247         fprimcont=0.0D0
6248       endif
6249       return
6250       end
6251 c------------------------------------------------------------------------------
6252       subroutine splinthet(theti,delta,ss,ssder)
6253       implicit real*8 (a-h,o-z)
6254       include 'DIMENSIONS'
6255       include 'COMMON.VAR'
6256       include 'COMMON.GEO'
6257       thetup=pi-delta
6258       thetlow=delta
6259       if (theti.gt.pipol) then
6260         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6261       else
6262         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6263         ssder=-ssder
6264       endif
6265       return
6266       end
6267 c------------------------------------------------------------------------------
6268       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6269       implicit none
6270       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6271       double precision ksi,ksi2,ksi3,a1,a2,a3
6272       a1=fprim0*delta/(f1-f0)
6273       a2=3.0d0-2.0d0*a1
6274       a3=a1-2.0d0
6275       ksi=(x-x0)/delta
6276       ksi2=ksi*ksi
6277       ksi3=ksi2*ksi
6278       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6279       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6280       return
6281       end
6282 c------------------------------------------------------------------------------
6283       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6284       implicit none
6285       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6286       double precision ksi,ksi2,ksi3,a1,a2,a3
6287       ksi=(x-x0)/delta
6288       ksi2=ksi*ksi
6289       ksi3=ksi2*ksi
6290       a1=fprim0x*delta
6291       a2=3*(f1x-f0x)-2*fprim0x*delta
6292       a3=fprim0x*delta-2*(f1x-f0x)
6293       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6294       return
6295       end
6296 C-----------------------------------------------------------------------------
6297 #ifdef CRYST_TOR
6298 C-----------------------------------------------------------------------------
6299       subroutine etor(etors,edihcnstr)
6300       implicit real*8 (a-h,o-z)
6301       include 'DIMENSIONS'
6302       include 'COMMON.VAR'
6303       include 'COMMON.GEO'
6304       include 'COMMON.LOCAL'
6305       include 'COMMON.TORSION'
6306       include 'COMMON.INTERACT'
6307       include 'COMMON.DERIV'
6308       include 'COMMON.CHAIN'
6309       include 'COMMON.NAMES'
6310       include 'COMMON.IOUNITS'
6311       include 'COMMON.FFIELD'
6312       include 'COMMON.TORCNSTR'
6313       include 'COMMON.CONTROL'
6314       logical lprn
6315 C Set lprn=.true. for debugging
6316       lprn=.false.
6317 c      lprn=.true.
6318       etors=0.0D0
6319       do i=iphi_start,iphi_end
6320       etors_ii=0.0D0
6321         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6322      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6323         itori=itortyp(itype(i-2))
6324         itori1=itortyp(itype(i-1))
6325         phii=phi(i)
6326         gloci=0.0D0
6327 C Proline-Proline pair is a special case...
6328         if (itori.eq.3 .and. itori1.eq.3) then
6329           if (phii.gt.-dwapi3) then
6330             cosphi=dcos(3*phii)
6331             fac=1.0D0/(1.0D0-cosphi)
6332             etorsi=v1(1,3,3)*fac
6333             etorsi=etorsi+etorsi
6334             etors=etors+etorsi-v1(1,3,3)
6335             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6336             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6337           endif
6338           do j=1,3
6339             v1ij=v1(j+1,itori,itori1)
6340             v2ij=v2(j+1,itori,itori1)
6341             cosphi=dcos(j*phii)
6342             sinphi=dsin(j*phii)
6343             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6344             if (energy_dec) etors_ii=etors_ii+
6345      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6346             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6347           enddo
6348         else
6349           do j=1,nterm_old
6350             v1ij=v1(j,itori,itori1)
6351             v2ij=v2(j,itori,itori1)
6352             cosphi=dcos(j*phii)
6353             sinphi=dsin(j*phii)
6354             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6355             if (energy_dec) etors_ii=etors_ii+
6356      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6357             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6358           enddo
6359         endif
6360         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6361              'etor',i,etors_ii
6362         if (lprn)
6363      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6364      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6365      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6366         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6367 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6368       enddo
6369 ! 6/20/98 - dihedral angle constraints
6370       edihcnstr=0.0d0
6371       do i=1,ndih_constr
6372         itori=idih_constr(i)
6373         phii=phi(itori)
6374         difi=phii-phi0(i)
6375         if (difi.gt.drange(i)) then
6376           difi=difi-drange(i)
6377           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6378           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6379         else if (difi.lt.-drange(i)) then
6380           difi=difi+drange(i)
6381           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6382           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6383         endif
6384 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6385 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6386       enddo
6387 !      write (iout,*) 'edihcnstr',edihcnstr
6388       return
6389       end
6390 c------------------------------------------------------------------------------
6391       subroutine etor_d(etors_d)
6392       etors_d=0.0d0
6393       return
6394       end
6395 c----------------------------------------------------------------------------
6396 #else
6397       subroutine etor(etors,edihcnstr)
6398       implicit real*8 (a-h,o-z)
6399       include 'DIMENSIONS'
6400       include 'COMMON.VAR'
6401       include 'COMMON.GEO'
6402       include 'COMMON.LOCAL'
6403       include 'COMMON.TORSION'
6404       include 'COMMON.INTERACT'
6405       include 'COMMON.DERIV'
6406       include 'COMMON.CHAIN'
6407       include 'COMMON.NAMES'
6408       include 'COMMON.IOUNITS'
6409       include 'COMMON.FFIELD'
6410       include 'COMMON.TORCNSTR'
6411       include 'COMMON.CONTROL'
6412       logical lprn
6413 C Set lprn=.true. for debugging
6414       lprn=.false.
6415 c     lprn=.true.
6416       etors=0.0D0
6417       do i=iphi_start,iphi_end
6418 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6419 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6420 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6421 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6422         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6423      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6424 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6425 C For introducing the NH3+ and COO- group please check the etor_d for reference
6426 C and guidance
6427         etors_ii=0.0D0
6428          if (iabs(itype(i)).eq.20) then
6429          iblock=2
6430          else
6431          iblock=1
6432          endif
6433         itori=itortyp(itype(i-2))
6434         itori1=itortyp(itype(i-1))
6435         phii=phi(i)
6436         gloci=0.0D0
6437 C Regular cosine and sine terms
6438         do j=1,nterm(itori,itori1,iblock)
6439           v1ij=v1(j,itori,itori1,iblock)
6440           v2ij=v2(j,itori,itori1,iblock)
6441           cosphi=dcos(j*phii)
6442           sinphi=dsin(j*phii)
6443           etors=etors+v1ij*cosphi+v2ij*sinphi
6444           if (energy_dec) etors_ii=etors_ii+
6445      &                v1ij*cosphi+v2ij*sinphi
6446           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6447         enddo
6448 C Lorentz terms
6449 C                         v1
6450 C  E = SUM ----------------------------------- - v1
6451 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6452 C
6453         cosphi=dcos(0.5d0*phii)
6454         sinphi=dsin(0.5d0*phii)
6455         do j=1,nlor(itori,itori1,iblock)
6456           vl1ij=vlor1(j,itori,itori1)
6457           vl2ij=vlor2(j,itori,itori1)
6458           vl3ij=vlor3(j,itori,itori1)
6459           pom=vl2ij*cosphi+vl3ij*sinphi
6460           pom1=1.0d0/(pom*pom+1.0d0)
6461           etors=etors+vl1ij*pom1
6462           if (energy_dec) etors_ii=etors_ii+
6463      &                vl1ij*pom1
6464           pom=-pom*pom1*pom1
6465           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6466         enddo
6467 C Subtract the constant term
6468         etors=etors-v0(itori,itori1,iblock)
6469           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6470      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6471         if (lprn)
6472      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6473      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6474      &  (v1(j,itori,itori1,iblock),j=1,6),
6475      &  (v2(j,itori,itori1,iblock),j=1,6)
6476         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6477 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6478       enddo
6479 ! 6/20/98 - dihedral angle constraints
6480       edihcnstr=0.0d0
6481 c      do i=1,ndih_constr
6482       do i=idihconstr_start,idihconstr_end
6483         itori=idih_constr(i)
6484         phii=phi(itori)
6485         difi=pinorm(phii-phi0(i))
6486         if (difi.gt.drange(i)) then
6487           difi=difi-drange(i)
6488           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6489           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6490         else if (difi.lt.-drange(i)) then
6491           difi=difi+drange(i)
6492           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6493           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6494         else
6495           difi=0.0
6496         endif
6497 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6498 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6499 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6500       enddo
6501 cd       write (iout,*) 'edihcnstr',edihcnstr
6502       return
6503       end
6504 c----------------------------------------------------------------------------
6505       subroutine etor_d(etors_d)
6506 C 6/23/01 Compute double torsional energy
6507       implicit real*8 (a-h,o-z)
6508       include 'DIMENSIONS'
6509       include 'COMMON.VAR'
6510       include 'COMMON.GEO'
6511       include 'COMMON.LOCAL'
6512       include 'COMMON.TORSION'
6513       include 'COMMON.INTERACT'
6514       include 'COMMON.DERIV'
6515       include 'COMMON.CHAIN'
6516       include 'COMMON.NAMES'
6517       include 'COMMON.IOUNITS'
6518       include 'COMMON.FFIELD'
6519       include 'COMMON.TORCNSTR'
6520       logical lprn
6521 C Set lprn=.true. for debugging
6522       lprn=.false.
6523 c     lprn=.true.
6524       etors_d=0.0D0
6525 c      write(iout,*) "a tu??"
6526       do i=iphid_start,iphid_end
6527 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6528 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6529 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6530 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6531 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6532          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6533      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6534      &  (itype(i+1).eq.ntyp1)) cycle
6535 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6536         itori=itortyp(itype(i-2))
6537         itori1=itortyp(itype(i-1))
6538         itori2=itortyp(itype(i))
6539         phii=phi(i)
6540         phii1=phi(i+1)
6541         gloci1=0.0D0
6542         gloci2=0.0D0
6543         iblock=1
6544         if (iabs(itype(i+1)).eq.20) iblock=2
6545 C Iblock=2 Proline type
6546 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6547 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6548 C        if (itype(i+1).eq.ntyp1) iblock=3
6549 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6550 C IS or IS NOT need for this
6551 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6552 C        is (itype(i-3).eq.ntyp1) ntblock=2
6553 C        ntblock is N-terminal blocking group
6554
6555 C Regular cosine and sine terms
6556         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6557 C Example of changes for NH3+ blocking group
6558 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6559 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6560           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6561           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6562           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6563           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6564           cosphi1=dcos(j*phii)
6565           sinphi1=dsin(j*phii)
6566           cosphi2=dcos(j*phii1)
6567           sinphi2=dsin(j*phii1)
6568           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6569      &     v2cij*cosphi2+v2sij*sinphi2
6570           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6571           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6572         enddo
6573         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6574           do l=1,k-1
6575             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6576             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6577             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6578             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6579             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6580             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6581             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6582             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6583             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6584      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6585             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6586      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6587             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6588      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6589           enddo
6590         enddo
6591         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6592         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6593       enddo
6594       return
6595       end
6596 #endif
6597 c------------------------------------------------------------------------------
6598       subroutine eback_sc_corr(esccor)
6599 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6600 c        conformational states; temporarily implemented as differences
6601 c        between UNRES torsional potentials (dependent on three types of
6602 c        residues) and the torsional potentials dependent on all 20 types
6603 c        of residues computed from AM1  energy surfaces of terminally-blocked
6604 c        amino-acid residues.
6605       implicit real*8 (a-h,o-z)
6606       include 'DIMENSIONS'
6607       include 'COMMON.VAR'
6608       include 'COMMON.GEO'
6609       include 'COMMON.LOCAL'
6610       include 'COMMON.TORSION'
6611       include 'COMMON.SCCOR'
6612       include 'COMMON.INTERACT'
6613       include 'COMMON.DERIV'
6614       include 'COMMON.CHAIN'
6615       include 'COMMON.NAMES'
6616       include 'COMMON.IOUNITS'
6617       include 'COMMON.FFIELD'
6618       include 'COMMON.CONTROL'
6619       logical lprn
6620 C Set lprn=.true. for debugging
6621       lprn=.false.
6622 c      lprn=.true.
6623 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6624       esccor=0.0D0
6625       do i=itau_start,itau_end
6626         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6627         esccor_ii=0.0D0
6628         isccori=isccortyp(itype(i-2))
6629         isccori1=isccortyp(itype(i-1))
6630 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6631         phii=phi(i)
6632         do intertyp=1,3 !intertyp
6633 cc Added 09 May 2012 (Adasko)
6634 cc  Intertyp means interaction type of backbone mainchain correlation:
6635 c   1 = SC...Ca...Ca...Ca
6636 c   2 = Ca...Ca...Ca...SC
6637 c   3 = SC...Ca...Ca...SCi
6638         gloci=0.0D0
6639         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6640      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6641      &      (itype(i-1).eq.ntyp1)))
6642      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6643      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6644      &     .or.(itype(i).eq.ntyp1)))
6645      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6646      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6647      &      (itype(i-3).eq.ntyp1)))) cycle
6648         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6649         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6650      & cycle
6651        do j=1,nterm_sccor(isccori,isccori1)
6652           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6653           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6654           cosphi=dcos(j*tauangle(intertyp,i))
6655           sinphi=dsin(j*tauangle(intertyp,i))
6656           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6657           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6658         enddo
6659 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6660         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6661         if (lprn)
6662      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6663      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6664      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6665      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6666         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6667        enddo !intertyp
6668       enddo
6669
6670       return
6671       end
6672 c----------------------------------------------------------------------------
6673       subroutine multibody(ecorr)
6674 C This subroutine calculates multi-body contributions to energy following
6675 C the idea of Skolnick et al. If side chains I and J make a contact and
6676 C at the same time side chains I+1 and J+1 make a contact, an extra
6677 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6678       implicit real*8 (a-h,o-z)
6679       include 'DIMENSIONS'
6680       include 'COMMON.IOUNITS'
6681       include 'COMMON.DERIV'
6682       include 'COMMON.INTERACT'
6683       include 'COMMON.CONTACTS'
6684       double precision gx(3),gx1(3)
6685       logical lprn
6686
6687 C Set lprn=.true. for debugging
6688       lprn=.false.
6689
6690       if (lprn) then
6691         write (iout,'(a)') 'Contact function values:'
6692         do i=nnt,nct-2
6693           write (iout,'(i2,20(1x,i2,f10.5))')
6694      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6695         enddo
6696       endif
6697       ecorr=0.0D0
6698       do i=nnt,nct
6699         do j=1,3
6700           gradcorr(j,i)=0.0D0
6701           gradxorr(j,i)=0.0D0
6702         enddo
6703       enddo
6704       do i=nnt,nct-2
6705
6706         DO ISHIFT = 3,4
6707
6708         i1=i+ishift
6709         num_conti=num_cont(i)
6710         num_conti1=num_cont(i1)
6711         do jj=1,num_conti
6712           j=jcont(jj,i)
6713           do kk=1,num_conti1
6714             j1=jcont(kk,i1)
6715             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6716 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6717 cd   &                   ' ishift=',ishift
6718 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6719 C The system gains extra energy.
6720               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6721             endif   ! j1==j+-ishift
6722           enddo     ! kk
6723         enddo       ! jj
6724
6725         ENDDO ! ISHIFT
6726
6727       enddo         ! i
6728       return
6729       end
6730 c------------------------------------------------------------------------------
6731       double precision function esccorr(i,j,k,l,jj,kk)
6732       implicit real*8 (a-h,o-z)
6733       include 'DIMENSIONS'
6734       include 'COMMON.IOUNITS'
6735       include 'COMMON.DERIV'
6736       include 'COMMON.INTERACT'
6737       include 'COMMON.CONTACTS'
6738       double precision gx(3),gx1(3)
6739       logical lprn
6740       lprn=.false.
6741       eij=facont(jj,i)
6742       ekl=facont(kk,k)
6743 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6744 C Calculate the multi-body contribution to energy.
6745 C Calculate multi-body contributions to the gradient.
6746 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6747 cd   & k,l,(gacont(m,kk,k),m=1,3)
6748       do m=1,3
6749         gx(m) =ekl*gacont(m,jj,i)
6750         gx1(m)=eij*gacont(m,kk,k)
6751         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6752         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6753         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6754         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6755       enddo
6756       do m=i,j-1
6757         do ll=1,3
6758           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6759         enddo
6760       enddo
6761       do m=k,l-1
6762         do ll=1,3
6763           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6764         enddo
6765       enddo
6766       esccorr=-eij*ekl
6767       return
6768       end
6769 c------------------------------------------------------------------------------
6770       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6771 C This subroutine calculates multi-body contributions to hydrogen-bonding
6772       implicit real*8 (a-h,o-z)
6773       include 'DIMENSIONS'
6774       include 'COMMON.IOUNITS'
6775 #ifdef MPI
6776       include "mpif.h"
6777       parameter (max_cont=maxconts)
6778       parameter (max_dim=26)
6779       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6780       double precision zapas(max_dim,maxconts,max_fg_procs),
6781      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6782       common /przechowalnia/ zapas
6783       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6784      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6785 #endif
6786       include 'COMMON.SETUP'
6787       include 'COMMON.FFIELD'
6788       include 'COMMON.DERIV'
6789       include 'COMMON.INTERACT'
6790       include 'COMMON.CONTACTS'
6791       include 'COMMON.CONTROL'
6792       include 'COMMON.LOCAL'
6793       double precision gx(3),gx1(3),time00
6794       logical lprn,ldone
6795
6796 C Set lprn=.true. for debugging
6797       lprn=.false.
6798 #ifdef MPI
6799       n_corr=0
6800       n_corr1=0
6801       if (nfgtasks.le.1) goto 30
6802       if (lprn) then
6803         write (iout,'(a)') 'Contact function values before RECEIVE:'
6804         do i=nnt,nct-2
6805           write (iout,'(2i3,50(1x,i2,f5.2))')
6806      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6807      &    j=1,num_cont_hb(i))
6808         enddo
6809       endif
6810       call flush(iout)
6811       do i=1,ntask_cont_from
6812         ncont_recv(i)=0
6813       enddo
6814       do i=1,ntask_cont_to
6815         ncont_sent(i)=0
6816       enddo
6817 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6818 c     & ntask_cont_to
6819 C Make the list of contacts to send to send to other procesors
6820 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6821 c      call flush(iout)
6822       do i=iturn3_start,iturn3_end
6823 c        write (iout,*) "make contact list turn3",i," num_cont",
6824 c     &    num_cont_hb(i)
6825         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6826       enddo
6827       do i=iturn4_start,iturn4_end
6828 c        write (iout,*) "make contact list turn4",i," num_cont",
6829 c     &   num_cont_hb(i)
6830         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6831       enddo
6832       do ii=1,nat_sent
6833         i=iat_sent(ii)
6834 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6835 c     &    num_cont_hb(i)
6836         do j=1,num_cont_hb(i)
6837         do k=1,4
6838           jjc=jcont_hb(j,i)
6839           iproc=iint_sent_local(k,jjc,ii)
6840 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6841           if (iproc.gt.0) then
6842             ncont_sent(iproc)=ncont_sent(iproc)+1
6843             nn=ncont_sent(iproc)
6844             zapas(1,nn,iproc)=i
6845             zapas(2,nn,iproc)=jjc
6846             zapas(3,nn,iproc)=facont_hb(j,i)
6847             zapas(4,nn,iproc)=ees0p(j,i)
6848             zapas(5,nn,iproc)=ees0m(j,i)
6849             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6850             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6851             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6852             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6853             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6854             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6855             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6856             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6857             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6858             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6859             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6860             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6861             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6862             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6863             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6864             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6865             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6866             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6867             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6868             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6869             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6870           endif
6871         enddo
6872         enddo
6873       enddo
6874       if (lprn) then
6875       write (iout,*)
6876      &  "Numbers of contacts to be sent to other processors",
6877      &  (ncont_sent(i),i=1,ntask_cont_to)
6878       write (iout,*) "Contacts sent"
6879       do ii=1,ntask_cont_to
6880         nn=ncont_sent(ii)
6881         iproc=itask_cont_to(ii)
6882         write (iout,*) nn," contacts to processor",iproc,
6883      &   " of CONT_TO_COMM group"
6884         do i=1,nn
6885           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6886         enddo
6887       enddo
6888       call flush(iout)
6889       endif
6890       CorrelType=477
6891       CorrelID=fg_rank+1
6892       CorrelType1=478
6893       CorrelID1=nfgtasks+fg_rank+1
6894       ireq=0
6895 C Receive the numbers of needed contacts from other processors
6896       do ii=1,ntask_cont_from
6897         iproc=itask_cont_from(ii)
6898         ireq=ireq+1
6899         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6900      &    FG_COMM,req(ireq),IERR)
6901       enddo
6902 c      write (iout,*) "IRECV ended"
6903 c      call flush(iout)
6904 C Send the number of contacts needed by other processors
6905       do ii=1,ntask_cont_to
6906         iproc=itask_cont_to(ii)
6907         ireq=ireq+1
6908         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6909      &    FG_COMM,req(ireq),IERR)
6910       enddo
6911 c      write (iout,*) "ISEND ended"
6912 c      write (iout,*) "number of requests (nn)",ireq
6913       call flush(iout)
6914       if (ireq.gt.0)
6915      &  call MPI_Waitall(ireq,req,status_array,ierr)
6916 c      write (iout,*)
6917 c     &  "Numbers of contacts to be received from other processors",
6918 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6919 c      call flush(iout)
6920 C Receive contacts
6921       ireq=0
6922       do ii=1,ntask_cont_from
6923         iproc=itask_cont_from(ii)
6924         nn=ncont_recv(ii)
6925 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6926 c     &   " of CONT_TO_COMM group"
6927         call flush(iout)
6928         if (nn.gt.0) then
6929           ireq=ireq+1
6930           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6931      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6932 c          write (iout,*) "ireq,req",ireq,req(ireq)
6933         endif
6934       enddo
6935 C Send the contacts to processors that need them
6936       do ii=1,ntask_cont_to
6937         iproc=itask_cont_to(ii)
6938         nn=ncont_sent(ii)
6939 c        write (iout,*) nn," contacts to processor",iproc,
6940 c     &   " of CONT_TO_COMM group"
6941         if (nn.gt.0) then
6942           ireq=ireq+1
6943           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6944      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6945 c          write (iout,*) "ireq,req",ireq,req(ireq)
6946 c          do i=1,nn
6947 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6948 c          enddo
6949         endif
6950       enddo
6951 c      write (iout,*) "number of requests (contacts)",ireq
6952 c      write (iout,*) "req",(req(i),i=1,4)
6953 c      call flush(iout)
6954       if (ireq.gt.0)
6955      & call MPI_Waitall(ireq,req,status_array,ierr)
6956       do iii=1,ntask_cont_from
6957         iproc=itask_cont_from(iii)
6958         nn=ncont_recv(iii)
6959         if (lprn) then
6960         write (iout,*) "Received",nn," contacts from processor",iproc,
6961      &   " of CONT_FROM_COMM group"
6962         call flush(iout)
6963         do i=1,nn
6964           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6965         enddo
6966         call flush(iout)
6967         endif
6968         do i=1,nn
6969           ii=zapas_recv(1,i,iii)
6970 c Flag the received contacts to prevent double-counting
6971           jj=-zapas_recv(2,i,iii)
6972 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6973 c          call flush(iout)
6974           nnn=num_cont_hb(ii)+1
6975           num_cont_hb(ii)=nnn
6976           jcont_hb(nnn,ii)=jj
6977           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6978           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6979           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6980           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6981           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6982           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6983           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6984           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6985           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6986           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6987           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6988           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6989           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6990           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6991           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6992           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6993           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6994           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6995           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6996           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6997           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6998           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6999           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7000           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7001         enddo
7002       enddo
7003       call flush(iout)
7004       if (lprn) then
7005         write (iout,'(a)') 'Contact function values after receive:'
7006         do i=nnt,nct-2
7007           write (iout,'(2i3,50(1x,i3,f5.2))')
7008      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7009      &    j=1,num_cont_hb(i))
7010         enddo
7011         call flush(iout)
7012       endif
7013    30 continue
7014 #endif
7015       if (lprn) then
7016         write (iout,'(a)') 'Contact function values:'
7017         do i=nnt,nct-2
7018           write (iout,'(2i3,50(1x,i3,f5.2))')
7019      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7020      &    j=1,num_cont_hb(i))
7021         enddo
7022       endif
7023       ecorr=0.0D0
7024 C Remove the loop below after debugging !!!
7025       do i=nnt,nct
7026         do j=1,3
7027           gradcorr(j,i)=0.0D0
7028           gradxorr(j,i)=0.0D0
7029         enddo
7030       enddo
7031 C Calculate the local-electrostatic correlation terms
7032       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7033         i1=i+1
7034         num_conti=num_cont_hb(i)
7035         num_conti1=num_cont_hb(i+1)
7036         do jj=1,num_conti
7037           j=jcont_hb(jj,i)
7038           jp=iabs(j)
7039           do kk=1,num_conti1
7040             j1=jcont_hb(kk,i1)
7041             jp1=iabs(j1)
7042 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7043 c     &         ' jj=',jj,' kk=',kk
7044             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7045      &          .or. j.lt.0 .and. j1.gt.0) .and.
7046      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7047 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7048 C The system gains extra energy.
7049               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7050               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7051      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7052               n_corr=n_corr+1
7053             else if (j1.eq.j) then
7054 C Contacts I-J and I-(J+1) occur simultaneously.
7055 C The system loses extra energy.
7056 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7057             endif
7058           enddo ! kk
7059           do kk=1,num_conti
7060             j1=jcont_hb(kk,i)
7061 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7062 c    &         ' jj=',jj,' kk=',kk
7063             if (j1.eq.j+1) then
7064 C Contacts I-J and (I+1)-J occur simultaneously.
7065 C The system loses extra energy.
7066 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7067             endif ! j1==j+1
7068           enddo ! kk
7069         enddo ! jj
7070       enddo ! i
7071       return
7072       end
7073 c------------------------------------------------------------------------------
7074       subroutine add_hb_contact(ii,jj,itask)
7075       implicit real*8 (a-h,o-z)
7076       include "DIMENSIONS"
7077       include "COMMON.IOUNITS"
7078       integer max_cont
7079       integer max_dim
7080       parameter (max_cont=maxconts)
7081       parameter (max_dim=26)
7082       include "COMMON.CONTACTS"
7083       double precision zapas(max_dim,maxconts,max_fg_procs),
7084      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7085       common /przechowalnia/ zapas
7086       integer i,j,ii,jj,iproc,itask(4),nn
7087 c      write (iout,*) "itask",itask
7088       do i=1,2
7089         iproc=itask(i)
7090         if (iproc.gt.0) then
7091           do j=1,num_cont_hb(ii)
7092             jjc=jcont_hb(j,ii)
7093 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7094             if (jjc.eq.jj) then
7095               ncont_sent(iproc)=ncont_sent(iproc)+1
7096               nn=ncont_sent(iproc)
7097               zapas(1,nn,iproc)=ii
7098               zapas(2,nn,iproc)=jjc
7099               zapas(3,nn,iproc)=facont_hb(j,ii)
7100               zapas(4,nn,iproc)=ees0p(j,ii)
7101               zapas(5,nn,iproc)=ees0m(j,ii)
7102               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7103               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7104               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7105               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7106               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7107               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7108               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7109               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7110               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7111               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7112               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7113               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7114               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7115               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7116               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7117               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7118               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7119               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7120               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7121               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7122               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7123               exit
7124             endif
7125           enddo
7126         endif
7127       enddo
7128       return
7129       end
7130 c------------------------------------------------------------------------------
7131       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7132      &  n_corr1)
7133 C This subroutine calculates multi-body contributions to hydrogen-bonding
7134       implicit real*8 (a-h,o-z)
7135       include 'DIMENSIONS'
7136       include 'COMMON.IOUNITS'
7137 #ifdef MPI
7138       include "mpif.h"
7139       parameter (max_cont=maxconts)
7140       parameter (max_dim=70)
7141       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7142       double precision zapas(max_dim,maxconts,max_fg_procs),
7143      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7144       common /przechowalnia/ zapas
7145       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7146      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7147 #endif
7148       include 'COMMON.SETUP'
7149       include 'COMMON.FFIELD'
7150       include 'COMMON.DERIV'
7151       include 'COMMON.LOCAL'
7152       include 'COMMON.INTERACT'
7153       include 'COMMON.CONTACTS'
7154       include 'COMMON.CHAIN'
7155       include 'COMMON.CONTROL'
7156       double precision gx(3),gx1(3)
7157       integer num_cont_hb_old(maxres)
7158       logical lprn,ldone
7159       double precision eello4,eello5,eelo6,eello_turn6
7160       external eello4,eello5,eello6,eello_turn6
7161 C Set lprn=.true. for debugging
7162       lprn=.false.
7163       eturn6=0.0d0
7164 #ifdef MPI
7165       do i=1,nres
7166         num_cont_hb_old(i)=num_cont_hb(i)
7167       enddo
7168       n_corr=0
7169       n_corr1=0
7170       if (nfgtasks.le.1) goto 30
7171       if (lprn) then
7172         write (iout,'(a)') 'Contact function values before RECEIVE:'
7173         do i=nnt,nct-2
7174           write (iout,'(2i3,50(1x,i2,f5.2))')
7175      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7176      &    j=1,num_cont_hb(i))
7177         enddo
7178       endif
7179       call flush(iout)
7180       do i=1,ntask_cont_from
7181         ncont_recv(i)=0
7182       enddo
7183       do i=1,ntask_cont_to
7184         ncont_sent(i)=0
7185       enddo
7186 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7187 c     & ntask_cont_to
7188 C Make the list of contacts to send to send to other procesors
7189       do i=iturn3_start,iturn3_end
7190 c        write (iout,*) "make contact list turn3",i," num_cont",
7191 c     &    num_cont_hb(i)
7192         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7193       enddo
7194       do i=iturn4_start,iturn4_end
7195 c        write (iout,*) "make contact list turn4",i," num_cont",
7196 c     &   num_cont_hb(i)
7197         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7198       enddo
7199       do ii=1,nat_sent
7200         i=iat_sent(ii)
7201 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7202 c     &    num_cont_hb(i)
7203         do j=1,num_cont_hb(i)
7204         do k=1,4
7205           jjc=jcont_hb(j,i)
7206           iproc=iint_sent_local(k,jjc,ii)
7207 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7208           if (iproc.ne.0) then
7209             ncont_sent(iproc)=ncont_sent(iproc)+1
7210             nn=ncont_sent(iproc)
7211             zapas(1,nn,iproc)=i
7212             zapas(2,nn,iproc)=jjc
7213             zapas(3,nn,iproc)=d_cont(j,i)
7214             ind=3
7215             do kk=1,3
7216               ind=ind+1
7217               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7218             enddo
7219             do kk=1,2
7220               do ll=1,2
7221                 ind=ind+1
7222                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7223               enddo
7224             enddo
7225             do jj=1,5
7226               do kk=1,3
7227                 do ll=1,2
7228                   do mm=1,2
7229                     ind=ind+1
7230                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7231                   enddo
7232                 enddo
7233               enddo
7234             enddo
7235           endif
7236         enddo
7237         enddo
7238       enddo
7239       if (lprn) then
7240       write (iout,*)
7241      &  "Numbers of contacts to be sent to other processors",
7242      &  (ncont_sent(i),i=1,ntask_cont_to)
7243       write (iout,*) "Contacts sent"
7244       do ii=1,ntask_cont_to
7245         nn=ncont_sent(ii)
7246         iproc=itask_cont_to(ii)
7247         write (iout,*) nn," contacts to processor",iproc,
7248      &   " of CONT_TO_COMM group"
7249         do i=1,nn
7250           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7251         enddo
7252       enddo
7253       call flush(iout)
7254       endif
7255       CorrelType=477
7256       CorrelID=fg_rank+1
7257       CorrelType1=478
7258       CorrelID1=nfgtasks+fg_rank+1
7259       ireq=0
7260 C Receive the numbers of needed contacts from other processors
7261       do ii=1,ntask_cont_from
7262         iproc=itask_cont_from(ii)
7263         ireq=ireq+1
7264         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7265      &    FG_COMM,req(ireq),IERR)
7266       enddo
7267 c      write (iout,*) "IRECV ended"
7268 c      call flush(iout)
7269 C Send the number of contacts needed by other processors
7270       do ii=1,ntask_cont_to
7271         iproc=itask_cont_to(ii)
7272         ireq=ireq+1
7273         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7274      &    FG_COMM,req(ireq),IERR)
7275       enddo
7276 c      write (iout,*) "ISEND ended"
7277 c      write (iout,*) "number of requests (nn)",ireq
7278       call flush(iout)
7279       if (ireq.gt.0)
7280      &  call MPI_Waitall(ireq,req,status_array,ierr)
7281 c      write (iout,*)
7282 c     &  "Numbers of contacts to be received from other processors",
7283 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7284 c      call flush(iout)
7285 C Receive contacts
7286       ireq=0
7287       do ii=1,ntask_cont_from
7288         iproc=itask_cont_from(ii)
7289         nn=ncont_recv(ii)
7290 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7291 c     &   " of CONT_TO_COMM group"
7292         call flush(iout)
7293         if (nn.gt.0) then
7294           ireq=ireq+1
7295           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7296      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7297 c          write (iout,*) "ireq,req",ireq,req(ireq)
7298         endif
7299       enddo
7300 C Send the contacts to processors that need them
7301       do ii=1,ntask_cont_to
7302         iproc=itask_cont_to(ii)
7303         nn=ncont_sent(ii)
7304 c        write (iout,*) nn," contacts to processor",iproc,
7305 c     &   " of CONT_TO_COMM group"
7306         if (nn.gt.0) then
7307           ireq=ireq+1
7308           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7309      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7310 c          write (iout,*) "ireq,req",ireq,req(ireq)
7311 c          do i=1,nn
7312 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7313 c          enddo
7314         endif
7315       enddo
7316 c      write (iout,*) "number of requests (contacts)",ireq
7317 c      write (iout,*) "req",(req(i),i=1,4)
7318 c      call flush(iout)
7319       if (ireq.gt.0)
7320      & call MPI_Waitall(ireq,req,status_array,ierr)
7321       do iii=1,ntask_cont_from
7322         iproc=itask_cont_from(iii)
7323         nn=ncont_recv(iii)
7324         if (lprn) then
7325         write (iout,*) "Received",nn," contacts from processor",iproc,
7326      &   " of CONT_FROM_COMM group"
7327         call flush(iout)
7328         do i=1,nn
7329           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7330         enddo
7331         call flush(iout)
7332         endif
7333         do i=1,nn
7334           ii=zapas_recv(1,i,iii)
7335 c Flag the received contacts to prevent double-counting
7336           jj=-zapas_recv(2,i,iii)
7337 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7338 c          call flush(iout)
7339           nnn=num_cont_hb(ii)+1
7340           num_cont_hb(ii)=nnn
7341           jcont_hb(nnn,ii)=jj
7342           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7343           ind=3
7344           do kk=1,3
7345             ind=ind+1
7346             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7347           enddo
7348           do kk=1,2
7349             do ll=1,2
7350               ind=ind+1
7351               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7352             enddo
7353           enddo
7354           do jj=1,5
7355             do kk=1,3
7356               do ll=1,2
7357                 do mm=1,2
7358                   ind=ind+1
7359                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7360                 enddo
7361               enddo
7362             enddo
7363           enddo
7364         enddo
7365       enddo
7366       call flush(iout)
7367       if (lprn) then
7368         write (iout,'(a)') 'Contact function values after receive:'
7369         do i=nnt,nct-2
7370           write (iout,'(2i3,50(1x,i3,5f6.3))')
7371      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7372      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7373         enddo
7374         call flush(iout)
7375       endif
7376    30 continue
7377 #endif
7378       if (lprn) then
7379         write (iout,'(a)') 'Contact function values:'
7380         do i=nnt,nct-2
7381           write (iout,'(2i3,50(1x,i2,5f6.3))')
7382      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7383      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7384         enddo
7385       endif
7386       ecorr=0.0D0
7387       ecorr5=0.0d0
7388       ecorr6=0.0d0
7389 C Remove the loop below after debugging !!!
7390       do i=nnt,nct
7391         do j=1,3
7392           gradcorr(j,i)=0.0D0
7393           gradxorr(j,i)=0.0D0
7394         enddo
7395       enddo
7396 C Calculate the dipole-dipole interaction energies
7397       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7398       do i=iatel_s,iatel_e+1
7399         num_conti=num_cont_hb(i)
7400         do jj=1,num_conti
7401           j=jcont_hb(jj,i)
7402 #ifdef MOMENT
7403           call dipole(i,j,jj)
7404 #endif
7405         enddo
7406       enddo
7407       endif
7408 C Calculate the local-electrostatic correlation terms
7409 c                write (iout,*) "gradcorr5 in eello5 before loop"
7410 c                do iii=1,nres
7411 c                  write (iout,'(i5,3f10.5)')
7412 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7413 c                enddo
7414       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7415 c        write (iout,*) "corr loop i",i
7416         i1=i+1
7417         num_conti=num_cont_hb(i)
7418         num_conti1=num_cont_hb(i+1)
7419         do jj=1,num_conti
7420           j=jcont_hb(jj,i)
7421           jp=iabs(j)
7422           do kk=1,num_conti1
7423             j1=jcont_hb(kk,i1)
7424             jp1=iabs(j1)
7425 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7426 c     &         ' jj=',jj,' kk=',kk
7427 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7428             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7429      &          .or. j.lt.0 .and. j1.gt.0) .and.
7430      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7431 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7432 C The system gains extra energy.
7433               n_corr=n_corr+1
7434               sqd1=dsqrt(d_cont(jj,i))
7435               sqd2=dsqrt(d_cont(kk,i1))
7436               sred_geom = sqd1*sqd2
7437               IF (sred_geom.lt.cutoff_corr) THEN
7438                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7439      &            ekont,fprimcont)
7440 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7441 cd     &         ' jj=',jj,' kk=',kk
7442                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7443                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7444                 do l=1,3
7445                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7446                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7447                 enddo
7448                 n_corr1=n_corr1+1
7449 cd               write (iout,*) 'sred_geom=',sred_geom,
7450 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7451 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7452 cd               write (iout,*) "g_contij",g_contij
7453 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7454 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7455                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7456                 if (wcorr4.gt.0.0d0)
7457      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7458                   if (energy_dec.and.wcorr4.gt.0.0d0)
7459      1                 write (iout,'(a6,4i5,0pf7.3)')
7460      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7461 c                write (iout,*) "gradcorr5 before eello5"
7462 c                do iii=1,nres
7463 c                  write (iout,'(i5,3f10.5)')
7464 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7465 c                enddo
7466                 if (wcorr5.gt.0.0d0)
7467      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7468 c                write (iout,*) "gradcorr5 after eello5"
7469 c                do iii=1,nres
7470 c                  write (iout,'(i5,3f10.5)')
7471 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7472 c                enddo
7473                   if (energy_dec.and.wcorr5.gt.0.0d0)
7474      1                 write (iout,'(a6,4i5,0pf7.3)')
7475      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7476 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7477 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7478                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7479      &               .or. wturn6.eq.0.0d0))then
7480 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7481                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7482                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7483      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7484 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7485 cd     &            'ecorr6=',ecorr6
7486 cd                write (iout,'(4e15.5)') sred_geom,
7487 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7488 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7489 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7490                 else if (wturn6.gt.0.0d0
7491      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7492 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7493                   eturn6=eturn6+eello_turn6(i,jj,kk)
7494                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7495      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7496 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7497                 endif
7498               ENDIF
7499 1111          continue
7500             endif
7501           enddo ! kk
7502         enddo ! jj
7503       enddo ! i
7504       do i=1,nres
7505         num_cont_hb(i)=num_cont_hb_old(i)
7506       enddo
7507 c                write (iout,*) "gradcorr5 in eello5"
7508 c                do iii=1,nres
7509 c                  write (iout,'(i5,3f10.5)')
7510 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7511 c                enddo
7512       return
7513       end
7514 c------------------------------------------------------------------------------
7515       subroutine add_hb_contact_eello(ii,jj,itask)
7516       implicit real*8 (a-h,o-z)
7517       include "DIMENSIONS"
7518       include "COMMON.IOUNITS"
7519       integer max_cont
7520       integer max_dim
7521       parameter (max_cont=maxconts)
7522       parameter (max_dim=70)
7523       include "COMMON.CONTACTS"
7524       double precision zapas(max_dim,maxconts,max_fg_procs),
7525      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7526       common /przechowalnia/ zapas
7527       integer i,j,ii,jj,iproc,itask(4),nn
7528 c      write (iout,*) "itask",itask
7529       do i=1,2
7530         iproc=itask(i)
7531         if (iproc.gt.0) then
7532           do j=1,num_cont_hb(ii)
7533             jjc=jcont_hb(j,ii)
7534 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7535             if (jjc.eq.jj) then
7536               ncont_sent(iproc)=ncont_sent(iproc)+1
7537               nn=ncont_sent(iproc)
7538               zapas(1,nn,iproc)=ii
7539               zapas(2,nn,iproc)=jjc
7540               zapas(3,nn,iproc)=d_cont(j,ii)
7541               ind=3
7542               do kk=1,3
7543                 ind=ind+1
7544                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7545               enddo
7546               do kk=1,2
7547                 do ll=1,2
7548                   ind=ind+1
7549                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7550                 enddo
7551               enddo
7552               do jj=1,5
7553                 do kk=1,3
7554                   do ll=1,2
7555                     do mm=1,2
7556                       ind=ind+1
7557                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7558                     enddo
7559                   enddo
7560                 enddo
7561               enddo
7562               exit
7563             endif
7564           enddo
7565         endif
7566       enddo
7567       return
7568       end
7569 c------------------------------------------------------------------------------
7570       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7571       implicit real*8 (a-h,o-z)
7572       include 'DIMENSIONS'
7573       include 'COMMON.IOUNITS'
7574       include 'COMMON.DERIV'
7575       include 'COMMON.INTERACT'
7576       include 'COMMON.CONTACTS'
7577       double precision gx(3),gx1(3)
7578       logical lprn
7579       lprn=.false.
7580       eij=facont_hb(jj,i)
7581       ekl=facont_hb(kk,k)
7582       ees0pij=ees0p(jj,i)
7583       ees0pkl=ees0p(kk,k)
7584       ees0mij=ees0m(jj,i)
7585       ees0mkl=ees0m(kk,k)
7586       ekont=eij*ekl
7587       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7588 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7589 C Following 4 lines for diagnostics.
7590 cd    ees0pkl=0.0D0
7591 cd    ees0pij=1.0D0
7592 cd    ees0mkl=0.0D0
7593 cd    ees0mij=1.0D0
7594 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7595 c     & 'Contacts ',i,j,
7596 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7597 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7598 c     & 'gradcorr_long'
7599 C Calculate the multi-body contribution to energy.
7600 c      ecorr=ecorr+ekont*ees
7601 C Calculate multi-body contributions to the gradient.
7602       coeffpees0pij=coeffp*ees0pij
7603       coeffmees0mij=coeffm*ees0mij
7604       coeffpees0pkl=coeffp*ees0pkl
7605       coeffmees0mkl=coeffm*ees0mkl
7606       do ll=1,3
7607 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7608         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7609      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7610      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7611         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7612      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7613      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7614 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7615         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7616      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7617      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7618         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7619      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7620      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7621         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7622      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7623      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7624         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7625         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7626         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7627      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7628      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7629         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7630         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7631 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7632       enddo
7633 c      write (iout,*)
7634 cgrad      do m=i+1,j-1
7635 cgrad        do ll=1,3
7636 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7637 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7638 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7639 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7640 cgrad        enddo
7641 cgrad      enddo
7642 cgrad      do m=k+1,l-1
7643 cgrad        do ll=1,3
7644 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7645 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7646 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7647 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7648 cgrad        enddo
7649 cgrad      enddo
7650 c      write (iout,*) "ehbcorr",ekont*ees
7651       ehbcorr=ekont*ees
7652       return
7653       end
7654 #ifdef MOMENT
7655 C---------------------------------------------------------------------------
7656       subroutine dipole(i,j,jj)
7657       implicit real*8 (a-h,o-z)
7658       include 'DIMENSIONS'
7659       include 'COMMON.IOUNITS'
7660       include 'COMMON.CHAIN'
7661       include 'COMMON.FFIELD'
7662       include 'COMMON.DERIV'
7663       include 'COMMON.INTERACT'
7664       include 'COMMON.CONTACTS'
7665       include 'COMMON.TORSION'
7666       include 'COMMON.VAR'
7667       include 'COMMON.GEO'
7668       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7669      &  auxmat(2,2)
7670       iti1 = itortyp(itype(i+1))
7671       if (j.lt.nres-1) then
7672         itj1 = itortyp(itype(j+1))
7673       else
7674         itj1=ntortyp
7675       endif
7676       do iii=1,2
7677         dipi(iii,1)=Ub2(iii,i)
7678         dipderi(iii)=Ub2der(iii,i)
7679         dipi(iii,2)=b1(iii,i+1)
7680         dipj(iii,1)=Ub2(iii,j)
7681         dipderj(iii)=Ub2der(iii,j)
7682         dipj(iii,2)=b1(iii,j+1)
7683       enddo
7684       kkk=0
7685       do iii=1,2
7686         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7687         do jjj=1,2
7688           kkk=kkk+1
7689           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7690         enddo
7691       enddo
7692       do kkk=1,5
7693         do lll=1,3
7694           mmm=0
7695           do iii=1,2
7696             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7697      &        auxvec(1))
7698             do jjj=1,2
7699               mmm=mmm+1
7700               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7701             enddo
7702           enddo
7703         enddo
7704       enddo
7705       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7706       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7707       do iii=1,2
7708         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7709       enddo
7710       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7711       do iii=1,2
7712         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7713       enddo
7714       return
7715       end
7716 #endif
7717 C---------------------------------------------------------------------------
7718       subroutine calc_eello(i,j,k,l,jj,kk)
7719 C
7720 C This subroutine computes matrices and vectors needed to calculate
7721 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7722 C
7723       implicit real*8 (a-h,o-z)
7724       include 'DIMENSIONS'
7725       include 'COMMON.IOUNITS'
7726       include 'COMMON.CHAIN'
7727       include 'COMMON.DERIV'
7728       include 'COMMON.INTERACT'
7729       include 'COMMON.CONTACTS'
7730       include 'COMMON.TORSION'
7731       include 'COMMON.VAR'
7732       include 'COMMON.GEO'
7733       include 'COMMON.FFIELD'
7734       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7735      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7736       logical lprn
7737       common /kutas/ lprn
7738 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7739 cd     & ' jj=',jj,' kk=',kk
7740 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7741 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7742 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7743       do iii=1,2
7744         do jjj=1,2
7745           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7746           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7747         enddo
7748       enddo
7749       call transpose2(aa1(1,1),aa1t(1,1))
7750       call transpose2(aa2(1,1),aa2t(1,1))
7751       do kkk=1,5
7752         do lll=1,3
7753           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7754      &      aa1tder(1,1,lll,kkk))
7755           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7756      &      aa2tder(1,1,lll,kkk))
7757         enddo
7758       enddo
7759       if (l.eq.j+1) then
7760 C parallel orientation of the two CA-CA-CA frames.
7761         if (i.gt.1) then
7762           iti=itortyp(itype(i))
7763         else
7764           iti=ntortyp
7765         endif
7766         itk1=itortyp(itype(k+1))
7767         itj=itortyp(itype(j))
7768         if (l.lt.nres-1) then
7769           itl1=itortyp(itype(l+1))
7770         else
7771           itl1=ntortyp
7772         endif
7773 C A1 kernel(j+1) A2T
7774 cd        do iii=1,2
7775 cd          write (iout,'(3f10.5,5x,3f10.5)')
7776 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7777 cd        enddo
7778         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7779      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7780      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7781 C Following matrices are needed only for 6-th order cumulants
7782         IF (wcorr6.gt.0.0d0) THEN
7783         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7784      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7785      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7786         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7787      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7788      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7789      &   ADtEAderx(1,1,1,1,1,1))
7790         lprn=.false.
7791         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7792      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7793      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7794      &   ADtEA1derx(1,1,1,1,1,1))
7795         ENDIF
7796 C End 6-th order cumulants
7797 cd        lprn=.false.
7798 cd        if (lprn) then
7799 cd        write (2,*) 'In calc_eello6'
7800 cd        do iii=1,2
7801 cd          write (2,*) 'iii=',iii
7802 cd          do kkk=1,5
7803 cd            write (2,*) 'kkk=',kkk
7804 cd            do jjj=1,2
7805 cd              write (2,'(3(2f10.5),5x)')
7806 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7807 cd            enddo
7808 cd          enddo
7809 cd        enddo
7810 cd        endif
7811         call transpose2(EUgder(1,1,k),auxmat(1,1))
7812         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7813         call transpose2(EUg(1,1,k),auxmat(1,1))
7814         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7815         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7816         do iii=1,2
7817           do kkk=1,5
7818             do lll=1,3
7819               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7820      &          EAEAderx(1,1,lll,kkk,iii,1))
7821             enddo
7822           enddo
7823         enddo
7824 C A1T kernel(i+1) A2
7825         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7826      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7827      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7828 C Following matrices are needed only for 6-th order cumulants
7829         IF (wcorr6.gt.0.0d0) THEN
7830         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7831      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7832      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7833         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7834      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7835      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7836      &   ADtEAderx(1,1,1,1,1,2))
7837         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7838      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7839      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7840      &   ADtEA1derx(1,1,1,1,1,2))
7841         ENDIF
7842 C End 6-th order cumulants
7843         call transpose2(EUgder(1,1,l),auxmat(1,1))
7844         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7845         call transpose2(EUg(1,1,l),auxmat(1,1))
7846         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7847         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7848         do iii=1,2
7849           do kkk=1,5
7850             do lll=1,3
7851               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7852      &          EAEAderx(1,1,lll,kkk,iii,2))
7853             enddo
7854           enddo
7855         enddo
7856 C AEAb1 and AEAb2
7857 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7858 C They are needed only when the fifth- or the sixth-order cumulants are
7859 C indluded.
7860         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7861         call transpose2(AEA(1,1,1),auxmat(1,1))
7862         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7863         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7864         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7865         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7866         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7867         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7868         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7869         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7870         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7871         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7872         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7873         call transpose2(AEA(1,1,2),auxmat(1,1))
7874         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7875         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7876         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7877         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7878         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7879         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7880         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7881         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7882         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7883         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7884         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7885 C Calculate the Cartesian derivatives of the vectors.
7886         do iii=1,2
7887           do kkk=1,5
7888             do lll=1,3
7889               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7890               call matvec2(auxmat(1,1),b1(1,i),
7891      &          AEAb1derx(1,lll,kkk,iii,1,1))
7892               call matvec2(auxmat(1,1),Ub2(1,i),
7893      &          AEAb2derx(1,lll,kkk,iii,1,1))
7894               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7895      &          AEAb1derx(1,lll,kkk,iii,2,1))
7896               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7897      &          AEAb2derx(1,lll,kkk,iii,2,1))
7898               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7899               call matvec2(auxmat(1,1),b1(1,j),
7900      &          AEAb1derx(1,lll,kkk,iii,1,2))
7901               call matvec2(auxmat(1,1),Ub2(1,j),
7902      &          AEAb2derx(1,lll,kkk,iii,1,2))
7903               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7904      &          AEAb1derx(1,lll,kkk,iii,2,2))
7905               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7906      &          AEAb2derx(1,lll,kkk,iii,2,2))
7907             enddo
7908           enddo
7909         enddo
7910         ENDIF
7911 C End vectors
7912       else
7913 C Antiparallel orientation of the two CA-CA-CA frames.
7914         if (i.gt.1) then
7915           iti=itortyp(itype(i))
7916         else
7917           iti=ntortyp
7918         endif
7919         itk1=itortyp(itype(k+1))
7920         itl=itortyp(itype(l))
7921         itj=itortyp(itype(j))
7922         if (j.lt.nres-1) then
7923           itj1=itortyp(itype(j+1))
7924         else
7925           itj1=ntortyp
7926         endif
7927 C A2 kernel(j-1)T A1T
7928         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7929      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7930      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7931 C Following matrices are needed only for 6-th order cumulants
7932         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7933      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7934         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7935      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7936      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7937         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7938      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7939      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7940      &   ADtEAderx(1,1,1,1,1,1))
7941         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7942      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7943      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7944      &   ADtEA1derx(1,1,1,1,1,1))
7945         ENDIF
7946 C End 6-th order cumulants
7947         call transpose2(EUgder(1,1,k),auxmat(1,1))
7948         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7949         call transpose2(EUg(1,1,k),auxmat(1,1))
7950         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7951         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7952         do iii=1,2
7953           do kkk=1,5
7954             do lll=1,3
7955               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7956      &          EAEAderx(1,1,lll,kkk,iii,1))
7957             enddo
7958           enddo
7959         enddo
7960 C A2T kernel(i+1)T A1
7961         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7962      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7963      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7964 C Following matrices are needed only for 6-th order cumulants
7965         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7966      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7967         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7968      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7969      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7970         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7971      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7972      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7973      &   ADtEAderx(1,1,1,1,1,2))
7974         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7975      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7976      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7977      &   ADtEA1derx(1,1,1,1,1,2))
7978         ENDIF
7979 C End 6-th order cumulants
7980         call transpose2(EUgder(1,1,j),auxmat(1,1))
7981         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7982         call transpose2(EUg(1,1,j),auxmat(1,1))
7983         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7984         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7985         do iii=1,2
7986           do kkk=1,5
7987             do lll=1,3
7988               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7989      &          EAEAderx(1,1,lll,kkk,iii,2))
7990             enddo
7991           enddo
7992         enddo
7993 C AEAb1 and AEAb2
7994 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7995 C They are needed only when the fifth- or the sixth-order cumulants are
7996 C indluded.
7997         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7998      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7999         call transpose2(AEA(1,1,1),auxmat(1,1))
8000         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8001         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8002         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8003         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8004         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8005         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8006         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8007         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8008         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8009         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8010         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8011         call transpose2(AEA(1,1,2),auxmat(1,1))
8012         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8013         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8014         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8015         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8016         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8017         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8018         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8019         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8020         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8021         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8022         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8023 C Calculate the Cartesian derivatives of the vectors.
8024         do iii=1,2
8025           do kkk=1,5
8026             do lll=1,3
8027               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8028               call matvec2(auxmat(1,1),b1(1,i),
8029      &          AEAb1derx(1,lll,kkk,iii,1,1))
8030               call matvec2(auxmat(1,1),Ub2(1,i),
8031      &          AEAb2derx(1,lll,kkk,iii,1,1))
8032               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8033      &          AEAb1derx(1,lll,kkk,iii,2,1))
8034               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8035      &          AEAb2derx(1,lll,kkk,iii,2,1))
8036               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8037               call matvec2(auxmat(1,1),b1(1,l),
8038      &          AEAb1derx(1,lll,kkk,iii,1,2))
8039               call matvec2(auxmat(1,1),Ub2(1,l),
8040      &          AEAb2derx(1,lll,kkk,iii,1,2))
8041               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8042      &          AEAb1derx(1,lll,kkk,iii,2,2))
8043               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8044      &          AEAb2derx(1,lll,kkk,iii,2,2))
8045             enddo
8046           enddo
8047         enddo
8048         ENDIF
8049 C End vectors
8050       endif
8051       return
8052       end
8053 C---------------------------------------------------------------------------
8054       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8055      &  KK,KKderg,AKA,AKAderg,AKAderx)
8056       implicit none
8057       integer nderg
8058       logical transp
8059       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8060      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8061      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8062       integer iii,kkk,lll
8063       integer jjj,mmm
8064       logical lprn
8065       common /kutas/ lprn
8066       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8067       do iii=1,nderg
8068         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8069      &    AKAderg(1,1,iii))
8070       enddo
8071 cd      if (lprn) write (2,*) 'In kernel'
8072       do kkk=1,5
8073 cd        if (lprn) write (2,*) 'kkk=',kkk
8074         do lll=1,3
8075           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8076      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8077 cd          if (lprn) then
8078 cd            write (2,*) 'lll=',lll
8079 cd            write (2,*) 'iii=1'
8080 cd            do jjj=1,2
8081 cd              write (2,'(3(2f10.5),5x)')
8082 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8083 cd            enddo
8084 cd          endif
8085           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8086      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8087 cd          if (lprn) then
8088 cd            write (2,*) 'lll=',lll
8089 cd            write (2,*) 'iii=2'
8090 cd            do jjj=1,2
8091 cd              write (2,'(3(2f10.5),5x)')
8092 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8093 cd            enddo
8094 cd          endif
8095         enddo
8096       enddo
8097       return
8098       end
8099 C---------------------------------------------------------------------------
8100       double precision function eello4(i,j,k,l,jj,kk)
8101       implicit real*8 (a-h,o-z)
8102       include 'DIMENSIONS'
8103       include 'COMMON.IOUNITS'
8104       include 'COMMON.CHAIN'
8105       include 'COMMON.DERIV'
8106       include 'COMMON.INTERACT'
8107       include 'COMMON.CONTACTS'
8108       include 'COMMON.TORSION'
8109       include 'COMMON.VAR'
8110       include 'COMMON.GEO'
8111       double precision pizda(2,2),ggg1(3),ggg2(3)
8112 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8113 cd        eello4=0.0d0
8114 cd        return
8115 cd      endif
8116 cd      print *,'eello4:',i,j,k,l,jj,kk
8117 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8118 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8119 cold      eij=facont_hb(jj,i)
8120 cold      ekl=facont_hb(kk,k)
8121 cold      ekont=eij*ekl
8122       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8123 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8124       gcorr_loc(k-1)=gcorr_loc(k-1)
8125      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8126       if (l.eq.j+1) then
8127         gcorr_loc(l-1)=gcorr_loc(l-1)
8128      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8129       else
8130         gcorr_loc(j-1)=gcorr_loc(j-1)
8131      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8132       endif
8133       do iii=1,2
8134         do kkk=1,5
8135           do lll=1,3
8136             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8137      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8138 cd            derx(lll,kkk,iii)=0.0d0
8139           enddo
8140         enddo
8141       enddo
8142 cd      gcorr_loc(l-1)=0.0d0
8143 cd      gcorr_loc(j-1)=0.0d0
8144 cd      gcorr_loc(k-1)=0.0d0
8145 cd      eel4=1.0d0
8146 cd      write (iout,*)'Contacts have occurred for peptide groups',
8147 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8148 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8149       if (j.lt.nres-1) then
8150         j1=j+1
8151         j2=j-1
8152       else
8153         j1=j-1
8154         j2=j-2
8155       endif
8156       if (l.lt.nres-1) then
8157         l1=l+1
8158         l2=l-1
8159       else
8160         l1=l-1
8161         l2=l-2
8162       endif
8163       do ll=1,3
8164 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8165 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8166         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8167         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8168 cgrad        ghalf=0.5d0*ggg1(ll)
8169         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8170         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8171         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8172         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8173         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8174         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8175 cgrad        ghalf=0.5d0*ggg2(ll)
8176         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8177         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8178         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8179         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8180         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8181         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8182       enddo
8183 cgrad      do m=i+1,j-1
8184 cgrad        do ll=1,3
8185 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8186 cgrad        enddo
8187 cgrad      enddo
8188 cgrad      do m=k+1,l-1
8189 cgrad        do ll=1,3
8190 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8191 cgrad        enddo
8192 cgrad      enddo
8193 cgrad      do m=i+2,j2
8194 cgrad        do ll=1,3
8195 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8196 cgrad        enddo
8197 cgrad      enddo
8198 cgrad      do m=k+2,l2
8199 cgrad        do ll=1,3
8200 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8201 cgrad        enddo
8202 cgrad      enddo
8203 cd      do iii=1,nres-3
8204 cd        write (2,*) iii,gcorr_loc(iii)
8205 cd      enddo
8206       eello4=ekont*eel4
8207 cd      write (2,*) 'ekont',ekont
8208 cd      write (iout,*) 'eello4',ekont*eel4
8209       return
8210       end
8211 C---------------------------------------------------------------------------
8212       double precision function eello5(i,j,k,l,jj,kk)
8213       implicit real*8 (a-h,o-z)
8214       include 'DIMENSIONS'
8215       include 'COMMON.IOUNITS'
8216       include 'COMMON.CHAIN'
8217       include 'COMMON.DERIV'
8218       include 'COMMON.INTERACT'
8219       include 'COMMON.CONTACTS'
8220       include 'COMMON.TORSION'
8221       include 'COMMON.VAR'
8222       include 'COMMON.GEO'
8223       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8224       double precision ggg1(3),ggg2(3)
8225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8226 C                                                                              C
8227 C                            Parallel chains                                   C
8228 C                                                                              C
8229 C          o             o                   o             o                   C
8230 C         /l\           / \             \   / \           / \   /              C
8231 C        /   \         /   \             \ /   \         /   \ /               C
8232 C       j| o |l1       | o |              o| o |         | o |o                C
8233 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8234 C      \i/   \         /   \ /             /   \         /   \                 C
8235 C       o    k1             o                                                  C
8236 C         (I)          (II)                (III)          (IV)                 C
8237 C                                                                              C
8238 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8239 C                                                                              C
8240 C                            Antiparallel chains                               C
8241 C                                                                              C
8242 C          o             o                   o             o                   C
8243 C         /j\           / \             \   / \           / \   /              C
8244 C        /   \         /   \             \ /   \         /   \ /               C
8245 C      j1| o |l        | o |              o| o |         | o |o                C
8246 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8247 C      \i/   \         /   \ /             /   \         /   \                 C
8248 C       o     k1            o                                                  C
8249 C         (I)          (II)                (III)          (IV)                 C
8250 C                                                                              C
8251 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8252 C                                                                              C
8253 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8254 C                                                                              C
8255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8256 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8257 cd        eello5=0.0d0
8258 cd        return
8259 cd      endif
8260 cd      write (iout,*)
8261 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8262 cd     &   ' and',k,l
8263       itk=itortyp(itype(k))
8264       itl=itortyp(itype(l))
8265       itj=itortyp(itype(j))
8266       eello5_1=0.0d0
8267       eello5_2=0.0d0
8268       eello5_3=0.0d0
8269       eello5_4=0.0d0
8270 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8271 cd     &   eel5_3_num,eel5_4_num)
8272       do iii=1,2
8273         do kkk=1,5
8274           do lll=1,3
8275             derx(lll,kkk,iii)=0.0d0
8276           enddo
8277         enddo
8278       enddo
8279 cd      eij=facont_hb(jj,i)
8280 cd      ekl=facont_hb(kk,k)
8281 cd      ekont=eij*ekl
8282 cd      write (iout,*)'Contacts have occurred for peptide groups',
8283 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8284 cd      goto 1111
8285 C Contribution from the graph I.
8286 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8287 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8288       call transpose2(EUg(1,1,k),auxmat(1,1))
8289       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8290       vv(1)=pizda(1,1)-pizda(2,2)
8291       vv(2)=pizda(1,2)+pizda(2,1)
8292       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8293      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8294 C Explicit gradient in virtual-dihedral angles.
8295       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8296      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8297      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8298       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8299       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8300       vv(1)=pizda(1,1)-pizda(2,2)
8301       vv(2)=pizda(1,2)+pizda(2,1)
8302       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8303      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8304      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8305       call matmat2(AEAderg(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       if (l.eq.j+1) then
8309         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8310      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8311      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8312       else
8313         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8314      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8315      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8316       endif
8317 C Cartesian gradient
8318       do iii=1,2
8319         do kkk=1,5
8320           do lll=1,3
8321             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8322      &        pizda(1,1))
8323             vv(1)=pizda(1,1)-pizda(2,2)
8324             vv(2)=pizda(1,2)+pizda(2,1)
8325             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8326      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8327      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8328           enddo
8329         enddo
8330       enddo
8331 c      goto 1112
8332 c1111  continue
8333 C Contribution from graph II
8334       call transpose2(EE(1,1,itk),auxmat(1,1))
8335       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8336       vv(1)=pizda(1,1)+pizda(2,2)
8337       vv(2)=pizda(2,1)-pizda(1,2)
8338       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8339      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8340 C Explicit gradient in virtual-dihedral angles.
8341       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8342      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8343       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8344       vv(1)=pizda(1,1)+pizda(2,2)
8345       vv(2)=pizda(2,1)-pizda(1,2)
8346       if (l.eq.j+1) then
8347         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8348      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8349      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8350       else
8351         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8352      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8353      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8354       endif
8355 C Cartesian gradient
8356       do iii=1,2
8357         do kkk=1,5
8358           do lll=1,3
8359             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8360      &        pizda(1,1))
8361             vv(1)=pizda(1,1)+pizda(2,2)
8362             vv(2)=pizda(2,1)-pizda(1,2)
8363             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8364      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8365      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8366           enddo
8367         enddo
8368       enddo
8369 cd      goto 1112
8370 cd1111  continue
8371       if (l.eq.j+1) then
8372 cd        goto 1110
8373 C Parallel orientation
8374 C Contribution from graph III
8375         call transpose2(EUg(1,1,l),auxmat(1,1))
8376         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8377         vv(1)=pizda(1,1)-pizda(2,2)
8378         vv(2)=pizda(1,2)+pizda(2,1)
8379         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8380      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8381 C Explicit gradient in virtual-dihedral angles.
8382         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8383      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8384      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8385         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8386         vv(1)=pizda(1,1)-pizda(2,2)
8387         vv(2)=pizda(1,2)+pizda(2,1)
8388         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8389      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8390      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8391         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8392         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8393         vv(1)=pizda(1,1)-pizda(2,2)
8394         vv(2)=pizda(1,2)+pizda(2,1)
8395         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8396      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8397      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8398 C Cartesian gradient
8399         do iii=1,2
8400           do kkk=1,5
8401             do lll=1,3
8402               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8403      &          pizda(1,1))
8404               vv(1)=pizda(1,1)-pizda(2,2)
8405               vv(2)=pizda(1,2)+pizda(2,1)
8406               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8407      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8408      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8409             enddo
8410           enddo
8411         enddo
8412 cd        goto 1112
8413 C Contribution from graph IV
8414 cd1110    continue
8415         call transpose2(EE(1,1,itl),auxmat(1,1))
8416         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8417         vv(1)=pizda(1,1)+pizda(2,2)
8418         vv(2)=pizda(2,1)-pizda(1,2)
8419         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8420      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8421 C Explicit gradient in virtual-dihedral angles.
8422         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8423      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8424         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8425         vv(1)=pizda(1,1)+pizda(2,2)
8426         vv(2)=pizda(2,1)-pizda(1,2)
8427         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8428      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8429      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8430 C Cartesian gradient
8431         do iii=1,2
8432           do kkk=1,5
8433             do lll=1,3
8434               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8435      &          pizda(1,1))
8436               vv(1)=pizda(1,1)+pizda(2,2)
8437               vv(2)=pizda(2,1)-pizda(1,2)
8438               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8439      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8440      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8441             enddo
8442           enddo
8443         enddo
8444       else
8445 C Antiparallel orientation
8446 C Contribution from graph III
8447 c        goto 1110
8448         call transpose2(EUg(1,1,j),auxmat(1,1))
8449         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8450         vv(1)=pizda(1,1)-pizda(2,2)
8451         vv(2)=pizda(1,2)+pizda(2,1)
8452         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8454 C Explicit gradient in virtual-dihedral angles.
8455         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8456      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8457      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8458         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8459         vv(1)=pizda(1,1)-pizda(2,2)
8460         vv(2)=pizda(1,2)+pizda(2,1)
8461         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8462      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8463      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8464         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8465         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8466         vv(1)=pizda(1,1)-pizda(2,2)
8467         vv(2)=pizda(1,2)+pizda(2,1)
8468         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8469      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8470      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8471 C Cartesian gradient
8472         do iii=1,2
8473           do kkk=1,5
8474             do lll=1,3
8475               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8476      &          pizda(1,1))
8477               vv(1)=pizda(1,1)-pizda(2,2)
8478               vv(2)=pizda(1,2)+pizda(2,1)
8479               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8480      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8481      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8482             enddo
8483           enddo
8484         enddo
8485 cd        goto 1112
8486 C Contribution from graph IV
8487 1110    continue
8488         call transpose2(EE(1,1,itj),auxmat(1,1))
8489         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8490         vv(1)=pizda(1,1)+pizda(2,2)
8491         vv(2)=pizda(2,1)-pizda(1,2)
8492         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8493      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8494 C Explicit gradient in virtual-dihedral angles.
8495         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8496      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8497         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8498         vv(1)=pizda(1,1)+pizda(2,2)
8499         vv(2)=pizda(2,1)-pizda(1,2)
8500         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8501      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8502      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8503 C Cartesian gradient
8504         do iii=1,2
8505           do kkk=1,5
8506             do lll=1,3
8507               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8508      &          pizda(1,1))
8509               vv(1)=pizda(1,1)+pizda(2,2)
8510               vv(2)=pizda(2,1)-pizda(1,2)
8511               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8512      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8513      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8514             enddo
8515           enddo
8516         enddo
8517       endif
8518 1112  continue
8519       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8520 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8521 cd        write (2,*) 'ijkl',i,j,k,l
8522 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8523 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8524 cd      endif
8525 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8526 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8527 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8528 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8529       if (j.lt.nres-1) then
8530         j1=j+1
8531         j2=j-1
8532       else
8533         j1=j-1
8534         j2=j-2
8535       endif
8536       if (l.lt.nres-1) then
8537         l1=l+1
8538         l2=l-1
8539       else
8540         l1=l-1
8541         l2=l-2
8542       endif
8543 cd      eij=1.0d0
8544 cd      ekl=1.0d0
8545 cd      ekont=1.0d0
8546 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8547 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8548 C        summed up outside the subrouine as for the other subroutines
8549 C        handling long-range interactions. The old code is commented out
8550 C        with "cgrad" to keep track of changes.
8551       do ll=1,3
8552 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8553 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8554         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8555         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8556 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8557 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8558 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8559 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8560 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8561 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8562 c     &   gradcorr5ij,
8563 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8564 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8565 cgrad        ghalf=0.5d0*ggg1(ll)
8566 cd        ghalf=0.0d0
8567         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8568         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8569         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8570         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8571         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8572         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8573 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8574 cgrad        ghalf=0.5d0*ggg2(ll)
8575 cd        ghalf=0.0d0
8576         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8577         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8578         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8579         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8580         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8581         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8582       enddo
8583 cd      goto 1112
8584 cgrad      do m=i+1,j-1
8585 cgrad        do ll=1,3
8586 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8587 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8588 cgrad        enddo
8589 cgrad      enddo
8590 cgrad      do m=k+1,l-1
8591 cgrad        do ll=1,3
8592 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8593 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8594 cgrad        enddo
8595 cgrad      enddo
8596 c1112  continue
8597 cgrad      do m=i+2,j2
8598 cgrad        do ll=1,3
8599 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8600 cgrad        enddo
8601 cgrad      enddo
8602 cgrad      do m=k+2,l2
8603 cgrad        do ll=1,3
8604 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8605 cgrad        enddo
8606 cgrad      enddo
8607 cd      do iii=1,nres-3
8608 cd        write (2,*) iii,g_corr5_loc(iii)
8609 cd      enddo
8610       eello5=ekont*eel5
8611 cd      write (2,*) 'ekont',ekont
8612 cd      write (iout,*) 'eello5',ekont*eel5
8613       return
8614       end
8615 c--------------------------------------------------------------------------
8616       double precision function eello6(i,j,k,l,jj,kk)
8617       implicit real*8 (a-h,o-z)
8618       include 'DIMENSIONS'
8619       include 'COMMON.IOUNITS'
8620       include 'COMMON.CHAIN'
8621       include 'COMMON.DERIV'
8622       include 'COMMON.INTERACT'
8623       include 'COMMON.CONTACTS'
8624       include 'COMMON.TORSION'
8625       include 'COMMON.VAR'
8626       include 'COMMON.GEO'
8627       include 'COMMON.FFIELD'
8628       double precision ggg1(3),ggg2(3)
8629 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8630 cd        eello6=0.0d0
8631 cd        return
8632 cd      endif
8633 cd      write (iout,*)
8634 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8635 cd     &   ' and',k,l
8636       eello6_1=0.0d0
8637       eello6_2=0.0d0
8638       eello6_3=0.0d0
8639       eello6_4=0.0d0
8640       eello6_5=0.0d0
8641       eello6_6=0.0d0
8642 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8643 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8644       do iii=1,2
8645         do kkk=1,5
8646           do lll=1,3
8647             derx(lll,kkk,iii)=0.0d0
8648           enddo
8649         enddo
8650       enddo
8651 cd      eij=facont_hb(jj,i)
8652 cd      ekl=facont_hb(kk,k)
8653 cd      ekont=eij*ekl
8654 cd      eij=1.0d0
8655 cd      ekl=1.0d0
8656 cd      ekont=1.0d0
8657       if (l.eq.j+1) then
8658         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8659         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8660         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8661         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8662         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8663         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8664       else
8665         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8666         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8667         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8668         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8669         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8670           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8671         else
8672           eello6_5=0.0d0
8673         endif
8674         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8675       endif
8676 C If turn contributions are considered, they will be handled separately.
8677       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8678 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8679 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8680 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8681 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8682 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8683 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8684 cd      goto 1112
8685       if (j.lt.nres-1) then
8686         j1=j+1
8687         j2=j-1
8688       else
8689         j1=j-1
8690         j2=j-2
8691       endif
8692       if (l.lt.nres-1) then
8693         l1=l+1
8694         l2=l-1
8695       else
8696         l1=l-1
8697         l2=l-2
8698       endif
8699       do ll=1,3
8700 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8701 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8702 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8703 cgrad        ghalf=0.5d0*ggg1(ll)
8704 cd        ghalf=0.0d0
8705         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8706         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8707         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8708         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8709         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8710         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8711         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8712         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8713 cgrad        ghalf=0.5d0*ggg2(ll)
8714 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8715 cd        ghalf=0.0d0
8716         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8717         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8718         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8719         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8720         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8721         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8722       enddo
8723 cd      goto 1112
8724 cgrad      do m=i+1,j-1
8725 cgrad        do ll=1,3
8726 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8727 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8728 cgrad        enddo
8729 cgrad      enddo
8730 cgrad      do m=k+1,l-1
8731 cgrad        do ll=1,3
8732 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8733 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8734 cgrad        enddo
8735 cgrad      enddo
8736 cgrad1112  continue
8737 cgrad      do m=i+2,j2
8738 cgrad        do ll=1,3
8739 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8740 cgrad        enddo
8741 cgrad      enddo
8742 cgrad      do m=k+2,l2
8743 cgrad        do ll=1,3
8744 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8745 cgrad        enddo
8746 cgrad      enddo
8747 cd      do iii=1,nres-3
8748 cd        write (2,*) iii,g_corr6_loc(iii)
8749 cd      enddo
8750       eello6=ekont*eel6
8751 cd      write (2,*) 'ekont',ekont
8752 cd      write (iout,*) 'eello6',ekont*eel6
8753       return
8754       end
8755 c--------------------------------------------------------------------------
8756       double precision function eello6_graph1(i,j,k,l,imat,swap)
8757       implicit real*8 (a-h,o-z)
8758       include 'DIMENSIONS'
8759       include 'COMMON.IOUNITS'
8760       include 'COMMON.CHAIN'
8761       include 'COMMON.DERIV'
8762       include 'COMMON.INTERACT'
8763       include 'COMMON.CONTACTS'
8764       include 'COMMON.TORSION'
8765       include 'COMMON.VAR'
8766       include 'COMMON.GEO'
8767       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8768       logical swap
8769       logical lprn
8770       common /kutas/ lprn
8771 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8772 C                                                                              C
8773 C      Parallel       Antiparallel                                             C
8774 C                                                                              C
8775 C          o             o                                                     C
8776 C         /l\           /j\                                                    C
8777 C        /   \         /   \                                                   C
8778 C       /| o |         | o |\                                                  C
8779 C     \ j|/k\|  /   \  |/k\|l /                                                C
8780 C      \ /   \ /     \ /   \ /                                                 C
8781 C       o     o       o     o                                                  C
8782 C       i             i                                                        C
8783 C                                                                              C
8784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8785       itk=itortyp(itype(k))
8786       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8787       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8788       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8789       call transpose2(EUgC(1,1,k),auxmat(1,1))
8790       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8791       vv1(1)=pizda1(1,1)-pizda1(2,2)
8792       vv1(2)=pizda1(1,2)+pizda1(2,1)
8793       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8794       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8795       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8796       s5=scalar2(vv(1),Dtobr2(1,i))
8797 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8798       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8799       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8800      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8801      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8802      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8803      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8804      & +scalar2(vv(1),Dtobr2der(1,i)))
8805       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8806       vv1(1)=pizda1(1,1)-pizda1(2,2)
8807       vv1(2)=pizda1(1,2)+pizda1(2,1)
8808       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8809       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8810       if (l.eq.j+1) then
8811         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8812      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8813      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8814      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8815      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8816       else
8817         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8818      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8819      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8820      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8821      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8822       endif
8823       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8824       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8825       vv1(1)=pizda1(1,1)-pizda1(2,2)
8826       vv1(2)=pizda1(1,2)+pizda1(2,1)
8827       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8828      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8829      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8830      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8831       do iii=1,2
8832         if (swap) then
8833           ind=3-iii
8834         else
8835           ind=iii
8836         endif
8837         do kkk=1,5
8838           do lll=1,3
8839             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8840             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8841             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8842             call transpose2(EUgC(1,1,k),auxmat(1,1))
8843             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8844      &        pizda1(1,1))
8845             vv1(1)=pizda1(1,1)-pizda1(2,2)
8846             vv1(2)=pizda1(1,2)+pizda1(2,1)
8847             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8848             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8849      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8850             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8851      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8852             s5=scalar2(vv(1),Dtobr2(1,i))
8853             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8854           enddo
8855         enddo
8856       enddo
8857       return
8858       end
8859 c----------------------------------------------------------------------------
8860       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8861       implicit real*8 (a-h,o-z)
8862       include 'DIMENSIONS'
8863       include 'COMMON.IOUNITS'
8864       include 'COMMON.CHAIN'
8865       include 'COMMON.DERIV'
8866       include 'COMMON.INTERACT'
8867       include 'COMMON.CONTACTS'
8868       include 'COMMON.TORSION'
8869       include 'COMMON.VAR'
8870       include 'COMMON.GEO'
8871       logical swap
8872       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8873      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8874       logical lprn
8875       common /kutas/ lprn
8876 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8877 C                                                                              C
8878 C      Parallel       Antiparallel                                             C
8879 C                                                                              C
8880 C          o             o                                                     C
8881 C     \   /l\           /j\   /                                                C
8882 C      \ /   \         /   \ /                                                 C
8883 C       o| o |         | o |o                                                  C
8884 C     \ j|/k\|      \  |/k\|l                                                  C
8885 C      \ /   \       \ /   \                                                   C
8886 C       o             o                                                        C
8887 C       i             i                                                        C
8888 C                                                                              C
8889 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8890 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8891 C AL 7/4/01 s1 would occur in the sixth-order moment,
8892 C           but not in a cluster cumulant
8893 #ifdef MOMENT
8894       s1=dip(1,jj,i)*dip(1,kk,k)
8895 #endif
8896       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8897       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8898       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8899       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8900       call transpose2(EUg(1,1,k),auxmat(1,1))
8901       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8902       vv(1)=pizda(1,1)-pizda(2,2)
8903       vv(2)=pizda(1,2)+pizda(2,1)
8904       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8905 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8906 #ifdef MOMENT
8907       eello6_graph2=-(s1+s2+s3+s4)
8908 #else
8909       eello6_graph2=-(s2+s3+s4)
8910 #endif
8911 c      eello6_graph2=-s3
8912 C Derivatives in gamma(i-1)
8913       if (i.gt.1) then
8914 #ifdef MOMENT
8915         s1=dipderg(1,jj,i)*dip(1,kk,k)
8916 #endif
8917         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8918         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8919         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8920         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8921 #ifdef MOMENT
8922         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8923 #else
8924         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8925 #endif
8926 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8927       endif
8928 C Derivatives in gamma(k-1)
8929 #ifdef MOMENT
8930       s1=dip(1,jj,i)*dipderg(1,kk,k)
8931 #endif
8932       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8933       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8934       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8935       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8936       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8937       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8938       vv(1)=pizda(1,1)-pizda(2,2)
8939       vv(2)=pizda(1,2)+pizda(2,1)
8940       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8941 #ifdef MOMENT
8942       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8943 #else
8944       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8945 #endif
8946 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8947 C Derivatives in gamma(j-1) or gamma(l-1)
8948       if (j.gt.1) then
8949 #ifdef MOMENT
8950         s1=dipderg(3,jj,i)*dip(1,kk,k)
8951 #endif
8952         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8953         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8954         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8955         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8956         vv(1)=pizda(1,1)-pizda(2,2)
8957         vv(2)=pizda(1,2)+pizda(2,1)
8958         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8959 #ifdef MOMENT
8960         if (swap) then
8961           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8962         else
8963           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8964         endif
8965 #endif
8966         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8967 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8968       endif
8969 C Derivatives in gamma(l-1) or gamma(j-1)
8970       if (l.gt.1) then
8971 #ifdef MOMENT
8972         s1=dip(1,jj,i)*dipderg(3,kk,k)
8973 #endif
8974         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8975         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8976         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8977         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8978         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8979         vv(1)=pizda(1,1)-pizda(2,2)
8980         vv(2)=pizda(1,2)+pizda(2,1)
8981         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8982 #ifdef MOMENT
8983         if (swap) then
8984           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8985         else
8986           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8987         endif
8988 #endif
8989         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8990 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8991       endif
8992 C Cartesian derivatives.
8993       if (lprn) then
8994         write (2,*) 'In eello6_graph2'
8995         do iii=1,2
8996           write (2,*) 'iii=',iii
8997           do kkk=1,5
8998             write (2,*) 'kkk=',kkk
8999             do jjj=1,2
9000               write (2,'(3(2f10.5),5x)')
9001      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9002             enddo
9003           enddo
9004         enddo
9005       endif
9006       do iii=1,2
9007         do kkk=1,5
9008           do lll=1,3
9009 #ifdef MOMENT
9010             if (iii.eq.1) then
9011               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9012             else
9013               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9014             endif
9015 #endif
9016             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9017      &        auxvec(1))
9018             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9019             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9020      &        auxvec(1))
9021             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9022             call transpose2(EUg(1,1,k),auxmat(1,1))
9023             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9024      &        pizda(1,1))
9025             vv(1)=pizda(1,1)-pizda(2,2)
9026             vv(2)=pizda(1,2)+pizda(2,1)
9027             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9028 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9029 #ifdef MOMENT
9030             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9031 #else
9032             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9033 #endif
9034             if (swap) then
9035               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9036             else
9037               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9038             endif
9039           enddo
9040         enddo
9041       enddo
9042       return
9043       end
9044 c----------------------------------------------------------------------------
9045       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9046       implicit real*8 (a-h,o-z)
9047       include 'DIMENSIONS'
9048       include 'COMMON.IOUNITS'
9049       include 'COMMON.CHAIN'
9050       include 'COMMON.DERIV'
9051       include 'COMMON.INTERACT'
9052       include 'COMMON.CONTACTS'
9053       include 'COMMON.TORSION'
9054       include 'COMMON.VAR'
9055       include 'COMMON.GEO'
9056       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9057       logical swap
9058 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9059 C                                                                              C
9060 C      Parallel       Antiparallel                                             C
9061 C                                                                              C
9062 C          o             o                                                     C
9063 C         /l\   /   \   /j\                                                    C
9064 C        /   \ /     \ /   \                                                   C
9065 C       /| o |o       o| o |\                                                  C
9066 C       j|/k\|  /      |/k\|l /                                                C
9067 C        /   \ /       /   \ /                                                 C
9068 C       /     o       /     o                                                  C
9069 C       i             i                                                        C
9070 C                                                                              C
9071 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9072 C
9073 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9074 C           energy moment and not to the cluster cumulant.
9075       iti=itortyp(itype(i))
9076       if (j.lt.nres-1) then
9077         itj1=itortyp(itype(j+1))
9078       else
9079         itj1=ntortyp
9080       endif
9081       itk=itortyp(itype(k))
9082       itk1=itortyp(itype(k+1))
9083       if (l.lt.nres-1) then
9084         itl1=itortyp(itype(l+1))
9085       else
9086         itl1=ntortyp
9087       endif
9088 #ifdef MOMENT
9089       s1=dip(4,jj,i)*dip(4,kk,k)
9090 #endif
9091       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9092       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9093       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9094       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9095       call transpose2(EE(1,1,itk),auxmat(1,1))
9096       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9097       vv(1)=pizda(1,1)+pizda(2,2)
9098       vv(2)=pizda(2,1)-pizda(1,2)
9099       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9100 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9101 cd     & "sum",-(s2+s3+s4)
9102 #ifdef MOMENT
9103       eello6_graph3=-(s1+s2+s3+s4)
9104 #else
9105       eello6_graph3=-(s2+s3+s4)
9106 #endif
9107 c      eello6_graph3=-s4
9108 C Derivatives in gamma(k-1)
9109       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9110       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9111       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9112       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9113 C Derivatives in gamma(l-1)
9114       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9115       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9116       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9117       vv(1)=pizda(1,1)+pizda(2,2)
9118       vv(2)=pizda(2,1)-pizda(1,2)
9119       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9120       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9121 C Cartesian derivatives.
9122       do iii=1,2
9123         do kkk=1,5
9124           do lll=1,3
9125 #ifdef MOMENT
9126             if (iii.eq.1) then
9127               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9128             else
9129               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9130             endif
9131 #endif
9132             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9133      &        auxvec(1))
9134             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9135             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9136      &        auxvec(1))
9137             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9138             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9139      &        pizda(1,1))
9140             vv(1)=pizda(1,1)+pizda(2,2)
9141             vv(2)=pizda(2,1)-pizda(1,2)
9142             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9143 #ifdef MOMENT
9144             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9145 #else
9146             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9147 #endif
9148             if (swap) then
9149               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9150             else
9151               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9152             endif
9153 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9154           enddo
9155         enddo
9156       enddo
9157       return
9158       end
9159 c----------------------------------------------------------------------------
9160       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9161       implicit real*8 (a-h,o-z)
9162       include 'DIMENSIONS'
9163       include 'COMMON.IOUNITS'
9164       include 'COMMON.CHAIN'
9165       include 'COMMON.DERIV'
9166       include 'COMMON.INTERACT'
9167       include 'COMMON.CONTACTS'
9168       include 'COMMON.TORSION'
9169       include 'COMMON.VAR'
9170       include 'COMMON.GEO'
9171       include 'COMMON.FFIELD'
9172       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9173      & auxvec1(2),auxmat1(2,2)
9174       logical swap
9175 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9176 C                                                                              C
9177 C      Parallel       Antiparallel                                             C
9178 C                                                                              C
9179 C          o             o                                                     C
9180 C         /l\   /   \   /j\                                                    C
9181 C        /   \ /     \ /   \                                                   C
9182 C       /| o |o       o| o |\                                                  C
9183 C     \ j|/k\|      \  |/k\|l                                                  C
9184 C      \ /   \       \ /   \                                                   C
9185 C       o     \       o     \                                                  C
9186 C       i             i                                                        C
9187 C                                                                              C
9188 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9189 C
9190 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9191 C           energy moment and not to the cluster cumulant.
9192 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9193       iti=itortyp(itype(i))
9194       itj=itortyp(itype(j))
9195       if (j.lt.nres-1) then
9196         itj1=itortyp(itype(j+1))
9197       else
9198         itj1=ntortyp
9199       endif
9200       itk=itortyp(itype(k))
9201       if (k.lt.nres-1) then
9202         itk1=itortyp(itype(k+1))
9203       else
9204         itk1=ntortyp
9205       endif
9206       itl=itortyp(itype(l))
9207       if (l.lt.nres-1) then
9208         itl1=itortyp(itype(l+1))
9209       else
9210         itl1=ntortyp
9211       endif
9212 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9213 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9214 cd     & ' itl',itl,' itl1',itl1
9215 #ifdef MOMENT
9216       if (imat.eq.1) then
9217         s1=dip(3,jj,i)*dip(3,kk,k)
9218       else
9219         s1=dip(2,jj,j)*dip(2,kk,l)
9220       endif
9221 #endif
9222       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9223       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9224       if (j.eq.l+1) then
9225         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9226         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9227       else
9228         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9229         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9230       endif
9231       call transpose2(EUg(1,1,k),auxmat(1,1))
9232       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9233       vv(1)=pizda(1,1)-pizda(2,2)
9234       vv(2)=pizda(2,1)+pizda(1,2)
9235       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9236 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9237 #ifdef MOMENT
9238       eello6_graph4=-(s1+s2+s3+s4)
9239 #else
9240       eello6_graph4=-(s2+s3+s4)
9241 #endif
9242 C Derivatives in gamma(i-1)
9243       if (i.gt.1) then
9244 #ifdef MOMENT
9245         if (imat.eq.1) then
9246           s1=dipderg(2,jj,i)*dip(3,kk,k)
9247         else
9248           s1=dipderg(4,jj,j)*dip(2,kk,l)
9249         endif
9250 #endif
9251         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9252         if (j.eq.l+1) then
9253           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9254           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9255         else
9256           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9257           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9258         endif
9259         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9260         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9261 cd          write (2,*) 'turn6 derivatives'
9262 #ifdef MOMENT
9263           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9264 #else
9265           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9266 #endif
9267         else
9268 #ifdef MOMENT
9269           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9270 #else
9271           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9272 #endif
9273         endif
9274       endif
9275 C Derivatives in gamma(k-1)
9276 #ifdef MOMENT
9277       if (imat.eq.1) then
9278         s1=dip(3,jj,i)*dipderg(2,kk,k)
9279       else
9280         s1=dip(2,jj,j)*dipderg(4,kk,l)
9281       endif
9282 #endif
9283       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9284       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9285       if (j.eq.l+1) then
9286         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9287         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9288       else
9289         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9290         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9291       endif
9292       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9293       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9294       vv(1)=pizda(1,1)-pizda(2,2)
9295       vv(2)=pizda(2,1)+pizda(1,2)
9296       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9297       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9298 #ifdef MOMENT
9299         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9300 #else
9301         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9302 #endif
9303       else
9304 #ifdef MOMENT
9305         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9306 #else
9307         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9308 #endif
9309       endif
9310 C Derivatives in gamma(j-1) or gamma(l-1)
9311       if (l.eq.j+1 .and. l.gt.1) then
9312         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9313         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9314         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9315         vv(1)=pizda(1,1)-pizda(2,2)
9316         vv(2)=pizda(2,1)+pizda(1,2)
9317         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9318         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9319       else if (j.gt.1) then
9320         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9321         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9322         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9323         vv(1)=pizda(1,1)-pizda(2,2)
9324         vv(2)=pizda(2,1)+pizda(1,2)
9325         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9326         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9327           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9328         else
9329           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9330         endif
9331       endif
9332 C Cartesian derivatives.
9333       do iii=1,2
9334         do kkk=1,5
9335           do lll=1,3
9336 #ifdef MOMENT
9337             if (iii.eq.1) then
9338               if (imat.eq.1) then
9339                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9340               else
9341                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9342               endif
9343             else
9344               if (imat.eq.1) then
9345                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9346               else
9347                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9348               endif
9349             endif
9350 #endif
9351             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9352      &        auxvec(1))
9353             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9354             if (j.eq.l+1) then
9355               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9356      &          b1(1,j+1),auxvec(1))
9357               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9358             else
9359               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9360      &          b1(1,l+1),auxvec(1))
9361               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9362             endif
9363             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9364      &        pizda(1,1))
9365             vv(1)=pizda(1,1)-pizda(2,2)
9366             vv(2)=pizda(2,1)+pizda(1,2)
9367             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9368             if (swap) then
9369               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9370 #ifdef MOMENT
9371                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9372      &             -(s1+s2+s4)
9373 #else
9374                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9375      &             -(s2+s4)
9376 #endif
9377                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9378               else
9379 #ifdef MOMENT
9380                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9381 #else
9382                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9383 #endif
9384                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9385               endif
9386             else
9387 #ifdef MOMENT
9388               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9389 #else
9390               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9391 #endif
9392               if (l.eq.j+1) then
9393                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9394               else
9395                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9396               endif
9397             endif
9398           enddo
9399         enddo
9400       enddo
9401       return
9402       end
9403 c----------------------------------------------------------------------------
9404       double precision function eello_turn6(i,jj,kk)
9405       implicit real*8 (a-h,o-z)
9406       include 'DIMENSIONS'
9407       include 'COMMON.IOUNITS'
9408       include 'COMMON.CHAIN'
9409       include 'COMMON.DERIV'
9410       include 'COMMON.INTERACT'
9411       include 'COMMON.CONTACTS'
9412       include 'COMMON.TORSION'
9413       include 'COMMON.VAR'
9414       include 'COMMON.GEO'
9415       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9416      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9417      &  ggg1(3),ggg2(3)
9418       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9419      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9420 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9421 C           the respective energy moment and not to the cluster cumulant.
9422       s1=0.0d0
9423       s8=0.0d0
9424       s13=0.0d0
9425 c
9426       eello_turn6=0.0d0
9427       j=i+4
9428       k=i+1
9429       l=i+3
9430       iti=itortyp(itype(i))
9431       itk=itortyp(itype(k))
9432       itk1=itortyp(itype(k+1))
9433       itl=itortyp(itype(l))
9434       itj=itortyp(itype(j))
9435 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9436 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9437 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9438 cd        eello6=0.0d0
9439 cd        return
9440 cd      endif
9441 cd      write (iout,*)
9442 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9443 cd     &   ' and',k,l
9444 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9445       do iii=1,2
9446         do kkk=1,5
9447           do lll=1,3
9448             derx_turn(lll,kkk,iii)=0.0d0
9449           enddo
9450         enddo
9451       enddo
9452 cd      eij=1.0d0
9453 cd      ekl=1.0d0
9454 cd      ekont=1.0d0
9455       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9456 cd      eello6_5=0.0d0
9457 cd      write (2,*) 'eello6_5',eello6_5
9458 #ifdef MOMENT
9459       call transpose2(AEA(1,1,1),auxmat(1,1))
9460       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9461       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9462       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9463 #endif
9464       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9465       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9466       s2 = scalar2(b1(1,k),vtemp1(1))
9467 #ifdef MOMENT
9468       call transpose2(AEA(1,1,2),atemp(1,1))
9469       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9470       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9471       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9472 #endif
9473       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9474       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9475       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9476 #ifdef MOMENT
9477       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9478       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9479       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9480       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9481       ss13 = scalar2(b1(1,k),vtemp4(1))
9482       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9483 #endif
9484 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9485 c      s1=0.0d0
9486 c      s2=0.0d0
9487 c      s8=0.0d0
9488 c      s12=0.0d0
9489 c      s13=0.0d0
9490       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9491 C Derivatives in gamma(i+2)
9492       s1d =0.0d0
9493       s8d =0.0d0
9494 #ifdef MOMENT
9495       call transpose2(AEA(1,1,1),auxmatd(1,1))
9496       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9497       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9498       call transpose2(AEAderg(1,1,2),atempd(1,1))
9499       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9500       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9501 #endif
9502       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9503       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9504       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9505 c      s1d=0.0d0
9506 c      s2d=0.0d0
9507 c      s8d=0.0d0
9508 c      s12d=0.0d0
9509 c      s13d=0.0d0
9510       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9511 C Derivatives in gamma(i+3)
9512 #ifdef MOMENT
9513       call transpose2(AEA(1,1,1),auxmatd(1,1))
9514       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9515       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9516       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9517 #endif
9518       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9519       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9520       s2d = scalar2(b1(1,k),vtemp1d(1))
9521 #ifdef MOMENT
9522       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9523       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9524 #endif
9525       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9526 #ifdef MOMENT
9527       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9528       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9529       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9530 #endif
9531 c      s1d=0.0d0
9532 c      s2d=0.0d0
9533 c      s8d=0.0d0
9534 c      s12d=0.0d0
9535 c      s13d=0.0d0
9536 #ifdef MOMENT
9537       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9538      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9539 #else
9540       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9541      &               -0.5d0*ekont*(s2d+s12d)
9542 #endif
9543 C Derivatives in gamma(i+4)
9544       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9545       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9546       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9547 #ifdef MOMENT
9548       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9549       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9550       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9551 #endif
9552 c      s1d=0.0d0
9553 c      s2d=0.0d0
9554 c      s8d=0.0d0
9555 C      s12d=0.0d0
9556 c      s13d=0.0d0
9557 #ifdef MOMENT
9558       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9559 #else
9560       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9561 #endif
9562 C Derivatives in gamma(i+5)
9563 #ifdef MOMENT
9564       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9565       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9566       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9567 #endif
9568       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9569       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9570       s2d = scalar2(b1(1,k),vtemp1d(1))
9571 #ifdef MOMENT
9572       call transpose2(AEA(1,1,2),atempd(1,1))
9573       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9574       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9575 #endif
9576       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9577       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9578 #ifdef MOMENT
9579       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9580       ss13d = scalar2(b1(1,k),vtemp4d(1))
9581       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9582 #endif
9583 c      s1d=0.0d0
9584 c      s2d=0.0d0
9585 c      s8d=0.0d0
9586 c      s12d=0.0d0
9587 c      s13d=0.0d0
9588 #ifdef MOMENT
9589       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9590      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9591 #else
9592       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9593      &               -0.5d0*ekont*(s2d+s12d)
9594 #endif
9595 C Cartesian derivatives
9596       do iii=1,2
9597         do kkk=1,5
9598           do lll=1,3
9599 #ifdef MOMENT
9600             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9601             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9602             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9603 #endif
9604             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9605             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9606      &          vtemp1d(1))
9607             s2d = scalar2(b1(1,k),vtemp1d(1))
9608 #ifdef MOMENT
9609             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9610             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9611             s8d = -(atempd(1,1)+atempd(2,2))*
9612      &           scalar2(cc(1,1,itl),vtemp2(1))
9613 #endif
9614             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9615      &           auxmatd(1,1))
9616             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9617             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9618 c      s1d=0.0d0
9619 c      s2d=0.0d0
9620 c      s8d=0.0d0
9621 c      s12d=0.0d0
9622 c      s13d=0.0d0
9623 #ifdef MOMENT
9624             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9625      &        - 0.5d0*(s1d+s2d)
9626 #else
9627             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9628      &        - 0.5d0*s2d
9629 #endif
9630 #ifdef MOMENT
9631             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9632      &        - 0.5d0*(s8d+s12d)
9633 #else
9634             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9635      &        - 0.5d0*s12d
9636 #endif
9637           enddo
9638         enddo
9639       enddo
9640 #ifdef MOMENT
9641       do kkk=1,5
9642         do lll=1,3
9643           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9644      &      achuj_tempd(1,1))
9645           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9646           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9647           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9648           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9649           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9650      &      vtemp4d(1))
9651           ss13d = scalar2(b1(1,k),vtemp4d(1))
9652           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9653           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9654         enddo
9655       enddo
9656 #endif
9657 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9658 cd     &  16*eel_turn6_num
9659 cd      goto 1112
9660       if (j.lt.nres-1) then
9661         j1=j+1
9662         j2=j-1
9663       else
9664         j1=j-1
9665         j2=j-2
9666       endif
9667       if (l.lt.nres-1) then
9668         l1=l+1
9669         l2=l-1
9670       else
9671         l1=l-1
9672         l2=l-2
9673       endif
9674       do ll=1,3
9675 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9676 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9677 cgrad        ghalf=0.5d0*ggg1(ll)
9678 cd        ghalf=0.0d0
9679         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9680         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9681         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9682      &    +ekont*derx_turn(ll,2,1)
9683         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9684         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9685      &    +ekont*derx_turn(ll,4,1)
9686         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9687         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9688         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9689 cgrad        ghalf=0.5d0*ggg2(ll)
9690 cd        ghalf=0.0d0
9691         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9692      &    +ekont*derx_turn(ll,2,2)
9693         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9694         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9695      &    +ekont*derx_turn(ll,4,2)
9696         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9697         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9698         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9699       enddo
9700 cd      goto 1112
9701 cgrad      do m=i+1,j-1
9702 cgrad        do ll=1,3
9703 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9704 cgrad        enddo
9705 cgrad      enddo
9706 cgrad      do m=k+1,l-1
9707 cgrad        do ll=1,3
9708 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9709 cgrad        enddo
9710 cgrad      enddo
9711 cgrad1112  continue
9712 cgrad      do m=i+2,j2
9713 cgrad        do ll=1,3
9714 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9715 cgrad        enddo
9716 cgrad      enddo
9717 cgrad      do m=k+2,l2
9718 cgrad        do ll=1,3
9719 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9720 cgrad        enddo
9721 cgrad      enddo
9722 cd      do iii=1,nres-3
9723 cd        write (2,*) iii,g_corr6_loc(iii)
9724 cd      enddo
9725       eello_turn6=ekont*eel_turn6
9726 cd      write (2,*) 'ekont',ekont
9727 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9728       return
9729       end
9730
9731 C-----------------------------------------------------------------------------
9732       double precision function scalar(u,v)
9733 !DIR$ INLINEALWAYS scalar
9734 #ifndef OSF
9735 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9736 #endif
9737       implicit none
9738       double precision u(3),v(3)
9739 cd      double precision sc
9740 cd      integer i
9741 cd      sc=0.0d0
9742 cd      do i=1,3
9743 cd        sc=sc+u(i)*v(i)
9744 cd      enddo
9745 cd      scalar=sc
9746
9747       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9748       return
9749       end
9750 crc-------------------------------------------------
9751       SUBROUTINE MATVEC2(A1,V1,V2)
9752 !DIR$ INLINEALWAYS MATVEC2
9753 #ifndef OSF
9754 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9755 #endif
9756       implicit real*8 (a-h,o-z)
9757       include 'DIMENSIONS'
9758       DIMENSION A1(2,2),V1(2),V2(2)
9759 c      DO 1 I=1,2
9760 c        VI=0.0
9761 c        DO 3 K=1,2
9762 c    3     VI=VI+A1(I,K)*V1(K)
9763 c        Vaux(I)=VI
9764 c    1 CONTINUE
9765
9766       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9767       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9768
9769       v2(1)=vaux1
9770       v2(2)=vaux2
9771       END
9772 C---------------------------------------
9773       SUBROUTINE MATMAT2(A1,A2,A3)
9774 #ifndef OSF
9775 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9776 #endif
9777       implicit real*8 (a-h,o-z)
9778       include 'DIMENSIONS'
9779       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9780 c      DIMENSION AI3(2,2)
9781 c        DO  J=1,2
9782 c          A3IJ=0.0
9783 c          DO K=1,2
9784 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9785 c          enddo
9786 c          A3(I,J)=A3IJ
9787 c       enddo
9788 c      enddo
9789
9790       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9791       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9792       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9793       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9794
9795       A3(1,1)=AI3_11
9796       A3(2,1)=AI3_21
9797       A3(1,2)=AI3_12
9798       A3(2,2)=AI3_22
9799       END
9800
9801 c-------------------------------------------------------------------------
9802       double precision function scalar2(u,v)
9803 !DIR$ INLINEALWAYS scalar2
9804       implicit none
9805       double precision u(2),v(2)
9806       double precision sc
9807       integer i
9808       scalar2=u(1)*v(1)+u(2)*v(2)
9809       return
9810       end
9811
9812 C-----------------------------------------------------------------------------
9813
9814       subroutine transpose2(a,at)
9815 !DIR$ INLINEALWAYS transpose2
9816 #ifndef OSF
9817 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9818 #endif
9819       implicit none
9820       double precision a(2,2),at(2,2)
9821       at(1,1)=a(1,1)
9822       at(1,2)=a(2,1)
9823       at(2,1)=a(1,2)
9824       at(2,2)=a(2,2)
9825       return
9826       end
9827 c--------------------------------------------------------------------------
9828       subroutine transpose(n,a,at)
9829       implicit none
9830       integer n,i,j
9831       double precision a(n,n),at(n,n)
9832       do i=1,n
9833         do j=1,n
9834           at(j,i)=a(i,j)
9835         enddo
9836       enddo
9837       return
9838       end
9839 C---------------------------------------------------------------------------
9840       subroutine prodmat3(a1,a2,kk,transp,prod)
9841 !DIR$ INLINEALWAYS prodmat3
9842 #ifndef OSF
9843 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9844 #endif
9845       implicit none
9846       integer i,j
9847       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9848       logical transp
9849 crc      double precision auxmat(2,2),prod_(2,2)
9850
9851       if (transp) then
9852 crc        call transpose2(kk(1,1),auxmat(1,1))
9853 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9854 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9855
9856            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9857      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9858            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9859      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9860            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9861      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9862            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9863      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9864
9865       else
9866 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9867 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9868
9869            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9870      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9871            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9872      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9873            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9874      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9875            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9876      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9877
9878       endif
9879 c      call transpose2(a2(1,1),a2t(1,1))
9880
9881 crc      print *,transp
9882 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9883 crc      print *,((prod(i,j),i=1,2),j=1,2)
9884
9885       return
9886       end
9887