source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 #ifdef TIMING
 265       time_enecalc=time_enecalc+MPI_Wtime()-time00
 266 #endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 #ifdef TIMING
 269       time00=MPI_Wtime()
 270 #endif
 271 c
 272 C Sum the energies
 273 C
 274       energia(1)=evdw
 275 #ifdef SCP14
 276       energia(2)=evdw2-evdw2_14
 277       energia(18)=evdw2_14
 278 #else
 279       energia(2)=evdw2
 280       energia(18)=0.0d0
 281 #endif
 282 #ifdef SPLITELE
 283       energia(3)=ees
 284       energia(16)=evdw1
 285 #else
 286       energia(3)=ees+evdw1
 287       energia(16)=0.0d0
 288 #endif
 289       energia(4)=ecorr
 290       energia(5)=ecorr5
 291       energia(6)=ecorr6
 292       energia(7)=eel_loc
 293       energia(8)=eello_turn3
 294       energia(9)=eello_turn4
 295       energia(10)=eturn6
 296       energia(11)=ebe
 297       energia(12)=escloc
 298       energia(13)=etors
 299       energia(14)=etors_d
 300       energia(15)=ehpb
 301       energia(19)=edihcnstr
 302       energia(17)=estr
 303       energia(20)=Uconst+Uconst_back
 304       energia(21)=esccor
 305 c    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445 #endif
 446       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 447      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,ebr*nss,
 982      &  Uconst,etot
 983    10 format (/'Virtual-chain energies:'//
 984      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 985      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 986      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 987      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #else
1008       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1009      &  estr,wbond,ebe,wang,
1010      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1011      &  ecorr,wcorr,
1012      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1013      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1014      &  ebr*nss,Uconst,etot
1015    10 format (/'Virtual-chain energies:'//
1016      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1017      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1018      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1019      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1020      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1021      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1022      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1023      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1024      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1025      & ' (SS bridges & dist. cnstr.)'/
1026      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1030      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1031      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1032      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1033      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1034      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1035      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1036      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1037      & 'ETOT=  ',1pE16.6,' (total)')
1038 #endif
1039       return
1040       end
1041 C-----------------------------------------------------------------------
1042       subroutine elj(evdw)
1043 C
1044 C This subroutine calculates the interaction energy of nonbonded side chains
1045 C assuming the LJ potential of interaction.
1046 C
1047       implicit real*8 (a-h,o-z)
1048       include 'DIMENSIONS'
1049       parameter (accur=1.0d-10)
1050       include 'COMMON.GEO'
1051       include 'COMMON.VAR'
1052       include 'COMMON.LOCAL'
1053       include 'COMMON.CHAIN'
1054       include 'COMMON.DERIV'
1055       include 'COMMON.INTERACT'
1056       include 'COMMON.TORSION'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.NAMES'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.CONTACTS'
1061       dimension gg(3)
1062 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1063       evdw=0.0D0
1064       do i=iatsc_s,iatsc_e
1065         itypi=iabs(itype(i))
1066         if (itypi.eq.ntyp1) cycle
1067         itypi1=iabs(itype(i+1))
1068         xi=c(1,nres+i)
1069         yi=c(2,nres+i)
1070         zi=c(3,nres+i)
1071 C Change 12/1/95
1072         num_conti=0
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1078 cd   &                  'iend=',iend(i,iint)
1079           do j=istart(i,iint),iend(i,iint)
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             xj=c(1,nres+j)-xi
1083             yj=c(2,nres+j)-yi
1084             zj=c(3,nres+j)-zi
1085 C Change 12/1/95 to calculate four-body interactions
1086             rij=xj*xj+yj*yj+zj*zj
1087             rrij=1.0D0/rij
1088 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1089             eps0ij=eps(itypi,itypj)
1090             fac=rrij**expon2
1091             e1=fac*fac*aa(itypi,itypj)
1092             e2=fac*bb(itypi,itypj)
1093             evdwij=e1+e2
1094 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1097 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1098 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1099 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1100             evdw=evdw+evdwij
1101 C
1102 C Calculate the components of the gradient in DC and X
1103 C
1104             fac=-rrij*(e1+evdwij)
1105             gg(1)=xj*fac
1106             gg(2)=yj*fac
1107             gg(3)=zj*fac
1108             do k=1,3
1109               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1110               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1111               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1112               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1113             enddo
1114 cgrad            do k=i,j-1
1115 cgrad              do l=1,3
1116 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1117 cgrad              enddo
1118 cgrad            enddo
1119 C
1120 C 12/1/95, revised on 5/20/97
1121 C
1122 C Calculate the contact function. The ith column of the array JCONT will
1123 C contain the numbers of atoms that make contacts with the atom I (of numbers
1124 C greater than I). The arrays FACONT and GACONT will contain the values of
1125 C the contact function and its derivative.
1126 C
1127 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1128 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1129 C Uncomment next line, if the correlation interactions are contact function only
1130             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1131               rij=dsqrt(rij)
1132               sigij=sigma(itypi,itypj)
1133               r0ij=rs0(itypi,itypj)
1134 C
1135 C Check whether the SC's are not too far to make a contact.
1136 C
1137               rcut=1.5d0*r0ij
1138               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1139 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1140 C
1141               if (fcont.gt.0.0D0) then
1142 C If the SC-SC distance if close to sigma, apply spline.
1143 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1144 cAdam &             fcont1,fprimcont1)
1145 cAdam           fcont1=1.0d0-fcont1
1146 cAdam           if (fcont1.gt.0.0d0) then
1147 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1148 cAdam             fcont=fcont*fcont1
1149 cAdam           endif
1150 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1151 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1152 cga             do k=1,3
1153 cga               gg(k)=gg(k)*eps0ij
1154 cga             enddo
1155 cga             eps0ij=-evdwij*eps0ij
1156 C Uncomment for AL's type of SC correlation interactions.
1157 cadam           eps0ij=-evdwij
1158                 num_conti=num_conti+1
1159                 jcont(num_conti,i)=j
1160                 facont(num_conti,i)=fcont*eps0ij
1161                 fprimcont=eps0ij*fprimcont/rij
1162                 fcont=expon*fcont
1163 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1164 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1165 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1166 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1167                 gacont(1,num_conti,i)=-fprimcont*xj
1168                 gacont(2,num_conti,i)=-fprimcont*yj
1169                 gacont(3,num_conti,i)=-fprimcont*zj
1170 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1171 cd              write (iout,'(2i3,3f10.5)')
1172 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1173               endif
1174             endif
1175           enddo      ! j
1176         enddo        ! iint
1177 C Change 12/1/95
1178         num_cont(i)=num_conti
1179       enddo          ! i
1180       do i=1,nct
1181         do j=1,3
1182           gvdwc(j,i)=expon*gvdwc(j,i)
1183           gvdwx(j,i)=expon*gvdwx(j,i)
1184         enddo
1185       enddo
1186 C******************************************************************************
1187 C
1188 C                              N O T E !!!
1189 C
1190 C To save time, the factor of EXPON has been extracted from ALL components
1191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1192 C use!
1193 C
1194 C******************************************************************************
1195       return
1196       end
1197 C-----------------------------------------------------------------------------
1198       subroutine eljk(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJK potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       include 'COMMON.GEO'
1206       include 'COMMON.VAR'
1207       include 'COMMON.LOCAL'
1208       include 'COMMON.CHAIN'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       include 'COMMON.IOUNITS'
1212       include 'COMMON.NAMES'
1213       dimension gg(3)
1214       logical scheck
1215 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1216       evdw=0.0D0
1217       do i=iatsc_s,iatsc_e
1218         itypi=iabs(itype(i))
1219         if (itypi.eq.ntyp1) cycle
1220         itypi1=iabs(itype(i+1))
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224 C
1225 C Calculate SC interaction energy.
1226 C
1227         do iint=1,nint_gr(i)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             fac_augm=rrij**expon
1236             e_augm=augm(itypi,itypj)*fac_augm
1237             r_inv_ij=dsqrt(rrij)
1238             rij=1.0D0/r_inv_ij
1239             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1240             fac=r_shift_inv**expon
1241             e1=fac*fac*aa(itypi,itypj)
1242             e2=fac*bb(itypi,itypj)
1243             evdwij=e_augm+e1+e2
1244 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1245 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1246 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1247 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1248 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1249 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1250 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1251             evdw=evdw+evdwij
1252 C
1253 C Calculate the components of the gradient in DC and X
1254 C
1255             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1256             gg(1)=xj*fac
1257             gg(2)=yj*fac
1258             gg(3)=zj*fac
1259             do k=1,3
1260               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1261               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1262               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1263               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1264             enddo
1265 cgrad            do k=i,j-1
1266 cgrad              do l=1,3
1267 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1268 cgrad              enddo
1269 cgrad            enddo
1270           enddo      ! j
1271         enddo        ! iint
1272       enddo          ! i
1273       do i=1,nct
1274         do j=1,3
1275           gvdwc(j,i)=expon*gvdwc(j,i)
1276           gvdwx(j,i)=expon*gvdwx(j,i)
1277         enddo
1278       enddo
1279       return
1280       end
1281 C-----------------------------------------------------------------------------
1282       subroutine ebp(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the Berne-Pechukas potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       include 'COMMON.GEO'
1290       include 'COMMON.VAR'
1291       include 'COMMON.LOCAL'
1292       include 'COMMON.CHAIN'
1293       include 'COMMON.DERIV'
1294       include 'COMMON.NAMES'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.CALC'
1298       common /srutu/ icall
1299 c     double precision rrsave(maxdim)
1300       logical lprn
1301       evdw=0.0D0
1302 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304 c     if (icall.eq.0) then
1305 c       lprn=.true.
1306 c     else
1307         lprn=.false.
1308 c     endif
1309       ind=0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317         dxi=dc_norm(1,nres+i)
1318         dyi=dc_norm(2,nres+i)
1319         dzi=dc_norm(3,nres+i)
1320 c        dsci_inv=dsc_inv(itypi)
1321         dsci_inv=vbld_inv(i+nres)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             ind=ind+1
1328             itypj=iabs(itype(j))
1329             if (itypj.eq.ntyp1) cycle
1330 c            dscj_inv=dsc_inv(itypj)
1331             dscj_inv=vbld_inv(j+nres)
1332             chi1=chi(itypi,itypj)
1333             chi2=chi(itypj,itypi)
1334             chi12=chi1*chi2
1335             chip1=chip(itypi)
1336             chip2=chip(itypj)
1337             chip12=chip1*chip2
1338             alf1=alp(itypi)
1339             alf2=alp(itypj)
1340             alf12=0.5D0*(alf1+alf2)
1341 C For diagnostics only!!!
1342 c           chi1=0.0D0
1343 c           chi2=0.0D0
1344 c           chi12=0.0D0
1345 c           chip1=0.0D0
1346 c           chip2=0.0D0
1347 c           chip12=0.0D0
1348 c           alf1=0.0D0
1349 c           alf2=0.0D0
1350 c           alf12=0.0D0
1351             xj=c(1,nres+j)-xi
1352             yj=c(2,nres+j)-yi
1353             zj=c(3,nres+j)-zi
1354             dxj=dc_norm(1,nres+j)
1355             dyj=dc_norm(2,nres+j)
1356             dzj=dc_norm(3,nres+j)
1357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1358 cd          if (icall.eq.0) then
1359 cd            rrsave(ind)=rrij
1360 cd          else
1361 cd            rrij=rrsave(ind)
1362 cd          endif
1363             rij=dsqrt(rrij)
1364 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1365             call sc_angular
1366 C Calculate whole angle-dependent part of epsilon and contributions
1367 C to its derivatives
1368             fac=(rrij*sigsq)**expon2
1369             e1=fac*fac*aa(itypi,itypj)
1370             e2=fac*bb(itypi,itypj)
1371             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1372             eps2der=evdwij*eps3rt
1373             eps3der=evdwij*eps2rt
1374             evdwij=evdwij*eps2rt*eps3rt
1375             evdw=evdw+evdwij
1376             if (lprn) then
1377             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1378             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1379 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1380 cd     &        restyp(itypi),i,restyp(itypj),j,
1381 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1382 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1383 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1384 cd     &        evdwij
1385             endif
1386 C Calculate gradient components.
1387             e1=e1*eps1*eps2rt**2*eps3rt**2
1388             fac=-expon*(e1+evdwij)
1389             sigder=fac/sigsq
1390             fac=rrij*fac
1391 C Calculate radial part of the gradient
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395 C Calculate the angular part of the gradient and sum add the contributions
1396 C to the appropriate components of the Cartesian gradient.
1397             call sc_grad
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401 c     stop
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine egb(evdw)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Gay-Berne potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       include 'COMMON.CONTROL'
1422       include 'COMMON.SPLITELE'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       integer xshift,yshift,zshift
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1434 C we have the original box)
1435 C      do xshift=-1,1
1436 C      do yshift=-1,1
1437 C      do zshift=-1,1
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445 C Return atom into box, boxxsize is size of box in x dimension
1446 c  134   continue
1447 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1448 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1449 C Condition for being inside the proper box
1450 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1451 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1452 c        go to 134
1453 c        endif
1454 c  135   continue
1455 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1456 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1457 C Condition for being inside the proper box
1458 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1459 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1460 c        go to 135
1461 c        endif
1462 c  136   continue
1463 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1464 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1465 C Condition for being inside the proper box
1466 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1467 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1468 c        go to 136
1469 c        endif
1470           xi=mod(xi,boxxsize)
1471           if (xi.lt.0) xi=xi+boxxsize
1472           yi=mod(yi,boxysize)
1473           if (yi.lt.0) yi=yi+boxysize
1474           zi=mod(zi,boxzsize)
1475           if (zi.lt.0) zi=zi+boxzsize
1476 C          xi=xi+xshift*boxxsize
1477 C          yi=yi+yshift*boxysize
1478 C          zi=zi+zshift*boxzsize
1479
1480         dxi=dc_norm(1,nres+i)
1481         dyi=dc_norm(2,nres+i)
1482         dzi=dc_norm(3,nres+i)
1483 c        dsci_inv=dsc_inv(itypi)
1484         dsci_inv=vbld_inv(i+nres)
1485 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1486 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1487 C
1488 C Calculate SC interaction energy.
1489 C
1490         do iint=1,nint_gr(i)
1491           do j=istart(i,iint),iend(i,iint)
1492             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1493               call dyn_ssbond_ene(i,j,evdwij)
1494               evdw=evdw+evdwij
1495               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1496      &                        'evdw',i,j,evdwij,' ss'
1497             ELSE
1498             ind=ind+1
1499             itypj=iabs(itype(j))
1500             if (itypj.eq.ntyp1) cycle
1501 c            dscj_inv=dsc_inv(itypj)
1502             dscj_inv=vbld_inv(j+nres)
1503 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1504 c     &       1.0d0/vbld(j+nres)
1505 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1506             sig0ij=sigma(itypi,itypj)
1507             chi1=chi(itypi,itypj)
1508             chi2=chi(itypj,itypi)
1509             chi12=chi1*chi2
1510             chip1=chip(itypi)
1511             chip2=chip(itypj)
1512             chip12=chip1*chip2
1513             alf1=alp(itypi)
1514             alf2=alp(itypj)
1515             alf12=0.5D0*(alf1+alf2)
1516 C For diagnostics only!!!
1517 c           chi1=0.0D0
1518 c           chi2=0.0D0
1519 c           chi12=0.0D0
1520 c           chip1=0.0D0
1521 c           chip2=0.0D0
1522 c           chip12=0.0D0
1523 c           alf1=0.0D0
1524 c           alf2=0.0D0
1525 c           alf12=0.0D0
1526             xj=c(1,nres+j)
1527             yj=c(2,nres+j)
1528             zj=c(3,nres+j)
1529 C Return atom J into box the original box
1530 c  137   continue
1531 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1532 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1533 C Condition for being inside the proper box
1534 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1535 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1536 c        go to 137
1537 c        endif
1538 c  138   continue
1539 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1540 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1541 C Condition for being inside the proper box
1542 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1543 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1544 c        go to 138
1545 c        endif
1546 c  139   continue
1547 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1548 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1549 C Condition for being inside the proper box
1550 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1551 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1552 c        go to 139
1553 c        endif
1554           xj=mod(xj,boxxsize)
1555           if (xj.lt.0) xj=xj+boxxsize
1556           yj=mod(yj,boxysize)
1557           if (yj.lt.0) yj=yj+boxysize
1558           zj=mod(zj,boxzsize)
1559           if (zj.lt.0) zj=zj+boxzsize
1560       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1561       xj_safe=xj
1562       yj_safe=yj
1563       zj_safe=zj
1564       subchap=0
1565       do xshift=-1,1
1566       do yshift=-1,1
1567       do zshift=-1,1
1568           xj=xj_safe+xshift*boxxsize
1569           yj=yj_safe+yshift*boxysize
1570           zj=zj_safe+zshift*boxzsize
1571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572           if(dist_temp.lt.dist_init) then
1573             dist_init=dist_temp
1574             xj_temp=xj
1575             yj_temp=yj
1576             zj_temp=zj
1577             subchap=1
1578           endif
1579        enddo
1580        enddo
1581        enddo
1582        if (subchap.eq.1) then
1583           xj=xj_temp-xi
1584           yj=yj_temp-yi
1585           zj=zj_temp-zi
1586        else
1587           xj=xj_safe-xi
1588           yj=yj_safe-yi
1589           zj=zj_safe-zi
1590        endif
1591             dxj=dc_norm(1,nres+j)
1592             dyj=dc_norm(2,nres+j)
1593             dzj=dc_norm(3,nres+j)
1594 C            xj=xj-xi
1595 C            yj=yj-yi
1596 C            zj=zj-zi
1597 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1598 c            write (iout,*) "j",j," dc_norm",
1599 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1600             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1601             rij=dsqrt(rrij)
1602             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1603             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1604
1605 c            write (iout,'(a7,4f8.3)')
1606 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1607             if (sss.gt.0.0d0) then
1608 C Calculate angle-dependent terms of energy and contributions to their
1609 C derivatives.
1610             call sc_angular
1611             sigsq=1.0D0/sigsq
1612             sig=sig0ij*dsqrt(sigsq)
1613             rij_shift=1.0D0/rij-sig+sig0ij
1614 c for diagnostics; uncomment
1615 c            rij_shift=1.2*sig0ij
1616 C I hate to put IF's in the loops, but here don't have another choice!!!!
1617             if (rij_shift.le.0.0D0) then
1618               evdw=1.0D20
1619 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1620 cd     &        restyp(itypi),i,restyp(itypj),j,
1621 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1622               return
1623             endif
1624             sigder=-sig*sigsq
1625 c---------------------------------------------------------------
1626             rij_shift=1.0D0/rij_shift
1627             fac=rij_shift**expon
1628             e1=fac*fac*aa(itypi,itypj)
1629             e2=fac*bb(itypi,itypj)
1630             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1631             eps2der=evdwij*eps3rt
1632             eps3der=evdwij*eps2rt
1633 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1634 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1635             evdwij=evdwij*eps2rt*eps3rt
1636             evdw=evdw+evdwij*sss
1637             if (lprn) then
1638             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1639             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1640             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1641      &        restyp(itypi),i,restyp(itypj),j,
1642      &        epsi,sigm,chi1,chi2,chip1,chip2,
1643      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1644      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1645      &        evdwij
1646             endif
1647
1648             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1649      &                        'evdw',i,j,evdwij
1650
1651 C Calculate gradient components.
1652             e1=e1*eps1*eps2rt**2*eps3rt**2
1653             fac=-expon*(e1+evdwij)*rij_shift
1654             sigder=fac*sigder
1655             fac=rij*fac
1656 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1657 c     &      evdwij,fac,sigma(itypi,itypj),expon
1658             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1659 c            fac=0.0d0
1660 C Calculate the radial part of the gradient
1661             gg(1)=xj*fac
1662             gg(2)=yj*fac
1663             gg(3)=zj*fac
1664 C Calculate angular part of the gradient.
1665             call sc_grad
1666             endif    ! sss
1667             ENDIF    ! dyn_ss
1668           enddo      ! j
1669         enddo        ! iint
1670       enddo          ! i
1671 C      enddo          ! zshift
1672 C      enddo          ! yshift
1673 C      enddo          ! xshift
1674 c      write (iout,*) "Number of loop steps in EGB:",ind
1675 cccc      energy_dec=.false.
1676       return
1677       end
1678 C-----------------------------------------------------------------------------
1679       subroutine egbv(evdw)
1680 C
1681 C This subroutine calculates the interaction energy of nonbonded side chains
1682 C assuming the Gay-Berne-Vorobjev potential of interaction.
1683 C
1684       implicit real*8 (a-h,o-z)
1685       include 'DIMENSIONS'
1686       include 'COMMON.GEO'
1687       include 'COMMON.VAR'
1688       include 'COMMON.LOCAL'
1689       include 'COMMON.CHAIN'
1690       include 'COMMON.DERIV'
1691       include 'COMMON.NAMES'
1692       include 'COMMON.INTERACT'
1693       include 'COMMON.IOUNITS'
1694       include 'COMMON.CALC'
1695       common /srutu/ icall
1696       logical lprn
1697       evdw=0.0D0
1698 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1699       evdw=0.0D0
1700       lprn=.false.
1701 c     if (icall.eq.0) lprn=.true.
1702       ind=0
1703       do i=iatsc_s,iatsc_e
1704         itypi=iabs(itype(i))
1705         if (itypi.eq.ntyp1) cycle
1706         itypi1=iabs(itype(i+1))
1707         xi=c(1,nres+i)
1708         yi=c(2,nres+i)
1709         zi=c(3,nres+i)
1710         dxi=dc_norm(1,nres+i)
1711         dyi=dc_norm(2,nres+i)
1712         dzi=dc_norm(3,nres+i)
1713 c        dsci_inv=dsc_inv(itypi)
1714         dsci_inv=vbld_inv(i+nres)
1715 C
1716 C Calculate SC interaction energy.
1717 C
1718         do iint=1,nint_gr(i)
1719           do j=istart(i,iint),iend(i,iint)
1720             ind=ind+1
1721             itypj=iabs(itype(j))
1722             if (itypj.eq.ntyp1) cycle
1723 c            dscj_inv=dsc_inv(itypj)
1724             dscj_inv=vbld_inv(j+nres)
1725             sig0ij=sigma(itypi,itypj)
1726             r0ij=r0(itypi,itypj)
1727             chi1=chi(itypi,itypj)
1728             chi2=chi(itypj,itypi)
1729             chi12=chi1*chi2
1730             chip1=chip(itypi)
1731             chip2=chip(itypj)
1732             chip12=chip1*chip2
1733             alf1=alp(itypi)
1734             alf2=alp(itypj)
1735             alf12=0.5D0*(alf1+alf2)
1736 C For diagnostics only!!!
1737 c           chi1=0.0D0
1738 c           chi2=0.0D0
1739 c           chi12=0.0D0
1740 c           chip1=0.0D0
1741 c           chip2=0.0D0
1742 c           chip12=0.0D0
1743 c           alf1=0.0D0
1744 c           alf2=0.0D0
1745 c           alf12=0.0D0
1746             xj=c(1,nres+j)-xi
1747             yj=c(2,nres+j)-yi
1748             zj=c(3,nres+j)-zi
1749             dxj=dc_norm(1,nres+j)
1750             dyj=dc_norm(2,nres+j)
1751             dzj=dc_norm(3,nres+j)
1752             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1753             rij=dsqrt(rrij)
1754 C Calculate angle-dependent terms of energy and contributions to their
1755 C derivatives.
1756             call sc_angular
1757             sigsq=1.0D0/sigsq
1758             sig=sig0ij*dsqrt(sigsq)
1759             rij_shift=1.0D0/rij-sig+r0ij
1760 C I hate to put IF's in the loops, but here don't have another choice!!!!
1761             if (rij_shift.le.0.0D0) then
1762               evdw=1.0D20
1763               return
1764             endif
1765             sigder=-sig*sigsq
1766 c---------------------------------------------------------------
1767             rij_shift=1.0D0/rij_shift
1768             fac=rij_shift**expon
1769             e1=fac*fac*aa(itypi,itypj)
1770             e2=fac*bb(itypi,itypj)
1771             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1772             eps2der=evdwij*eps3rt
1773             eps3der=evdwij*eps2rt
1774             fac_augm=rrij**expon
1775             e_augm=augm(itypi,itypj)*fac_augm
1776             evdwij=evdwij*eps2rt*eps3rt
1777             evdw=evdw+evdwij+e_augm
1778             if (lprn) then
1779             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1780             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1781             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1782      &        restyp(itypi),i,restyp(itypj),j,
1783      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1784      &        chi1,chi2,chip1,chip2,
1785      &        eps1,eps2rt**2,eps3rt**2,
1786      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1787      &        evdwij+e_augm
1788             endif
1789 C Calculate gradient components.
1790             e1=e1*eps1*eps2rt**2*eps3rt**2
1791             fac=-expon*(e1+evdwij)*rij_shift
1792             sigder=fac*sigder
1793             fac=rij*fac-2*expon*rrij*e_augm
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799             call sc_grad
1800           enddo      ! j
1801         enddo        ! iint
1802       enddo          ! i
1803       end
1804 C-----------------------------------------------------------------------------
1805       subroutine sc_angular
1806 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1807 C om12. Called by ebp, egb, and egbv.
1808       implicit none
1809       include 'COMMON.CALC'
1810       include 'COMMON.IOUNITS'
1811       erij(1)=xj*rij
1812       erij(2)=yj*rij
1813       erij(3)=zj*rij
1814       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1815       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1816       om12=dxi*dxj+dyi*dyj+dzi*dzj
1817       chiom12=chi12*om12
1818 C Calculate eps1(om12) and its derivative in om12
1819       faceps1=1.0D0-om12*chiom12
1820       faceps1_inv=1.0D0/faceps1
1821       eps1=dsqrt(faceps1_inv)
1822 C Following variable is eps1*deps1/dom12
1823       eps1_om12=faceps1_inv*chiom12
1824 c diagnostics only
1825 c      faceps1_inv=om12
1826 c      eps1=om12
1827 c      eps1_om12=1.0d0
1828 c      write (iout,*) "om12",om12," eps1",eps1
1829 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1830 C and om12.
1831       om1om2=om1*om2
1832       chiom1=chi1*om1
1833       chiom2=chi2*om2
1834       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1835       sigsq=1.0D0-facsig*faceps1_inv
1836       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1837       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1838       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1839 c diagnostics only
1840 c      sigsq=1.0d0
1841 c      sigsq_om1=0.0d0
1842 c      sigsq_om2=0.0d0
1843 c      sigsq_om12=0.0d0
1844 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1845 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1846 c     &    " eps1",eps1
1847 C Calculate eps2 and its derivatives in om1, om2, and om12.
1848       chipom1=chip1*om1
1849       chipom2=chip2*om2
1850       chipom12=chip12*om12
1851       facp=1.0D0-om12*chipom12
1852       facp_inv=1.0D0/facp
1853       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1854 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1855 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1856 C Following variable is the square root of eps2
1857       eps2rt=1.0D0-facp1*facp_inv
1858 C Following three variables are the derivatives of the square root of eps
1859 C in om1, om2, and om12.
1860       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1861       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1862       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1863 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1864       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1865 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1866 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1867 c     &  " eps2rt_om12",eps2rt_om12
1868 C Calculate whole angle-dependent part of epsilon and contributions
1869 C to its derivatives
1870       return
1871       end
1872 C----------------------------------------------------------------------------
1873       subroutine sc_grad
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CHAIN'
1877       include 'COMMON.DERIV'
1878       include 'COMMON.CALC'
1879       include 'COMMON.IOUNITS'
1880       double precision dcosom1(3),dcosom2(3)
1881 cc      print *,'sss=',sss
1882       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1883       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1884       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1885      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1886 c diagnostics only
1887 c      eom1=0.0d0
1888 c      eom2=0.0d0
1889 c      eom12=evdwij*eps1_om12
1890 c end diagnostics
1891 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1892 c     &  " sigder",sigder
1893 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1894 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1895       do k=1,3
1896         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1897         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1898       enddo
1899       do k=1,3
1900         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1901       enddo
1902 c      write (iout,*) "gg",(gg(k),k=1,3)
1903       do k=1,3
1904         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1905      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1906      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1907         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1908      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1909      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1910 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1911 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1912 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914       enddo
1915 C
1916 C Calculate the components of the gradient in DC and X
1917 C
1918 cgrad      do k=i,j-1
1919 cgrad        do l=1,3
1920 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1921 cgrad        enddo
1922 cgrad      enddo
1923       do l=1,3
1924         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1925         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1926       enddo
1927       return
1928       end
1929 C-----------------------------------------------------------------------
1930       subroutine e_softsphere(evdw)
1931 C
1932 C This subroutine calculates the interaction energy of nonbonded side chains
1933 C assuming the LJ potential of interaction.
1934 C
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937       parameter (accur=1.0d-10)
1938       include 'COMMON.GEO'
1939       include 'COMMON.VAR'
1940       include 'COMMON.LOCAL'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.INTERACT'
1944       include 'COMMON.TORSION'
1945       include 'COMMON.SBRIDGE'
1946       include 'COMMON.NAMES'
1947       include 'COMMON.IOUNITS'
1948       include 'COMMON.CONTACTS'
1949       dimension gg(3)
1950 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1951       evdw=0.0D0
1952       do i=iatsc_s,iatsc_e
1953         itypi=iabs(itype(i))
1954         if (itypi.eq.ntyp1) cycle
1955         itypi1=iabs(itype(i+1))
1956         xi=c(1,nres+i)
1957         yi=c(2,nres+i)
1958         zi=c(3,nres+i)
1959 C
1960 C Calculate SC interaction energy.
1961 C
1962         do iint=1,nint_gr(i)
1963 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1964 cd   &                  'iend=',iend(i,iint)
1965           do j=istart(i,iint),iend(i,iint)
1966             itypj=iabs(itype(j))
1967             if (itypj.eq.ntyp1) cycle
1968             xj=c(1,nres+j)-xi
1969             yj=c(2,nres+j)-yi
1970             zj=c(3,nres+j)-zi
1971             rij=xj*xj+yj*yj+zj*zj
1972 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1973             r0ij=r0(itypi,itypj)
1974             r0ijsq=r0ij*r0ij
1975 c            print *,i,j,r0ij,dsqrt(rij)
1976             if (rij.lt.r0ijsq) then
1977               evdwij=0.25d0*(rij-r0ijsq)**2
1978               fac=rij-r0ijsq
1979             else
1980               evdwij=0.0d0
1981               fac=0.0d0
1982             endif
1983             evdw=evdw+evdwij
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987             gg(1)=xj*fac
1988             gg(2)=yj*fac
1989             gg(3)=zj*fac
1990             do k=1,3
1991               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1992               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1993               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1994               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1995             enddo
1996 cgrad            do k=i,j-1
1997 cgrad              do l=1,3
1998 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1999 cgrad              enddo
2000 cgrad            enddo
2001           enddo ! j
2002         enddo ! iint
2003       enddo ! i
2004       return
2005       end
2006 C--------------------------------------------------------------------------
2007       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2008      &              eello_turn4)
2009 C
2010 C Soft-sphere potential of p-p interaction
2011 C
2012       implicit real*8 (a-h,o-z)
2013       include 'DIMENSIONS'
2014       include 'COMMON.CONTROL'
2015       include 'COMMON.IOUNITS'
2016       include 'COMMON.GEO'
2017       include 'COMMON.VAR'
2018       include 'COMMON.LOCAL'
2019       include 'COMMON.CHAIN'
2020       include 'COMMON.DERIV'
2021       include 'COMMON.INTERACT'
2022       include 'COMMON.CONTACTS'
2023       include 'COMMON.TORSION'
2024       include 'COMMON.VECTORS'
2025       include 'COMMON.FFIELD'
2026       dimension ggg(3)
2027 C      write(iout,*) 'In EELEC_soft_sphere'
2028       ees=0.0D0
2029       evdw1=0.0D0
2030       eel_loc=0.0d0
2031       eello_turn3=0.0d0
2032       eello_turn4=0.0d0
2033       ind=0
2034       do i=iatel_s,iatel_e
2035         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2036         dxi=dc(1,i)
2037         dyi=dc(2,i)
2038         dzi=dc(3,i)
2039         xmedi=c(1,i)+0.5d0*dxi
2040         ymedi=c(2,i)+0.5d0*dyi
2041         zmedi=c(3,i)+0.5d0*dzi
2042           xmedi=mod(xmedi,boxxsize)
2043           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2044           ymedi=mod(ymedi,boxysize)
2045           if (ymedi.lt.0) ymedi=ymedi+boxysize
2046           zmedi=mod(zmedi,boxzsize)
2047           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2048         num_conti=0
2049 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2050         do j=ielstart(i),ielend(i)
2051           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2052           ind=ind+1
2053           iteli=itel(i)
2054           itelj=itel(j)
2055           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2056           r0ij=rpp(iteli,itelj)
2057           r0ijsq=r0ij*r0ij
2058           dxj=dc(1,j)
2059           dyj=dc(2,j)
2060           dzj=dc(3,j)
2061           xj=c(1,j)+0.5D0*dxj
2062           yj=c(2,j)+0.5D0*dyj
2063           zj=c(3,j)+0.5D0*dzj
2064           xj=mod(xj,boxxsize)
2065           if (xj.lt.0) xj=xj+boxxsize
2066           yj=mod(yj,boxysize)
2067           if (yj.lt.0) yj=yj+boxysize
2068           zj=mod(zj,boxzsize)
2069           if (zj.lt.0) zj=zj+boxzsize
2070       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2071       xj_safe=xj
2072       yj_safe=yj
2073       zj_safe=zj
2074       isubchap=0
2075       do xshift=-1,1
2076       do yshift=-1,1
2077       do zshift=-1,1
2078           xj=xj_safe+xshift*boxxsize
2079           yj=yj_safe+yshift*boxysize
2080           zj=zj_safe+zshift*boxzsize
2081           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2082           if(dist_temp.lt.dist_init) then
2083             dist_init=dist_temp
2084             xj_temp=xj
2085             yj_temp=yj
2086             zj_temp=zj
2087             isubchap=1
2088           endif
2089        enddo
2090        enddo
2091        enddo
2092        if (isubchap.eq.1) then
2093           xj=xj_temp-xmedi
2094           yj=yj_temp-ymedi
2095           zj=zj_temp-zmedi
2096        else
2097           xj=xj_safe-xmedi
2098           yj=yj_safe-ymedi
2099           zj=zj_safe-zmedi
2100        endif
2101           rij=xj*xj+yj*yj+zj*zj
2102             sss=sscale(sqrt(rij))
2103             sssgrad=sscagrad(sqrt(rij))
2104           if (rij.lt.r0ijsq) then
2105             evdw1ij=0.25d0*(rij-r0ijsq)**2
2106             fac=rij-r0ijsq
2107           else
2108             evdw1ij=0.0d0
2109             fac=0.0d0
2110           endif
2111           evdw1=evdw1+evdw1ij*sss
2112 C
2113 C Calculate contributions to the Cartesian gradient.
2114 C
2115           ggg(1)=fac*xj*sssgrad
2116           ggg(2)=fac*yj*sssgrad
2117           ggg(3)=fac*zj*sssgrad
2118           do k=1,3
2119             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2120             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2121           enddo
2122 *
2123 * Loop over residues i+1 thru j-1.
2124 *
2125 cgrad          do k=i+1,j-1
2126 cgrad            do l=1,3
2127 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2128 cgrad            enddo
2129 cgrad          enddo
2130         enddo ! j
2131       enddo   ! i
2132 cgrad      do i=nnt,nct-1
2133 cgrad        do k=1,3
2134 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2135 cgrad        enddo
2136 cgrad        do j=i+1,nct-1
2137 cgrad          do k=1,3
2138 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2139 cgrad          enddo
2140 cgrad        enddo
2141 cgrad      enddo
2142       return
2143       end
2144 c------------------------------------------------------------------------------
2145       subroutine vec_and_deriv
2146       implicit real*8 (a-h,o-z)
2147       include 'DIMENSIONS'
2148 #ifdef MPI
2149       include 'mpif.h'
2150 #endif
2151       include 'COMMON.IOUNITS'
2152       include 'COMMON.GEO'
2153       include 'COMMON.VAR'
2154       include 'COMMON.LOCAL'
2155       include 'COMMON.CHAIN'
2156       include 'COMMON.VECTORS'
2157       include 'COMMON.SETUP'
2158       include 'COMMON.TIME1'
2159       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2160 C Compute the local reference systems. For reference system (i), the
2161 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2162 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2163 #ifdef PARVEC
2164       do i=ivec_start,ivec_end
2165 #else
2166       do i=1,nres-1
2167 #endif
2168           if (i.eq.nres-1) then
2169 C Case of the last full residue
2170 C Compute the Z-axis
2171             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2172             costh=dcos(pi-theta(nres))
2173             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2174             do k=1,3
2175               uz(k,i)=fac*uz(k,i)
2176             enddo
2177 C Compute the derivatives of uz
2178             uzder(1,1,1)= 0.0d0
2179             uzder(2,1,1)=-dc_norm(3,i-1)
2180             uzder(3,1,1)= dc_norm(2,i-1)
2181             uzder(1,2,1)= dc_norm(3,i-1)
2182             uzder(2,2,1)= 0.0d0
2183             uzder(3,2,1)=-dc_norm(1,i-1)
2184             uzder(1,3,1)=-dc_norm(2,i-1)
2185             uzder(2,3,1)= dc_norm(1,i-1)
2186             uzder(3,3,1)= 0.0d0
2187             uzder(1,1,2)= 0.0d0
2188             uzder(2,1,2)= dc_norm(3,i)
2189             uzder(3,1,2)=-dc_norm(2,i)
2190             uzder(1,2,2)=-dc_norm(3,i)
2191             uzder(2,2,2)= 0.0d0
2192             uzder(3,2,2)= dc_norm(1,i)
2193             uzder(1,3,2)= dc_norm(2,i)
2194             uzder(2,3,2)=-dc_norm(1,i)
2195             uzder(3,3,2)= 0.0d0
2196 C Compute the Y-axis
2197             facy=fac
2198             do k=1,3
2199               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2200             enddo
2201 C Compute the derivatives of uy
2202             do j=1,3
2203               do k=1,3
2204                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2205      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2206                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2207               enddo
2208               uyder(j,j,1)=uyder(j,j,1)-costh
2209               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2210             enddo
2211             do j=1,2
2212               do k=1,3
2213                 do l=1,3
2214                   uygrad(l,k,j,i)=uyder(l,k,j)
2215                   uzgrad(l,k,j,i)=uzder(l,k,j)
2216                 enddo
2217               enddo
2218             enddo
2219             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2220             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2221             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2222             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2223           else
2224 C Other residues
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2227             costh=dcos(pi-theta(i+2))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i+1)
2235             uzder(3,1,1)= dc_norm(2,i+1)
2236             uzder(1,2,1)= dc_norm(3,i+1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i+1)
2239             uzder(1,3,1)=-dc_norm(2,i+1)
2240             uzder(2,3,1)= dc_norm(1,i+1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           endif
2279       enddo
2280       do i=1,nres-1
2281         vbld_inv_temp(1)=vbld_inv(i+1)
2282         if (i.lt.nres-1) then
2283           vbld_inv_temp(2)=vbld_inv(i+2)
2284           else
2285           vbld_inv_temp(2)=vbld_inv(i)
2286           endif
2287         do j=1,2
2288           do k=1,3
2289             do l=1,3
2290               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2291               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2292             enddo
2293           enddo
2294         enddo
2295       enddo
2296 #if defined(PARVEC) && defined(MPI)
2297       if (nfgtasks1.gt.1) then
2298         time00=MPI_Wtime()
2299 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2300 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2301 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2302         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2303      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2304      &   FG_COMM1,IERR)
2305         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2306      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2307      &   FG_COMM1,IERR)
2308         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2309      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2310      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2311         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2312      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2313      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2314         time_gather=time_gather+MPI_Wtime()-time00
2315       endif
2316 c      if (fg_rank.eq.0) then
2317 c        write (iout,*) "Arrays UY and UZ"
2318 c        do i=1,nres-1
2319 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2320 c     &     (uz(k,i),k=1,3)
2321 c        enddo
2322 c      endif
2323 #endif
2324       return
2325       end
2326 C-----------------------------------------------------------------------------
2327       subroutine check_vecgrad
2328       implicit real*8 (a-h,o-z)
2329       include 'DIMENSIONS'
2330       include 'COMMON.IOUNITS'
2331       include 'COMMON.GEO'
2332       include 'COMMON.VAR'
2333       include 'COMMON.LOCAL'
2334       include 'COMMON.CHAIN'
2335       include 'COMMON.VECTORS'
2336       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2337       dimension uyt(3,maxres),uzt(3,maxres)
2338       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2339       double precision delta /1.0d-7/
2340       call vec_and_deriv
2341 cd      do i=1,nres
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2344 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2345 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2346 cd     &     (dc_norm(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2348 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2349 cd          write(iout,'(a)')
2350 cd      enddo
2351       do i=1,nres
2352         do j=1,2
2353           do k=1,3
2354             do l=1,3
2355               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2356               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2357             enddo
2358           enddo
2359         enddo
2360       enddo
2361       call vec_and_deriv
2362       do i=1,nres
2363         do j=1,3
2364           uyt(j,i)=uy(j,i)
2365           uzt(j,i)=uz(j,i)
2366         enddo
2367       enddo
2368       do i=1,nres
2369 cd        write (iout,*) 'i=',i
2370         do k=1,3
2371           erij(k)=dc_norm(k,i)
2372         enddo
2373         do j=1,3
2374           do k=1,3
2375             dc_norm(k,i)=erij(k)
2376           enddo
2377           dc_norm(j,i)=dc_norm(j,i)+delta
2378 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2379 c          do k=1,3
2380 c            dc_norm(k,i)=dc_norm(k,i)/fac
2381 c          enddo
2382 c          write (iout,*) (dc_norm(k,i),k=1,3)
2383 c          write (iout,*) (erij(k),k=1,3)
2384           call vec_and_deriv
2385           do k=1,3
2386             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2387             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2388             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2389             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2390           enddo
2391 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2392 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2393 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2394         enddo
2395         do k=1,3
2396           dc_norm(k,i)=erij(k)
2397         enddo
2398 cd        do k=1,3
2399 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2400 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2401 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2402 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2403 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2404 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2405 cd          write (iout,'(a)')
2406 cd        enddo
2407       enddo
2408       return
2409       end
2410 C--------------------------------------------------------------------------
2411       subroutine set_matrices
2412       implicit real*8 (a-h,o-z)
2413       include 'DIMENSIONS'
2414 #ifdef MPI
2415       include "mpif.h"
2416       include "COMMON.SETUP"
2417       integer IERR
2418       integer status(MPI_STATUS_SIZE)
2419 #endif
2420       include 'COMMON.IOUNITS'
2421       include 'COMMON.GEO'
2422       include 'COMMON.VAR'
2423       include 'COMMON.LOCAL'
2424       include 'COMMON.CHAIN'
2425       include 'COMMON.DERIV'
2426       include 'COMMON.INTERACT'
2427       include 'COMMON.CONTACTS'
2428       include 'COMMON.TORSION'
2429       include 'COMMON.VECTORS'
2430       include 'COMMON.FFIELD'
2431       double precision auxvec(2),auxmat(2,2)
2432 C
2433 C Compute the virtual-bond-torsional-angle dependent quantities needed
2434 C to calculate the el-loc multibody terms of various order.
2435 C
2436 c      write(iout,*) 'nphi=',nphi,nres
2437 #ifdef PARMAT
2438       do i=ivec_start+2,ivec_end+2
2439 #else
2440       do i=3,nres+1
2441 #endif
2442 #ifdef NEWCORR
2443         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2444           iti = itortyp(itype(i-2))
2445         else
2446           iti=ntortyp+1
2447         endif
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           iti1 = itortyp(itype(i-1))
2451         else
2452           iti1=ntortyp+1
2453         endif
2454 c        write(iout,*),i
2455         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2456      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2457      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2458         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2459      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2460      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2461 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2462 c     &*(cos(theta(i)/2.0)
2463         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2464      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2465      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2466 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2467 c     &*(cos(theta(i)/2.0)
2468         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2469      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2470      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2471 c        if (ggb1(1,i).eq.0.0d0) then
2472 c        write(iout,*) 'i=',i,ggb1(1,i),
2473 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2474 c     &bnew1(2,1,iti)*cos(theta(i)),
2475 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2476 c        endif
2477         b1(2,i-2)=bnew1(1,2,iti)
2478         gtb1(2,i-2)=0.0
2479         b2(2,i-2)=bnew2(1,2,iti)
2480         gtb2(2,i-2)=0.0
2481         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2482         EE(1,2,i-2)=eeold(1,2,iti)
2483         EE(2,1,i-2)=eeold(2,1,iti)
2484         EE(2,2,i-2)=eeold(2,2,iti)
2485         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2486         gtEE(1,2,i-2)=0.0d0
2487         gtEE(2,2,i-2)=0.0d0
2488         gtEE(2,1,i-2)=0.0d0
2489 c        EE(2,2,iti)=0.0d0
2490 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2491 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2492 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2493 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2494        b1tilde(1,i-2)=b1(1,i-2)
2495        b1tilde(2,i-2)=-b1(2,i-2)
2496        b2tilde(1,i-2)=b2(1,i-2)
2497        b2tilde(2,i-2)=-b2(2,i-2)
2498 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2499 c       write(iout,*)  'b1=',b1(1,i-2)
2500 c       write (iout,*) 'theta=', theta(i-1)
2501        enddo
2502 #ifdef PARMAT
2503       do i=ivec_start+2,ivec_end+2
2504 #else
2505       do i=3,nres+1
2506 #endif
2507 #endif
2508         if (i .lt. nres+1) then
2509           sin1=dsin(phi(i))
2510           cos1=dcos(phi(i))
2511           sintab(i-2)=sin1
2512           costab(i-2)=cos1
2513           obrot(1,i-2)=cos1
2514           obrot(2,i-2)=sin1
2515           sin2=dsin(2*phi(i))
2516           cos2=dcos(2*phi(i))
2517           sintab2(i-2)=sin2
2518           costab2(i-2)=cos2
2519           obrot2(1,i-2)=cos2
2520           obrot2(2,i-2)=sin2
2521           Ug(1,1,i-2)=-cos1
2522           Ug(1,2,i-2)=-sin1
2523           Ug(2,1,i-2)=-sin1
2524           Ug(2,2,i-2)= cos1
2525           Ug2(1,1,i-2)=-cos2
2526           Ug2(1,2,i-2)=-sin2
2527           Ug2(2,1,i-2)=-sin2
2528           Ug2(2,2,i-2)= cos2
2529         else
2530           costab(i-2)=1.0d0
2531           sintab(i-2)=0.0d0
2532           obrot(1,i-2)=1.0d0
2533           obrot(2,i-2)=0.0d0
2534           obrot2(1,i-2)=0.0d0
2535           obrot2(2,i-2)=0.0d0
2536           Ug(1,1,i-2)=1.0d0
2537           Ug(1,2,i-2)=0.0d0
2538           Ug(2,1,i-2)=0.0d0
2539           Ug(2,2,i-2)=1.0d0
2540           Ug2(1,1,i-2)=0.0d0
2541           Ug2(1,2,i-2)=0.0d0
2542           Ug2(2,1,i-2)=0.0d0
2543           Ug2(2,2,i-2)=0.0d0
2544         endif
2545         if (i .gt. 3 .and. i .lt. nres+1) then
2546           obrot_der(1,i-2)=-sin1
2547           obrot_der(2,i-2)= cos1
2548           Ugder(1,1,i-2)= sin1
2549           Ugder(1,2,i-2)=-cos1
2550           Ugder(2,1,i-2)=-cos1
2551           Ugder(2,2,i-2)=-sin1
2552           dwacos2=cos2+cos2
2553           dwasin2=sin2+sin2
2554           obrot2_der(1,i-2)=-dwasin2
2555           obrot2_der(2,i-2)= dwacos2
2556           Ug2der(1,1,i-2)= dwasin2
2557           Ug2der(1,2,i-2)=-dwacos2
2558           Ug2der(2,1,i-2)=-dwacos2
2559           Ug2der(2,2,i-2)=-dwasin2
2560         else
2561           obrot_der(1,i-2)=0.0d0
2562           obrot_der(2,i-2)=0.0d0
2563           Ugder(1,1,i-2)=0.0d0
2564           Ugder(1,2,i-2)=0.0d0
2565           Ugder(2,1,i-2)=0.0d0
2566           Ugder(2,2,i-2)=0.0d0
2567           obrot2_der(1,i-2)=0.0d0
2568           obrot2_der(2,i-2)=0.0d0
2569           Ug2der(1,1,i-2)=0.0d0
2570           Ug2der(1,2,i-2)=0.0d0
2571           Ug2der(2,1,i-2)=0.0d0
2572           Ug2der(2,2,i-2)=0.0d0
2573         endif
2574 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2575         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2576           iti = itortyp(itype(i-2))
2577         else
2578           iti=ntortyp
2579         endif
2580 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2581         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2582           iti1 = itortyp(itype(i-1))
2583         else
2584           iti1=ntortyp
2585         endif
2586 cd        write (iout,*) '*******i',i,' iti1',iti
2587 cd        write (iout,*) 'b1',b1(:,iti)
2588 cd        write (iout,*) 'b2',b2(:,iti)
2589 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2590 c        if (i .gt. iatel_s+2) then
2591         if (i .gt. nnt+2) then
2592           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2593 #ifdef NEWCORR
2594           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2595 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2596 #endif
2597 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2598 c     &    EE(1,2,iti),EE(2,2,iti)
2599           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2600           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2601 c          write(iout,*) "Macierz EUG",
2602 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2603 c     &    eug(2,2,i-2)
2604           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2605      &    then
2606           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2607           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2608           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2609           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2610           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2611           endif
2612         else
2613           do k=1,2
2614             Ub2(k,i-2)=0.0d0
2615             Ctobr(k,i-2)=0.0d0
2616             Dtobr2(k,i-2)=0.0d0
2617             do l=1,2
2618               EUg(l,k,i-2)=0.0d0
2619               CUg(l,k,i-2)=0.0d0
2620               DUg(l,k,i-2)=0.0d0
2621               DtUg2(l,k,i-2)=0.0d0
2622             enddo
2623           enddo
2624         endif
2625         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2626         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2627         do k=1,2
2628           muder(k,i-2)=Ub2der(k,i-2)
2629         enddo
2630 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2631         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2632           if (itype(i-1).le.ntyp) then
2633             iti1 = itortyp(itype(i-1))
2634           else
2635             iti1=ntortyp
2636           endif
2637         else
2638           iti1=ntortyp
2639         endif
2640         do k=1,2
2641           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2642         enddo
2643 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2644 cd        write (iout,*) 'mu1',mu1(:,i-2)
2645 cd        write (iout,*) 'mu2',mu2(:,i-2)
2646         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2647      &  then
2648         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2649         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2650         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2651         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2652         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2653 C Vectors and matrices dependent on a single virtual-bond dihedral.
2654         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2655         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2656         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2657         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2658         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2659         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2660         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2661         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2662         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2663         endif
2664       enddo
2665 C Matrices dependent on two consecutive virtual-bond dihedrals.
2666 C The order of matrices is from left to right.
2667       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2668      &then
2669 c      do i=max0(ivec_start,2),ivec_end
2670       do i=2,nres-1
2671         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2672         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2673         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2674         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2675         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2676         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2677         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2678         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2679       enddo
2680       endif
2681 #if defined(MPI) && defined(PARMAT)
2682 #ifdef DEBUG
2683 c      if (fg_rank.eq.0) then
2684         write (iout,*) "Arrays UG and UGDER before GATHER"
2685         do i=1,nres-1
2686           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2687      &     ((ug(l,k,i),l=1,2),k=1,2),
2688      &     ((ugder(l,k,i),l=1,2),k=1,2)
2689         enddo
2690         write (iout,*) "Arrays UG2 and UG2DER"
2691         do i=1,nres-1
2692           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2693      &     ((ug2(l,k,i),l=1,2),k=1,2),
2694      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2695         enddo
2696         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2697         do i=1,nres-1
2698           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2699      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2700      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2701         enddo
2702         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2703         do i=1,nres-1
2704           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2705      &     costab(i),sintab(i),costab2(i),sintab2(i)
2706         enddo
2707         write (iout,*) "Array MUDER"
2708         do i=1,nres-1
2709           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2710         enddo
2711 c      endif
2712 #endif
2713       if (nfgtasks.gt.1) then
2714         time00=MPI_Wtime()
2715 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2716 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2717 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2718 #ifdef MATGATHER
2719         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2724      &   FG_COMM1,IERR)
2725         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2736      &   FG_COMM1,IERR)
2737         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2738      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2739      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2740         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2741      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2742      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2743         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2744      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2745      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2746         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2747      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2748      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2749         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2750      &  then
2751         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2758      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2759      &   FG_COMM1,IERR)
2760        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2761      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2762      &   FG_COMM1,IERR)
2763         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2764      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2765      &   FG_COMM1,IERR)
2766         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2767      &   ivec_count(fg_rank1),
2768      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2769      &   FG_COMM1,IERR)
2770         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2774      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2775      &   FG_COMM1,IERR)
2776         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2777      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2778      &   FG_COMM1,IERR)
2779         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2780      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2781      &   FG_COMM1,IERR)
2782         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2783      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2784      &   FG_COMM1,IERR)
2785         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2786      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2789      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2790      &   FG_COMM1,IERR)
2791         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2792      &   ivec_count(fg_rank1),
2793      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2794      &   FG_COMM1,IERR)
2795         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2796      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2797      &   FG_COMM1,IERR)
2798        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2799      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2800      &   FG_COMM1,IERR)
2801         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2802      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2803      &   FG_COMM1,IERR)
2804        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2808      &   ivec_count(fg_rank1),
2809      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2810      &   FG_COMM1,IERR)
2811         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2812      &   ivec_count(fg_rank1),
2813      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2816      &   ivec_count(fg_rank1),
2817      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2818      &   MPI_MAT2,FG_COMM1,IERR)
2819         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2820      &   ivec_count(fg_rank1),
2821      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2822      &   MPI_MAT2,FG_COMM1,IERR)
2823         endif
2824 #else
2825 c Passes matrix info through the ring
2826       isend=fg_rank1
2827       irecv=fg_rank1-1
2828       if (irecv.lt.0) irecv=nfgtasks1-1
2829       iprev=irecv
2830       inext=fg_rank1+1
2831       if (inext.ge.nfgtasks1) inext=0
2832       do i=1,nfgtasks1-1
2833 c        write (iout,*) "isend",isend," irecv",irecv
2834 c        call flush(iout)
2835         lensend=lentyp(isend)
2836         lenrecv=lentyp(irecv)
2837 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2838 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2839 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2840 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2841 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2842 c        write (iout,*) "Gather ROTAT1"
2843 c        call flush(iout)
2844 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2845 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2846 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2847 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2848 c        write (iout,*) "Gather ROTAT2"
2849 c        call flush(iout)
2850         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2851      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2852      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2853      &   iprev,4400+irecv,FG_COMM,status,IERR)
2854 c        write (iout,*) "Gather ROTAT_OLD"
2855 c        call flush(iout)
2856         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2857      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2858      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2859      &   iprev,5500+irecv,FG_COMM,status,IERR)
2860 c        write (iout,*) "Gather PRECOMP11"
2861 c        call flush(iout)
2862         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2863      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2864      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2865      &   iprev,6600+irecv,FG_COMM,status,IERR)
2866 c        write (iout,*) "Gather PRECOMP12"
2867 c        call flush(iout)
2868         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2869      &  then
2870         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2871      &   MPI_ROTAT2(lensend),inext,7700+isend,
2872      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2873      &   iprev,7700+irecv,FG_COMM,status,IERR)
2874 c        write (iout,*) "Gather PRECOMP21"
2875 c        call flush(iout)
2876         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2877      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2878      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2879      &   iprev,8800+irecv,FG_COMM,status,IERR)
2880 c        write (iout,*) "Gather PRECOMP22"
2881 c        call flush(iout)
2882         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2883      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2884      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2885      &   MPI_PRECOMP23(lenrecv),
2886      &   iprev,9900+irecv,FG_COMM,status,IERR)
2887 c        write (iout,*) "Gather PRECOMP23"
2888 c        call flush(iout)
2889         endif
2890         isend=irecv
2891         irecv=irecv-1
2892         if (irecv.lt.0) irecv=nfgtasks1-1
2893       enddo
2894 #endif
2895         time_gather=time_gather+MPI_Wtime()-time00
2896       endif
2897 #ifdef DEBUG
2898 c      if (fg_rank.eq.0) then
2899         write (iout,*) "Arrays UG and UGDER"
2900         do i=1,nres-1
2901           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2902      &     ((ug(l,k,i),l=1,2),k=1,2),
2903      &     ((ugder(l,k,i),l=1,2),k=1,2)
2904         enddo
2905         write (iout,*) "Arrays UG2 and UG2DER"
2906         do i=1,nres-1
2907           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2908      &     ((ug2(l,k,i),l=1,2),k=1,2),
2909      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2910         enddo
2911         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2912         do i=1,nres-1
2913           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2914      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2915      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2916         enddo
2917         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2918         do i=1,nres-1
2919           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2920      &     costab(i),sintab(i),costab2(i),sintab2(i)
2921         enddo
2922         write (iout,*) "Array MUDER"
2923         do i=1,nres-1
2924           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2925         enddo
2926 c      endif
2927 #endif
2928 #endif
2929 cd      do i=1,nres
2930 cd        iti = itortyp(itype(i))
2931 cd        write (iout,*) i
2932 cd        do j=1,2
2933 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2934 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2935 cd        enddo
2936 cd      enddo
2937       return
2938       end
2939 C--------------------------------------------------------------------------
2940       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2941 C
2942 C This subroutine calculates the average interaction energy and its gradient
2943 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2944 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2945 C The potential depends both on the distance of peptide-group centers and on
2946 C the orientation of the CA-CA virtual bonds.
2947 C
2948       implicit real*8 (a-h,o-z)
2949 #ifdef MPI
2950       include 'mpif.h'
2951 #endif
2952       include 'DIMENSIONS'
2953       include 'COMMON.CONTROL'
2954       include 'COMMON.SETUP'
2955       include 'COMMON.IOUNITS'
2956       include 'COMMON.GEO'
2957       include 'COMMON.VAR'
2958       include 'COMMON.LOCAL'
2959       include 'COMMON.CHAIN'
2960       include 'COMMON.DERIV'
2961       include 'COMMON.INTERACT'
2962       include 'COMMON.CONTACTS'
2963       include 'COMMON.TORSION'
2964       include 'COMMON.VECTORS'
2965       include 'COMMON.FFIELD'
2966       include 'COMMON.TIME1'
2967       include 'COMMON.SPLITELE'
2968       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2969      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2970       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2971      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2972       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2973      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2974      &    num_conti,j1,j2
2975 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2976 #ifdef MOMENT
2977       double precision scal_el /1.0d0/
2978 #else
2979       double precision scal_el /0.5d0/
2980 #endif
2981 C 12/13/98
2982 C 13-go grudnia roku pamietnego...
2983       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2984      &                   0.0d0,1.0d0,0.0d0,
2985      &                   0.0d0,0.0d0,1.0d0/
2986 cd      write(iout,*) 'In EELEC'
2987 cd      do i=1,nloctyp
2988 cd        write(iout,*) 'Type',i
2989 cd        write(iout,*) 'B1',B1(:,i)
2990 cd        write(iout,*) 'B2',B2(:,i)
2991 cd        write(iout,*) 'CC',CC(:,:,i)
2992 cd        write(iout,*) 'DD',DD(:,:,i)
2993 cd        write(iout,*) 'EE',EE(:,:,i)
2994 cd      enddo
2995 cd      call check_vecgrad
2996 cd      stop
2997       if (icheckgrad.eq.1) then
2998         do i=1,nres-1
2999           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3000           do k=1,3
3001             dc_norm(k,i)=dc(k,i)*fac
3002           enddo
3003 c          write (iout,*) 'i',i,' fac',fac
3004         enddo
3005       endif
3006       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3007      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3008      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3009 c        call vec_and_deriv
3010 #ifdef TIMING
3011         time01=MPI_Wtime()
3012 #endif
3013         call set_matrices
3014 #ifdef TIMING
3015         time_mat=time_mat+MPI_Wtime()-time01
3016 #endif
3017       endif
3018 cd      do i=1,nres-1
3019 cd        write (iout,*) 'i=',i
3020 cd        do k=1,3
3021 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3022 cd        enddo
3023 cd        do k=1,3
3024 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3025 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3026 cd        enddo
3027 cd      enddo
3028       t_eelecij=0.0d0
3029       ees=0.0D0
3030       evdw1=0.0D0
3031       eel_loc=0.0d0
3032       eello_turn3=0.0d0
3033       eello_turn4=0.0d0
3034       ind=0
3035       do i=1,nres
3036         num_cont_hb(i)=0
3037       enddo
3038 cd      print '(a)','Enter EELEC'
3039 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3040       do i=1,nres
3041         gel_loc_loc(i)=0.0d0
3042         gcorr_loc(i)=0.0d0
3043       enddo
3044 c
3045 c
3046 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3047 C
3048 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3049 C
3050 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3051       do i=iturn3_start,iturn3_end
3052         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3053      &  .or. itype(i+2).eq.ntyp1
3054      &  .or. itype(i+3).eq.ntyp1
3055      &  .or. itype(i-1).eq.ntyp1
3056      &  .or. itype(i+4).eq.ntyp1
3057      &  ) cycle
3058         dxi=dc(1,i)
3059         dyi=dc(2,i)
3060         dzi=dc(3,i)
3061         dx_normi=dc_norm(1,i)
3062         dy_normi=dc_norm(2,i)
3063         dz_normi=dc_norm(3,i)
3064         xmedi=c(1,i)+0.5d0*dxi
3065         ymedi=c(2,i)+0.5d0*dyi
3066         zmedi=c(3,i)+0.5d0*dzi
3067           xmedi=mod(xmedi,boxxsize)
3068           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3069           ymedi=mod(ymedi,boxysize)
3070           if (ymedi.lt.0) ymedi=ymedi+boxysize
3071           zmedi=mod(zmedi,boxzsize)
3072           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3073         num_conti=0
3074         call eelecij(i,i+2,ees,evdw1,eel_loc)
3075         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3076         num_cont_hb(i)=num_conti
3077       enddo
3078       do i=iturn4_start,iturn4_end
3079         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3080      &    .or. itype(i+3).eq.ntyp1
3081      &    .or. itype(i+4).eq.ntyp1
3082      &    .or. itype(i+5).eq.ntyp1
3083      &    .or. itype(i).eq.ntyp1
3084      &    .or. itype(i-1).eq.ntyp1
3085      &                             ) cycle
3086         dxi=dc(1,i)
3087         dyi=dc(2,i)
3088         dzi=dc(3,i)
3089         dx_normi=dc_norm(1,i)
3090         dy_normi=dc_norm(2,i)
3091         dz_normi=dc_norm(3,i)
3092         xmedi=c(1,i)+0.5d0*dxi
3093         ymedi=c(2,i)+0.5d0*dyi
3094         zmedi=c(3,i)+0.5d0*dzi
3095 C Return atom into box, boxxsize is size of box in x dimension
3096 c  194   continue
3097 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3098 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3099 C Condition for being inside the proper box
3100 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3101 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3102 c        go to 194
3103 c        endif
3104 c  195   continue
3105 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3106 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3107 C Condition for being inside the proper box
3108 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3109 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3110 c        go to 195
3111 c        endif
3112 c  196   continue
3113 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3114 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3115 C Condition for being inside the proper box
3116 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3117 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3118 c        go to 196
3119 c        endif
3120           xmedi=mod(xmedi,boxxsize)
3121           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3122           ymedi=mod(ymedi,boxysize)
3123           if (ymedi.lt.0) ymedi=ymedi+boxysize
3124           zmedi=mod(zmedi,boxzsize)
3125           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3126
3127         num_conti=num_cont_hb(i)
3128 c        write(iout,*) "JESTEM W PETLI"
3129         call eelecij(i,i+3,ees,evdw1,eel_loc)
3130         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3131      &   call eturn4(i,eello_turn4)
3132         num_cont_hb(i)=num_conti
3133       enddo   ! i
3134 C Loop over all neighbouring boxes
3135 C      do xshift=-1,1
3136 C      do yshift=-1,1
3137 C      do zshift=-1,1
3138 c
3139 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3140 c
3141       do i=iatel_s,iatel_e
3142         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3143      &  .or. itype(i+2).eq.ntyp1
3144      &  .or. itype(i-1).eq.ntyp1
3145      &                ) cycle
3146         dxi=dc(1,i)
3147         dyi=dc(2,i)
3148         dzi=dc(3,i)
3149         dx_normi=dc_norm(1,i)
3150         dy_normi=dc_norm(2,i)
3151         dz_normi=dc_norm(3,i)
3152         xmedi=c(1,i)+0.5d0*dxi
3153         ymedi=c(2,i)+0.5d0*dyi
3154         zmedi=c(3,i)+0.5d0*dzi
3155           xmedi=mod(xmedi,boxxsize)
3156           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3157           ymedi=mod(ymedi,boxysize)
3158           if (ymedi.lt.0) ymedi=ymedi+boxysize
3159           zmedi=mod(zmedi,boxzsize)
3160           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3161 C          xmedi=xmedi+xshift*boxxsize
3162 C          ymedi=ymedi+yshift*boxysize
3163 C          zmedi=zmedi+zshift*boxzsize
3164
3165 C Return tom into box, boxxsize is size of box in x dimension
3166 c  164   continue
3167 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3168 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3169 C Condition for being inside the proper box
3170 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3171 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3172 c        go to 164
3173 c        endif
3174 c  165   continue
3175 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3176 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3177 C Condition for being inside the proper box
3178 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3179 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3180 c        go to 165
3181 c        endif
3182 c  166   continue
3183 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3184 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3185 cC Condition for being inside the proper box
3186 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3187 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3188 c        go to 166
3189 c        endif
3190
3191 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3192         num_conti=num_cont_hb(i)
3193         do j=ielstart(i),ielend(i)
3194 c          write (iout,*) i,j,itype(i),itype(j)
3195           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3196      & .or.itype(j+2).eq.ntyp1
3197      & .or.itype(j-1).eq.ntyp1
3198      &) cycle
3199           call eelecij(i,j,ees,evdw1,eel_loc)
3200         enddo ! j
3201         num_cont_hb(i)=num_conti
3202       enddo   ! i
3203 C     enddo   ! zshift
3204 C      enddo   ! yshift
3205 C      enddo   ! xshift
3206
3207 c      write (iout,*) "Number of loop steps in EELEC:",ind
3208 cd      do i=1,nres
3209 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3210 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3211 cd      enddo
3212 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3213 ccc      eel_loc=eel_loc+eello_turn3
3214 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3215       return
3216       end
3217 C-------------------------------------------------------------------------------
3218       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3219       implicit real*8 (a-h,o-z)
3220       include 'DIMENSIONS'
3221 #ifdef MPI
3222       include "mpif.h"
3223 #endif
3224       include 'COMMON.CONTROL'
3225       include 'COMMON.IOUNITS'
3226       include 'COMMON.GEO'
3227       include 'COMMON.VAR'
3228       include 'COMMON.LOCAL'
3229       include 'COMMON.CHAIN'
3230       include 'COMMON.DERIV'
3231       include 'COMMON.INTERACT'
3232       include 'COMMON.CONTACTS'
3233       include 'COMMON.TORSION'
3234       include 'COMMON.VECTORS'
3235       include 'COMMON.FFIELD'
3236       include 'COMMON.TIME1'
3237       include 'COMMON.SPLITELE'
3238       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3239      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3240       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3241      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3242      &    gmuij2(4),gmuji2(4)
3243       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3244      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3245      &    num_conti,j1,j2
3246 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3247 #ifdef MOMENT
3248       double precision scal_el /1.0d0/
3249 #else
3250       double precision scal_el /0.5d0/
3251 #endif
3252 C 12/13/98
3253 C 13-go grudnia roku pamietnego...
3254       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3255      &                   0.0d0,1.0d0,0.0d0,
3256      &                   0.0d0,0.0d0,1.0d0/
3257 c          time00=MPI_Wtime()
3258 cd      write (iout,*) "eelecij",i,j
3259 c          ind=ind+1
3260           iteli=itel(i)
3261           itelj=itel(j)
3262           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3263           aaa=app(iteli,itelj)
3264           bbb=bpp(iteli,itelj)
3265           ael6i=ael6(iteli,itelj)
3266           ael3i=ael3(iteli,itelj)
3267           dxj=dc(1,j)
3268           dyj=dc(2,j)
3269           dzj=dc(3,j)
3270           dx_normj=dc_norm(1,j)
3271           dy_normj=dc_norm(2,j)
3272           dz_normj=dc_norm(3,j)
3273 C          xj=c(1,j)+0.5D0*dxj-xmedi
3274 C          yj=c(2,j)+0.5D0*dyj-ymedi
3275 C          zj=c(3,j)+0.5D0*dzj-zmedi
3276           xj=c(1,j)+0.5D0*dxj
3277           yj=c(2,j)+0.5D0*dyj
3278           zj=c(3,j)+0.5D0*dzj
3279           xj=mod(xj,boxxsize)
3280           if (xj.lt.0) xj=xj+boxxsize
3281           yj=mod(yj,boxysize)
3282           if (yj.lt.0) yj=yj+boxysize
3283           zj=mod(zj,boxzsize)
3284           if (zj.lt.0) zj=zj+boxzsize
3285           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3286       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3287       xj_safe=xj
3288       yj_safe=yj
3289       zj_safe=zj
3290       isubchap=0
3291       do xshift=-1,1
3292       do yshift=-1,1
3293       do zshift=-1,1
3294           xj=xj_safe+xshift*boxxsize
3295           yj=yj_safe+yshift*boxysize
3296           zj=zj_safe+zshift*boxzsize
3297           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3298           if(dist_temp.lt.dist_init) then
3299             dist_init=dist_temp
3300             xj_temp=xj
3301             yj_temp=yj
3302             zj_temp=zj
3303             isubchap=1
3304           endif
3305        enddo
3306        enddo
3307        enddo
3308        if (isubchap.eq.1) then
3309           xj=xj_temp-xmedi
3310           yj=yj_temp-ymedi
3311           zj=zj_temp-zmedi
3312        else
3313           xj=xj_safe-xmedi
3314           yj=yj_safe-ymedi
3315           zj=zj_safe-zmedi
3316        endif
3317 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3318 c  174   continue
3319 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3320 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3321 C Condition for being inside the proper box
3322 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3323 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3324 c        go to 174
3325 c        endif
3326 c  175   continue
3327 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3328 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3329 C Condition for being inside the proper box
3330 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3331 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3332 c        go to 175
3333 c        endif
3334 c  176   continue
3335 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3336 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3337 C Condition for being inside the proper box
3338 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3339 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3340 c        go to 176
3341 c        endif
3342 C        endif !endPBC condintion
3343 C        xj=xj-xmedi
3344 C        yj=yj-ymedi
3345 C        zj=zj-zmedi
3346           rij=xj*xj+yj*yj+zj*zj
3347
3348             sss=sscale(sqrt(rij))
3349             sssgrad=sscagrad(sqrt(rij))
3350 c            if (sss.gt.0.0d0) then
3351           rrmij=1.0D0/rij
3352           rij=dsqrt(rij)
3353           rmij=1.0D0/rij
3354           r3ij=rrmij*rmij
3355           r6ij=r3ij*r3ij
3356           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3357           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3358           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3359           fac=cosa-3.0D0*cosb*cosg
3360           ev1=aaa*r6ij*r6ij
3361 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3362           if (j.eq.i+2) ev1=scal_el*ev1
3363           ev2=bbb*r6ij
3364           fac3=ael6i*r6ij
3365           fac4=ael3i*r3ij
3366           evdwij=(ev1+ev2)
3367           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3368           el2=fac4*fac
3369 C MARYSIA
3370           eesij=(el1+el2)
3371 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3372           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3373           ees=ees+eesij
3374           evdw1=evdw1+evdwij*sss
3375 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3376 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3377 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3378 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3379
3380           if (energy_dec) then
3381               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3382      &'evdw1',i,j,evdwij
3383      &,iteli,itelj,aaa,evdw1
3384               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3385           endif
3386
3387 C
3388 C Calculate contributions to the Cartesian gradient.
3389 C
3390 #ifdef SPLITELE
3391           facvdw=-6*rrmij*(ev1+evdwij)*sss
3392           facel=-3*rrmij*(el1+eesij)
3393           fac1=fac
3394           erij(1)=xj*rmij
3395           erij(2)=yj*rmij
3396           erij(3)=zj*rmij
3397 *
3398 * Radial derivatives. First process both termini of the fragment (i,j)
3399 *
3400           ggg(1)=facel*xj
3401           ggg(2)=facel*yj
3402           ggg(3)=facel*zj
3403 c          do k=1,3
3404 c            ghalf=0.5D0*ggg(k)
3405 c            gelc(k,i)=gelc(k,i)+ghalf
3406 c            gelc(k,j)=gelc(k,j)+ghalf
3407 c          enddo
3408 c 9/28/08 AL Gradient compotents will be summed only at the end
3409           do k=1,3
3410             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3411             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3412           enddo
3413 *
3414 * Loop over residues i+1 thru j-1.
3415 *
3416 cgrad          do k=i+1,j-1
3417 cgrad            do l=1,3
3418 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3419 cgrad            enddo
3420 cgrad          enddo
3421           if (sss.gt.0.0) then
3422           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3423           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3424           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3425           else
3426           ggg(1)=0.0
3427           ggg(2)=0.0
3428           ggg(3)=0.0
3429           endif
3430 c          do k=1,3
3431 c            ghalf=0.5D0*ggg(k)
3432 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3433 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3434 c          enddo
3435 c 9/28/08 AL Gradient compotents will be summed only at the end
3436           do k=1,3
3437             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3438             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3439           enddo
3440 *
3441 * Loop over residues i+1 thru j-1.
3442 *
3443 cgrad          do k=i+1,j-1
3444 cgrad            do l=1,3
3445 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3446 cgrad            enddo
3447 cgrad          enddo
3448 #else
3449 C MARYSIA
3450           facvdw=(ev1+evdwij)*sss
3451           facel=(el1+eesij)
3452           fac1=fac
3453           fac=-3*rrmij*(facvdw+facvdw+facel)
3454           erij(1)=xj*rmij
3455           erij(2)=yj*rmij
3456           erij(3)=zj*rmij
3457 *
3458 * Radial derivatives. First process both termini of the fragment (i,j)
3459 *
3460           ggg(1)=fac*xj
3461           ggg(2)=fac*yj
3462           ggg(3)=fac*zj
3463 c          do k=1,3
3464 c            ghalf=0.5D0*ggg(k)
3465 c            gelc(k,i)=gelc(k,i)+ghalf
3466 c            gelc(k,j)=gelc(k,j)+ghalf
3467 c          enddo
3468 c 9/28/08 AL Gradient compotents will be summed only at the end
3469           do k=1,3
3470             gelc_long(k,j)=gelc(k,j)+ggg(k)
3471             gelc_long(k,i)=gelc(k,i)-ggg(k)
3472           enddo
3473 *
3474 * Loop over residues i+1 thru j-1.
3475 *
3476 cgrad          do k=i+1,j-1
3477 cgrad            do l=1,3
3478 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3479 cgrad            enddo
3480 cgrad          enddo
3481 c 9/28/08 AL Gradient compotents will be summed only at the end
3482           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3483           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3484           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3485           do k=1,3
3486             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3487             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3488           enddo
3489 #endif
3490 *
3491 * Angular part
3492 *
3493           ecosa=2.0D0*fac3*fac1+fac4
3494           fac4=-3.0D0*fac4
3495           fac3=-6.0D0*fac3
3496           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3497           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3498           do k=1,3
3499             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3500             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3501           enddo
3502 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3503 cd   &          (dcosg(k),k=1,3)
3504           do k=1,3
3505             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3506           enddo
3507 c          do k=1,3
3508 c            ghalf=0.5D0*ggg(k)
3509 c            gelc(k,i)=gelc(k,i)+ghalf
3510 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3511 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3512 c            gelc(k,j)=gelc(k,j)+ghalf
3513 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3514 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3515 c          enddo
3516 cgrad          do k=i+1,j-1
3517 cgrad            do l=1,3
3518 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3519 cgrad            enddo
3520 cgrad          enddo
3521           do k=1,3
3522             gelc(k,i)=gelc(k,i)
3523      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3524      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3525             gelc(k,j)=gelc(k,j)
3526      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3527      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3528             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3529             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3530           enddo
3531 C MARYSIA
3532 c          endif !sscale
3533           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3534      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3535      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3536 C
3537 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3538 C   energy of a peptide unit is assumed in the form of a second-order
3539 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3540 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3541 C   are computed for EVERY pair of non-contiguous peptide groups.
3542 C
3543
3544           if (j.lt.nres-1) then
3545             j1=j+1
3546             j2=j-1
3547           else
3548             j1=j-1
3549             j2=j-2
3550           endif
3551           kkk=0
3552           lll=0
3553           do k=1,2
3554             do l=1,2
3555               kkk=kkk+1
3556               muij(kkk)=mu(k,i)*mu(l,j)
3557 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3558 #ifdef NEWCORR
3559              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3560 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3561              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3562              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3563 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3564              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3565 #endif
3566             enddo
3567           enddo
3568 cd         write (iout,*) 'EELEC: i',i,' j',j
3569 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3570 cd          write(iout,*) 'muij',muij
3571           ury=scalar(uy(1,i),erij)
3572           urz=scalar(uz(1,i),erij)
3573           vry=scalar(uy(1,j),erij)
3574           vrz=scalar(uz(1,j),erij)
3575           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3576           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3577           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3578           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3579           fac=dsqrt(-ael6i)*r3ij
3580           a22=a22*fac
3581           a23=a23*fac
3582           a32=a32*fac
3583           a33=a33*fac
3584 cd          write (iout,'(4i5,4f10.5)')
3585 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3586 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3587 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3588 cd     &      uy(:,j),uz(:,j)
3589 cd          write (iout,'(4f10.5)')
3590 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3591 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3592 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3593 cd           write (iout,'(9f10.5/)')
3594 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3595 C Derivatives of the elements of A in virtual-bond vectors
3596           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3597           do k=1,3
3598             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3599             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3600             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3601             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3602             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3603             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3604             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3605             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3606             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3607             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3608             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3609             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3610           enddo
3611 C Compute radial contributions to the gradient
3612           facr=-3.0d0*rrmij
3613           a22der=a22*facr
3614           a23der=a23*facr
3615           a32der=a32*facr
3616           a33der=a33*facr
3617           agg(1,1)=a22der*xj
3618           agg(2,1)=a22der*yj
3619           agg(3,1)=a22der*zj
3620           agg(1,2)=a23der*xj
3621           agg(2,2)=a23der*yj
3622           agg(3,2)=a23der*zj
3623           agg(1,3)=a32der*xj
3624           agg(2,3)=a32der*yj
3625           agg(3,3)=a32der*zj
3626           agg(1,4)=a33der*xj
3627           agg(2,4)=a33der*yj
3628           agg(3,4)=a33der*zj
3629 C Add the contributions coming from er
3630           fac3=-3.0d0*fac
3631           do k=1,3
3632             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3633             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3634             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3635             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3636           enddo
3637           do k=1,3
3638 C Derivatives in DC(i)
3639 cgrad            ghalf1=0.5d0*agg(k,1)
3640 cgrad            ghalf2=0.5d0*agg(k,2)
3641 cgrad            ghalf3=0.5d0*agg(k,3)
3642 cgrad            ghalf4=0.5d0*agg(k,4)
3643             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3644      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3645             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3646      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3647             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3648      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3649             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3650      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3651 C Derivatives in DC(i+1)
3652             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3653      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3654             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3655      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3656             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3657      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3658             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3659      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3660 C Derivatives in DC(j)
3661             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3662      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3663             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3664      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3665             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3666      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3667             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3668      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3669 C Derivatives in DC(j+1) or DC(nres-1)
3670             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3671      &      -3.0d0*vryg(k,3)*ury)
3672             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3673      &      -3.0d0*vrzg(k,3)*ury)
3674             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3675      &      -3.0d0*vryg(k,3)*urz)
3676             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3677      &      -3.0d0*vrzg(k,3)*urz)
3678 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3679 cgrad              do l=1,4
3680 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3681 cgrad              enddo
3682 cgrad            endif
3683           enddo
3684           acipa(1,1)=a22
3685           acipa(1,2)=a23
3686           acipa(2,1)=a32
3687           acipa(2,2)=a33
3688           a22=-a22
3689           a23=-a23
3690           do l=1,2
3691             do k=1,3
3692               agg(k,l)=-agg(k,l)
3693               aggi(k,l)=-aggi(k,l)
3694               aggi1(k,l)=-aggi1(k,l)
3695               aggj(k,l)=-aggj(k,l)
3696               aggj1(k,l)=-aggj1(k,l)
3697             enddo
3698           enddo
3699           if (j.lt.nres-1) then
3700             a22=-a22
3701             a32=-a32
3702             do l=1,3,2
3703               do k=1,3
3704                 agg(k,l)=-agg(k,l)
3705                 aggi(k,l)=-aggi(k,l)
3706                 aggi1(k,l)=-aggi1(k,l)
3707                 aggj(k,l)=-aggj(k,l)
3708                 aggj1(k,l)=-aggj1(k,l)
3709               enddo
3710             enddo
3711           else
3712             a22=-a22
3713             a23=-a23
3714             a32=-a32
3715             a33=-a33
3716             do l=1,4
3717               do k=1,3
3718                 agg(k,l)=-agg(k,l)
3719                 aggi(k,l)=-aggi(k,l)
3720                 aggi1(k,l)=-aggi1(k,l)
3721                 aggj(k,l)=-aggj(k,l)
3722                 aggj1(k,l)=-aggj1(k,l)
3723               enddo
3724             enddo
3725           endif
3726           ENDIF ! WCORR
3727           IF (wel_loc.gt.0.0d0) THEN
3728 C Contribution to the local-electrostatic energy coming from the i-j pair
3729           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3730      &     +a33*muij(4)
3731 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3732 c     &                     ' eel_loc_ij',eel_loc_ij
3733 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3734 C Calculate patrial derivative for theta angle
3735 #ifdef NEWCORR
3736          geel_loc_ij=a22*gmuij1(1)
3737      &     +a23*gmuij1(2)
3738      &     +a32*gmuij1(3)
3739      &     +a33*gmuij1(4)
3740 c         write(iout,*) "derivative over thatai"
3741 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3742 c     &   a33*gmuij1(4)
3743          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3744      &      geel_loc_ij*wel_loc
3745 c         write(iout,*) "derivative over thatai-1"
3746 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3747 c     &   a33*gmuij2(4)
3748          geel_loc_ij=
3749      &     a22*gmuij2(1)
3750      &     +a23*gmuij2(2)
3751      &     +a32*gmuij2(3)
3752      &     +a33*gmuij2(4)
3753          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3754      &      geel_loc_ij*wel_loc
3755 c  Derivative over j residue
3756          geel_loc_ji=a22*gmuji1(1)
3757      &     +a23*gmuji1(2)
3758      &     +a32*gmuji1(3)
3759      &     +a33*gmuji1(4)
3760 c         write(iout,*) "derivative over thataj"
3761 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3762 c     &   a33*gmuji1(4)
3763
3764         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3765      &      geel_loc_ji*wel_loc
3766          geel_loc_ji=
3767      &     +a22*gmuji2(1)
3768      &     +a23*gmuji2(2)
3769      &     +a32*gmuji2(3)
3770      &     +a33*gmuji2(4)
3771 c         write(iout,*) "derivative over thataj-1"
3772 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3773 c     &   a33*gmuji2(4)
3774          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3775      &      geel_loc_ji*wel_loc
3776 #endif
3777 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3778
3779           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3780      &            'eelloc',i,j,eel_loc_ij
3781 c           if (eel_loc_ij.ne.0)
3782 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3783 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3784
3785           eel_loc=eel_loc+eel_loc_ij
3786 C Partial derivatives in virtual-bond dihedral angles gamma
3787           if (i.gt.1)
3788      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3789      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3790      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3791           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3792      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3793      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3794 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3795           do l=1,3
3796             ggg(l)=agg(l,1)*muij(1)+
3797      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3798             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3799             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3800 cgrad            ghalf=0.5d0*ggg(l)
3801 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3802 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3803           enddo
3804 cgrad          do k=i+1,j2
3805 cgrad            do l=1,3
3806 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3807 cgrad            enddo
3808 cgrad          enddo
3809 C Remaining derivatives of eello
3810           do l=1,3
3811             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3812      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3813             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3814      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3815             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3816      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3817             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3818      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3819           enddo
3820           ENDIF
3821 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3822 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3823           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3824      &       .and. num_conti.le.maxconts) then
3825 c            write (iout,*) i,j," entered corr"
3826 C
3827 C Calculate the contact function. The ith column of the array JCONT will
3828 C contain the numbers of atoms that make contacts with the atom I (of numbers
3829 C greater than I). The arrays FACONT and GACONT will contain the values of
3830 C the contact function and its derivative.
3831 c           r0ij=1.02D0*rpp(iteli,itelj)
3832 c           r0ij=1.11D0*rpp(iteli,itelj)
3833             r0ij=2.20D0*rpp(iteli,itelj)
3834 c           r0ij=1.55D0*rpp(iteli,itelj)
3835             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3836             if (fcont.gt.0.0D0) then
3837               num_conti=num_conti+1
3838               if (num_conti.gt.maxconts) then
3839                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3840      &                         ' will skip next contacts for this conf.'
3841               else
3842                 jcont_hb(num_conti,i)=j
3843 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3844 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3845                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3846      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3847 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3848 C  terms.
3849                 d_cont(num_conti,i)=rij
3850 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3851 C     --- Electrostatic-interaction matrix ---
3852                 a_chuj(1,1,num_conti,i)=a22
3853                 a_chuj(1,2,num_conti,i)=a23
3854                 a_chuj(2,1,num_conti,i)=a32
3855                 a_chuj(2,2,num_conti,i)=a33
3856 C     --- Gradient of rij
3857                 do kkk=1,3
3858                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3859                 enddo
3860                 kkll=0
3861                 do k=1,2
3862                   do l=1,2
3863                     kkll=kkll+1
3864                     do m=1,3
3865                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3866                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3867                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3868                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3869                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3870                     enddo
3871                   enddo
3872                 enddo
3873                 ENDIF
3874                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3875 C Calculate contact energies
3876                 cosa4=4.0D0*cosa
3877                 wij=cosa-3.0D0*cosb*cosg
3878                 cosbg1=cosb+cosg
3879                 cosbg2=cosb-cosg
3880 c               fac3=dsqrt(-ael6i)/r0ij**3
3881                 fac3=dsqrt(-ael6i)*r3ij
3882 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3883                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3884                 if (ees0tmp.gt.0) then
3885                   ees0pij=dsqrt(ees0tmp)
3886                 else
3887                   ees0pij=0
3888                 endif
3889 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3890                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3891                 if (ees0tmp.gt.0) then
3892                   ees0mij=dsqrt(ees0tmp)
3893                 else
3894                   ees0mij=0
3895                 endif
3896 c               ees0mij=0.0D0
3897                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3898                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3899 C Diagnostics. Comment out or remove after debugging!
3900 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3901 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3902 c               ees0m(num_conti,i)=0.0D0
3903 C End diagnostics.
3904 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3905 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3906 C Angular derivatives of the contact function
3907                 ees0pij1=fac3/ees0pij
3908                 ees0mij1=fac3/ees0mij
3909                 fac3p=-3.0D0*fac3*rrmij
3910                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3911                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3912 c               ees0mij1=0.0D0
3913                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3914                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3915                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3916                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3917                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3918                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3919                 ecosap=ecosa1+ecosa2
3920                 ecosbp=ecosb1+ecosb2
3921                 ecosgp=ecosg1+ecosg2
3922                 ecosam=ecosa1-ecosa2
3923                 ecosbm=ecosb1-ecosb2
3924                 ecosgm=ecosg1-ecosg2
3925 C Diagnostics
3926 c               ecosap=ecosa1
3927 c               ecosbp=ecosb1
3928 c               ecosgp=ecosg1
3929 c               ecosam=0.0D0
3930 c               ecosbm=0.0D0
3931 c               ecosgm=0.0D0
3932 C End diagnostics
3933                 facont_hb(num_conti,i)=fcont
3934                 fprimcont=fprimcont/rij
3935 cd              facont_hb(num_conti,i)=1.0D0
3936 C Following line is for diagnostics.
3937 cd              fprimcont=0.0D0
3938                 do k=1,3
3939                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3940                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3941                 enddo
3942                 do k=1,3
3943                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3944                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3945                 enddo
3946                 gggp(1)=gggp(1)+ees0pijp*xj
3947                 gggp(2)=gggp(2)+ees0pijp*yj
3948                 gggp(3)=gggp(3)+ees0pijp*zj
3949                 gggm(1)=gggm(1)+ees0mijp*xj
3950                 gggm(2)=gggm(2)+ees0mijp*yj
3951                 gggm(3)=gggm(3)+ees0mijp*zj
3952 C Derivatives due to the contact function
3953                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3954                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3955                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3956                 do k=1,3
3957 c
3958 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3959 c          following the change of gradient-summation algorithm.
3960 c
3961 cgrad                  ghalfp=0.5D0*gggp(k)
3962 cgrad                  ghalfm=0.5D0*gggm(k)
3963                   gacontp_hb1(k,num_conti,i)=!ghalfp
3964      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3965      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3966                   gacontp_hb2(k,num_conti,i)=!ghalfp
3967      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3968      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3969                   gacontp_hb3(k,num_conti,i)=gggp(k)
3970                   gacontm_hb1(k,num_conti,i)=!ghalfm
3971      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3972      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3973                   gacontm_hb2(k,num_conti,i)=!ghalfm
3974      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3975      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3976                   gacontm_hb3(k,num_conti,i)=gggm(k)
3977                 enddo
3978 C Diagnostics. Comment out or remove after debugging!
3979 cdiag           do k=1,3
3980 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3981 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3982 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3983 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3984 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3985 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3986 cdiag           enddo
3987               ENDIF ! wcorr
3988               endif  ! num_conti.le.maxconts
3989             endif  ! fcont.gt.0
3990           endif    ! j.gt.i+1
3991           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3992             do k=1,4
3993               do l=1,3
3994                 ghalf=0.5d0*agg(l,k)
3995                 aggi(l,k)=aggi(l,k)+ghalf
3996                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3997                 aggj(l,k)=aggj(l,k)+ghalf
3998               enddo
3999             enddo
4000             if (j.eq.nres-1 .and. i.lt.j-2) then
4001               do k=1,4
4002                 do l=1,3
4003                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4004                 enddo
4005               enddo
4006             endif
4007           endif
4008 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4009       return
4010       end
4011 C-----------------------------------------------------------------------------
4012       subroutine eturn3(i,eello_turn3)
4013 C Third- and fourth-order contributions from turns
4014       implicit real*8 (a-h,o-z)
4015       include 'DIMENSIONS'
4016       include 'COMMON.IOUNITS'
4017       include 'COMMON.GEO'
4018       include 'COMMON.VAR'
4019       include 'COMMON.LOCAL'
4020       include 'COMMON.CHAIN'
4021       include 'COMMON.DERIV'
4022       include 'COMMON.INTERACT'
4023       include 'COMMON.CONTACTS'
4024       include 'COMMON.TORSION'
4025       include 'COMMON.VECTORS'
4026       include 'COMMON.FFIELD'
4027       include 'COMMON.CONTROL'
4028       dimension ggg(3)
4029       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4030      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4031      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4032      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4033      &  auxgmat2(2,2),auxgmatt2(2,2)
4034       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4035      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4036       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4037      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4038      &    num_conti,j1,j2
4039       j=i+2
4040 c      write (iout,*) "eturn3",i,j,j1,j2
4041       a_temp(1,1)=a22
4042       a_temp(1,2)=a23
4043       a_temp(2,1)=a32
4044       a_temp(2,2)=a33
4045 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4046 C
4047 C               Third-order contributions
4048 C
4049 C                 (i+2)o----(i+3)
4050 C                      | |
4051 C                      | |
4052 C                 (i+1)o----i
4053 C
4054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4055 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4056         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4057 c auxalary matices for theta gradient
4058 c auxalary matrix for i+1 and constant i+2
4059         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4060 c auxalary matrix for i+2 and constant i+1
4061         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4062         call transpose2(auxmat(1,1),auxmat1(1,1))
4063         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4064         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4065         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4066         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4067         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4068         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4069 C Derivatives in theta
4070         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4071      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4072         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4073      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4074
4075         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4076      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4077 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4078 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4079 cd     &    ' eello_turn3_num',4*eello_turn3_num
4080 C Derivatives in gamma(i)
4081         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4082         call transpose2(auxmat2(1,1),auxmat3(1,1))
4083         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4084         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4085 C Derivatives in gamma(i+1)
4086         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4087         call transpose2(auxmat2(1,1),auxmat3(1,1))
4088         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4089         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4090      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4091 C Cartesian derivatives
4092         do l=1,3
4093 c            ghalf1=0.5d0*agg(l,1)
4094 c            ghalf2=0.5d0*agg(l,2)
4095 c            ghalf3=0.5d0*agg(l,3)
4096 c            ghalf4=0.5d0*agg(l,4)
4097           a_temp(1,1)=aggi(l,1)!+ghalf1
4098           a_temp(1,2)=aggi(l,2)!+ghalf2
4099           a_temp(2,1)=aggi(l,3)!+ghalf3
4100           a_temp(2,2)=aggi(l,4)!+ghalf4
4101           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4102           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4103      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4104           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4105           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4106           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4107           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4108           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4109           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4110      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4111           a_temp(1,1)=aggj(l,1)!+ghalf1
4112           a_temp(1,2)=aggj(l,2)!+ghalf2
4113           a_temp(2,1)=aggj(l,3)!+ghalf3
4114           a_temp(2,2)=aggj(l,4)!+ghalf4
4115           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4116           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4117      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4118           a_temp(1,1)=aggj1(l,1)
4119           a_temp(1,2)=aggj1(l,2)
4120           a_temp(2,1)=aggj1(l,3)
4121           a_temp(2,2)=aggj1(l,4)
4122           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4123           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4124      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4125         enddo
4126       return
4127       end
4128 C-------------------------------------------------------------------------------
4129       subroutine eturn4(i,eello_turn4)
4130 C Third- and fourth-order contributions from turns
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.IOUNITS'
4134       include 'COMMON.GEO'
4135       include 'COMMON.VAR'
4136       include 'COMMON.LOCAL'
4137       include 'COMMON.CHAIN'
4138       include 'COMMON.DERIV'
4139       include 'COMMON.INTERACT'
4140       include 'COMMON.CONTACTS'
4141       include 'COMMON.TORSION'
4142       include 'COMMON.VECTORS'
4143       include 'COMMON.FFIELD'
4144       include 'COMMON.CONTROL'
4145       dimension ggg(3)
4146       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4147      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4148      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4149      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4150      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4151      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4152      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4153       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4154      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4155       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4156      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4157      &    num_conti,j1,j2
4158       j=i+3
4159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4160 C
4161 C               Fourth-order contributions
4162 C
4163 C                 (i+3)o----(i+4)
4164 C                     /  |
4165 C               (i+2)o   |
4166 C                     \  |
4167 C                 (i+1)o----i
4168 C
4169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4170 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4171 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4172 c        write(iout,*)"WCHODZE W PROGRAM"
4173         a_temp(1,1)=a22
4174         a_temp(1,2)=a23
4175         a_temp(2,1)=a32
4176         a_temp(2,2)=a33
4177         iti1=itortyp(itype(i+1))
4178         iti2=itortyp(itype(i+2))
4179         iti3=itortyp(itype(i+3))
4180 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4181         call transpose2(EUg(1,1,i+1),e1t(1,1))
4182         call transpose2(Eug(1,1,i+2),e2t(1,1))
4183         call transpose2(Eug(1,1,i+3),e3t(1,1))
4184 C Ematrix derivative in theta
4185         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4186         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4187         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4188         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4189 c       eta1 in derivative theta
4190         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4191         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4192 c       auxgvec is derivative of Ub2 so i+3 theta
4193         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4194 c       auxalary matrix of E i+1
4195         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4196 c        s1=0.0
4197 c        gs1=0.0
4198         s1=scalar2(b1(1,i+2),auxvec(1))
4199 c derivative of theta i+2 with constant i+3
4200         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4201 c derivative of theta i+2 with constant i+2
4202         gs32=scalar2(b1(1,i+2),auxgvec(1))
4203 c derivative of E matix in theta of i+1
4204         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4205
4206         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4207 c       ea31 in derivative theta
4208         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4209         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4210 c auxilary matrix auxgvec of Ub2 with constant E matirx
4211         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4212 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4213         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4214
4215 c        s2=0.0
4216 c        gs2=0.0
4217         s2=scalar2(b1(1,i+1),auxvec(1))
4218 c derivative of theta i+1 with constant i+3
4219         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4220 c derivative of theta i+2 with constant i+1
4221         gs21=scalar2(b1(1,i+1),auxgvec(1))
4222 c derivative of theta i+3 with constant i+1
4223         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4224 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4225 c     &  gtb1(1,i+1)
4226         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4227 c two derivatives over diffetent matrices
4228 c gtae3e2 is derivative over i+3
4229         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4230 c ae3gte2 is derivative over i+2
4231         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4232         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4233 c three possible derivative over theta E matices
4234 c i+1
4235         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4236 c i+2
4237         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4238 c i+3
4239         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4240         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4241
4242         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4243         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4244         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4245
4246         eello_turn4=eello_turn4-(s1+s2+s3)
4247 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4248         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4249      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4250 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4251 cd     &    ' eello_turn4_num',8*eello_turn4_num
4252 #ifdef NEWCORR
4253         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4254      &                  -(gs13+gsE13+gsEE1)*wturn4
4255         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4256      &                    -(gs23+gs21+gsEE2)*wturn4
4257         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4258      &                    -(gs32+gsE31+gsEE3)*wturn4
4259 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4260 c     &   gs2
4261 #endif
4262         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4263      &      'eturn4',i,j,-(s1+s2+s3)
4264 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4265 c     &    ' eello_turn4_num',8*eello_turn4_num
4266 C Derivatives in gamma(i)
4267         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4268         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4269         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4270         s1=scalar2(b1(1,i+2),auxvec(1))
4271         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4272         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4273         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4274 C Derivatives in gamma(i+1)
4275         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4276         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4277         s2=scalar2(b1(1,i+1),auxvec(1))
4278         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4279         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4280         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4281         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4282 C Derivatives in gamma(i+2)
4283         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4284         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4285         s1=scalar2(b1(1,i+2),auxvec(1))
4286         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4287         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4288         s2=scalar2(b1(1,i+1),auxvec(1))
4289         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4290         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4291         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4292         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4293 C Cartesian derivatives
4294 C Derivatives of this turn contributions in DC(i+2)
4295         if (j.lt.nres-1) then
4296           do l=1,3
4297             a_temp(1,1)=agg(l,1)
4298             a_temp(1,2)=agg(l,2)
4299             a_temp(2,1)=agg(l,3)
4300             a_temp(2,2)=agg(l,4)
4301             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4302             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4303             s1=scalar2(b1(1,i+2),auxvec(1))
4304             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4305             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4306             s2=scalar2(b1(1,i+1),auxvec(1))
4307             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4308             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4309             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4310             ggg(l)=-(s1+s2+s3)
4311             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4312           enddo
4313         endif
4314 C Remaining derivatives of this turn contribution
4315         do l=1,3
4316           a_temp(1,1)=aggi(l,1)
4317           a_temp(1,2)=aggi(l,2)
4318           a_temp(2,1)=aggi(l,3)
4319           a_temp(2,2)=aggi(l,4)
4320           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4321           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4322           s1=scalar2(b1(1,i+2),auxvec(1))
4323           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4324           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4325           s2=scalar2(b1(1,i+1),auxvec(1))
4326           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4327           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4328           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4329           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4330           a_temp(1,1)=aggi1(l,1)
4331           a_temp(1,2)=aggi1(l,2)
4332           a_temp(2,1)=aggi1(l,3)
4333           a_temp(2,2)=aggi1(l,4)
4334           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4335           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4336           s1=scalar2(b1(1,i+2),auxvec(1))
4337           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4338           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4339           s2=scalar2(b1(1,i+1),auxvec(1))
4340           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4341           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4342           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4343           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4344           a_temp(1,1)=aggj(l,1)
4345           a_temp(1,2)=aggj(l,2)
4346           a_temp(2,1)=aggj(l,3)
4347           a_temp(2,2)=aggj(l,4)
4348           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4349           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4350           s1=scalar2(b1(1,i+2),auxvec(1))
4351           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4352           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4353           s2=scalar2(b1(1,i+1),auxvec(1))
4354           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4355           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4356           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4357           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4358           a_temp(1,1)=aggj1(l,1)
4359           a_temp(1,2)=aggj1(l,2)
4360           a_temp(2,1)=aggj1(l,3)
4361           a_temp(2,2)=aggj1(l,4)
4362           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4363           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4364           s1=scalar2(b1(1,i+2),auxvec(1))
4365           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4366           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4367           s2=scalar2(b1(1,i+1),auxvec(1))
4368           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4369           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4370           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4371 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4372           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4373         enddo
4374       return
4375       end
4376 C-----------------------------------------------------------------------------
4377       subroutine vecpr(u,v,w)
4378       implicit real*8(a-h,o-z)
4379       dimension u(3),v(3),w(3)
4380       w(1)=u(2)*v(3)-u(3)*v(2)
4381       w(2)=-u(1)*v(3)+u(3)*v(1)
4382       w(3)=u(1)*v(2)-u(2)*v(1)
4383       return
4384       end
4385 C-----------------------------------------------------------------------------
4386       subroutine unormderiv(u,ugrad,unorm,ungrad)
4387 C This subroutine computes the derivatives of a normalized vector u, given
4388 C the derivatives computed without normalization conditions, ugrad. Returns
4389 C ungrad.
4390       implicit none
4391       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4392       double precision vec(3)
4393       double precision scalar
4394       integer i,j
4395 c      write (2,*) 'ugrad',ugrad
4396 c      write (2,*) 'u',u
4397       do i=1,3
4398         vec(i)=scalar(ugrad(1,i),u(1))
4399       enddo
4400 c      write (2,*) 'vec',vec
4401       do i=1,3
4402         do j=1,3
4403           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4404         enddo
4405       enddo
4406 c      write (2,*) 'ungrad',ungrad
4407       return
4408       end
4409 C-----------------------------------------------------------------------------
4410       subroutine escp_soft_sphere(evdw2,evdw2_14)
4411 C
4412 C This subroutine calculates the excluded-volume interaction energy between
4413 C peptide-group centers and side chains and its gradient in virtual-bond and
4414 C side-chain vectors.
4415 C
4416       implicit real*8 (a-h,o-z)
4417       include 'DIMENSIONS'
4418       include 'COMMON.GEO'
4419       include 'COMMON.VAR'
4420       include 'COMMON.LOCAL'
4421       include 'COMMON.CHAIN'
4422       include 'COMMON.DERIV'
4423       include 'COMMON.INTERACT'
4424       include 'COMMON.FFIELD'
4425       include 'COMMON.IOUNITS'
4426       include 'COMMON.CONTROL'
4427       dimension ggg(3)
4428       evdw2=0.0D0
4429       evdw2_14=0.0d0
4430       r0_scp=4.5d0
4431 cd    print '(a)','Enter ESCP'
4432 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4433 C      do xshift=-1,1
4434 C      do yshift=-1,1
4435 C      do zshift=-1,1
4436       do i=iatscp_s,iatscp_e
4437         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4438         iteli=itel(i)
4439         xi=0.5D0*(c(1,i)+c(1,i+1))
4440         yi=0.5D0*(c(2,i)+c(2,i+1))
4441         zi=0.5D0*(c(3,i)+c(3,i+1))
4442 C Return atom into box, boxxsize is size of box in x dimension
4443 c  134   continue
4444 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4445 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4446 C Condition for being inside the proper box
4447 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4448 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4449 c        go to 134
4450 c        endif
4451 c  135   continue
4452 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4453 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4454 C Condition for being inside the proper box
4455 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4456 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4457 c        go to 135
4458 c c       endif
4459 c  136   continue
4460 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4461 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4462 cC Condition for being inside the proper box
4463 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4464 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4465 c        go to 136
4466 c        endif
4467           xi=mod(xi,boxxsize)
4468           if (xi.lt.0) xi=xi+boxxsize
4469           yi=mod(yi,boxysize)
4470           if (yi.lt.0) yi=yi+boxysize
4471           zi=mod(zi,boxzsize)
4472           if (zi.lt.0) zi=zi+boxzsize
4473 C          xi=xi+xshift*boxxsize
4474 C          yi=yi+yshift*boxysize
4475 C          zi=zi+zshift*boxzsize
4476         do iint=1,nscp_gr(i)
4477
4478         do j=iscpstart(i,iint),iscpend(i,iint)
4479           if (itype(j).eq.ntyp1) cycle
4480           itypj=iabs(itype(j))
4481 C Uncomment following three lines for SC-p interactions
4482 c         xj=c(1,nres+j)-xi
4483 c         yj=c(2,nres+j)-yi
4484 c         zj=c(3,nres+j)-zi
4485 C Uncomment following three lines for Ca-p interactions
4486           xj=c(1,j)
4487           yj=c(2,j)
4488           zj=c(3,j)
4489 c  174   continue
4490 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4491 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4492 C Condition for being inside the proper box
4493 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4494 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4495 c        go to 174
4496 c        endif
4497 c  175   continue
4498 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4499 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4500 cC Condition for being inside the proper box
4501 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4502 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4503 c        go to 175
4504 c        endif
4505 c  176   continue
4506 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4507 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4508 C Condition for being inside the proper box
4509 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4510 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4511 c        go to 176
4512           xj=mod(xj,boxxsize)
4513           if (xj.lt.0) xj=xj+boxxsize
4514           yj=mod(yj,boxysize)
4515           if (yj.lt.0) yj=yj+boxysize
4516           zj=mod(zj,boxzsize)
4517           if (zj.lt.0) zj=zj+boxzsize
4518       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4519       xj_safe=xj
4520       yj_safe=yj
4521       zj_safe=zj
4522       subchap=0
4523       do xshift=-1,1
4524       do yshift=-1,1
4525       do zshift=-1,1
4526           xj=xj_safe+xshift*boxxsize
4527           yj=yj_safe+yshift*boxysize
4528           zj=zj_safe+zshift*boxzsize
4529           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4530           if(dist_temp.lt.dist_init) then
4531             dist_init=dist_temp
4532             xj_temp=xj
4533             yj_temp=yj
4534             zj_temp=zj
4535             subchap=1
4536           endif
4537        enddo
4538        enddo
4539        enddo
4540        if (subchap.eq.1) then
4541           xj=xj_temp-xi
4542           yj=yj_temp-yi
4543           zj=zj_temp-zi
4544        else
4545           xj=xj_safe-xi
4546           yj=yj_safe-yi
4547           zj=zj_safe-zi
4548        endif
4549 c c       endif
4550 C          xj=xj-xi
4551 C          yj=yj-yi
4552 C          zj=zj-zi
4553           rij=xj*xj+yj*yj+zj*zj
4554
4555           r0ij=r0_scp
4556           r0ijsq=r0ij*r0ij
4557           if (rij.lt.r0ijsq) then
4558             evdwij=0.25d0*(rij-r0ijsq)**2
4559             fac=rij-r0ijsq
4560           else
4561             evdwij=0.0d0
4562             fac=0.0d0
4563           endif
4564           evdw2=evdw2+evdwij
4565 C
4566 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4567 C
4568           ggg(1)=xj*fac
4569           ggg(2)=yj*fac
4570           ggg(3)=zj*fac
4571 cgrad          if (j.lt.i) then
4572 cd          write (iout,*) 'j<i'
4573 C Uncomment following three lines for SC-p interactions
4574 c           do k=1,3
4575 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4576 c           enddo
4577 cgrad          else
4578 cd          write (iout,*) 'j>i'
4579 cgrad            do k=1,3
4580 cgrad              ggg(k)=-ggg(k)
4581 C Uncomment following line for SC-p interactions
4582 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4583 cgrad            enddo
4584 cgrad          endif
4585 cgrad          do k=1,3
4586 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4587 cgrad          enddo
4588 cgrad          kstart=min0(i+1,j)
4589 cgrad          kend=max0(i-1,j-1)
4590 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4591 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4592 cgrad          do k=kstart,kend
4593 cgrad            do l=1,3
4594 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4595 cgrad            enddo
4596 cgrad          enddo
4597           do k=1,3
4598             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4599             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4600           enddo
4601         enddo
4602
4603         enddo ! iint
4604       enddo ! i
4605 C      enddo !zshift
4606 C      enddo !yshift
4607 C      enddo !xshift
4608       return
4609       end
4610 C-----------------------------------------------------------------------------
4611       subroutine escp(evdw2,evdw2_14)
4612 C
4613 C This subroutine calculates the excluded-volume interaction energy between
4614 C peptide-group centers and side chains and its gradient in virtual-bond and
4615 C side-chain vectors.
4616 C
4617       implicit real*8 (a-h,o-z)
4618       include 'DIMENSIONS'
4619       include 'COMMON.GEO'
4620       include 'COMMON.VAR'
4621       include 'COMMON.LOCAL'
4622       include 'COMMON.CHAIN'
4623       include 'COMMON.DERIV'
4624       include 'COMMON.INTERACT'
4625       include 'COMMON.FFIELD'
4626       include 'COMMON.IOUNITS'
4627       include 'COMMON.CONTROL'
4628       include 'COMMON.SPLITELE'
4629       dimension ggg(3)
4630       evdw2=0.0D0
4631       evdw2_14=0.0d0
4632 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4633 cd    print '(a)','Enter ESCP'
4634 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4635 C      do xshift=-1,1
4636 C      do yshift=-1,1
4637 C      do zshift=-1,1
4638       do i=iatscp_s,iatscp_e
4639         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4640         iteli=itel(i)
4641         xi=0.5D0*(c(1,i)+c(1,i+1))
4642         yi=0.5D0*(c(2,i)+c(2,i+1))
4643         zi=0.5D0*(c(3,i)+c(3,i+1))
4644           xi=mod(xi,boxxsize)
4645           if (xi.lt.0) xi=xi+boxxsize
4646           yi=mod(yi,boxysize)
4647           if (yi.lt.0) yi=yi+boxysize
4648           zi=mod(zi,boxzsize)
4649           if (zi.lt.0) zi=zi+boxzsize
4650 c          xi=xi+xshift*boxxsize
4651 c          yi=yi+yshift*boxysize
4652 c          zi=zi+zshift*boxzsize
4653 c        print *,xi,yi,zi,'polozenie i'
4654 C Return atom into box, boxxsize is size of box in x dimension
4655 c  134   continue
4656 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4657 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4658 C Condition for being inside the proper box
4659 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4660 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4661 c        go to 134
4662 c        endif
4663 c  135   continue
4664 c          print *,xi,boxxsize,"pierwszy"
4665
4666 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4667 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4668 C Condition for being inside the proper box
4669 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4670 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4671 c        go to 135
4672 c        endif
4673 c  136   continue
4674 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4675 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4676 C Condition for being inside the proper box
4677 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4678 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4679 c        go to 136
4680 c        endif
4681         do iint=1,nscp_gr(i)
4682
4683         do j=iscpstart(i,iint),iscpend(i,iint)
4684           itypj=iabs(itype(j))
4685           if (itypj.eq.ntyp1) cycle
4686 C Uncomment following three lines for SC-p interactions
4687 c         xj=c(1,nres+j)-xi
4688 c         yj=c(2,nres+j)-yi
4689 c         zj=c(3,nres+j)-zi
4690 C Uncomment following three lines for Ca-p interactions
4691           xj=c(1,j)
4692           yj=c(2,j)
4693           zj=c(3,j)
4694           xj=mod(xj,boxxsize)
4695           if (xj.lt.0) xj=xj+boxxsize
4696           yj=mod(yj,boxysize)
4697           if (yj.lt.0) yj=yj+boxysize
4698           zj=mod(zj,boxzsize)
4699           if (zj.lt.0) zj=zj+boxzsize
4700 c  174   continue
4701 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4702 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4703 C Condition for being inside the proper box
4704 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4705 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4706 c        go to 174
4707 c        endif
4708 c  175   continue
4709 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4710 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4711 cC Condition for being inside the proper box
4712 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4713 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4714 c        go to 175
4715 c        endif
4716 c  176   continue
4717 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4718 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4719 C Condition for being inside the proper box
4720 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4721 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4722 c        go to 176
4723 c        endif
4724 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4725       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4726       xj_safe=xj
4727       yj_safe=yj
4728       zj_safe=zj
4729       subchap=0
4730       do xshift=-1,1
4731       do yshift=-1,1
4732       do zshift=-1,1
4733           xj=xj_safe+xshift*boxxsize
4734           yj=yj_safe+yshift*boxysize
4735           zj=zj_safe+zshift*boxzsize
4736           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4737           if(dist_temp.lt.dist_init) then
4738             dist_init=dist_temp
4739             xj_temp=xj
4740             yj_temp=yj
4741             zj_temp=zj
4742             subchap=1
4743           endif
4744        enddo
4745        enddo
4746        enddo
4747        if (subchap.eq.1) then
4748           xj=xj_temp-xi
4749           yj=yj_temp-yi
4750           zj=zj_temp-zi
4751        else
4752           xj=xj_safe-xi
4753           yj=yj_safe-yi
4754           zj=zj_safe-zi
4755        endif
4756 c          print *,xj,yj,zj,'polozenie j'
4757           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4758 c          print *,rrij
4759           sss=sscale(1.0d0/(dsqrt(rrij)))
4760 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4761 c          if (sss.eq.0) print *,'czasem jest OK'
4762           if (sss.le.0.0d0) cycle
4763           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4764           fac=rrij**expon2
4765           e1=fac*fac*aad(itypj,iteli)
4766           e2=fac*bad(itypj,iteli)
4767           if (iabs(j-i) .le. 2) then
4768             e1=scal14*e1
4769             e2=scal14*e2
4770             evdw2_14=evdw2_14+(e1+e2)*sss
4771           endif
4772           evdwij=e1+e2
4773           evdw2=evdw2+evdwij*sss
4774           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4775      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4776      &       bad(itypj,iteli)
4777 C
4778 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4779 C
4780           fac=-(evdwij+e1)*rrij*sss
4781           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4782           ggg(1)=xj*fac
4783           ggg(2)=yj*fac
4784           ggg(3)=zj*fac
4785 cgrad          if (j.lt.i) then
4786 cd          write (iout,*) 'j<i'
4787 C Uncomment following three lines for SC-p interactions
4788 c           do k=1,3
4789 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4790 c           enddo
4791 cgrad          else
4792 cd          write (iout,*) 'j>i'
4793 cgrad            do k=1,3
4794 cgrad              ggg(k)=-ggg(k)
4795 C Uncomment following line for SC-p interactions
4796 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4797 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4798 cgrad            enddo
4799 cgrad          endif
4800 cgrad          do k=1,3
4801 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4802 cgrad          enddo
4803 cgrad          kstart=min0(i+1,j)
4804 cgrad          kend=max0(i-1,j-1)
4805 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4806 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4807 cgrad          do k=kstart,kend
4808 cgrad            do l=1,3
4809 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4810 cgrad            enddo
4811 cgrad          enddo
4812           do k=1,3
4813             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4814             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4815           enddo
4816 c        endif !endif for sscale cutoff
4817         enddo ! j
4818
4819         enddo ! iint
4820       enddo ! i
4821 c      enddo !zshift
4822 c      enddo !yshift
4823 c      enddo !xshift
4824       do i=1,nct
4825         do j=1,3
4826           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4827           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4828           gradx_scp(j,i)=expon*gradx_scp(j,i)
4829         enddo
4830       enddo
4831 C******************************************************************************
4832 C
4833 C                              N O T E !!!
4834 C
4835 C To save time the factor EXPON has been extracted from ALL components
4836 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4837 C use!
4838 C
4839 C******************************************************************************
4840       return
4841       end
4842 C--------------------------------------------------------------------------
4843       subroutine edis(ehpb)
4844 C
4845 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4846 C
4847       implicit real*8 (a-h,o-z)
4848       include 'DIMENSIONS'
4849       include 'COMMON.SBRIDGE'
4850       include 'COMMON.CHAIN'
4851       include 'COMMON.DERIV'
4852       include 'COMMON.VAR'
4853       include 'COMMON.INTERACT'
4854       include 'COMMON.IOUNITS'
4855       dimension ggg(3)
4856       ehpb=0.0D0
4857 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4858 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4859       if (link_end.eq.0) return
4860       do i=link_start,link_end
4861 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4862 C CA-CA distance used in regularization of structure.
4863         ii=ihpb(i)
4864         jj=jhpb(i)
4865 C iii and jjj point to the residues for which the distance is assigned.
4866         if (ii.gt.nres) then
4867           iii=ii-nres
4868           jjj=jj-nres
4869         else
4870           iii=ii
4871           jjj=jj
4872         endif
4873 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4874 c     &    dhpb(i),dhpb1(i),forcon(i)
4875 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4876 C    distance and angle dependent SS bond potential.
4877         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4878      & iabs(itype(jjj)).eq.1) then
4879 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4880 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4881         if (.not.dyn_ss .and. i.le.nss) then
4882 C 15/02/13 CC dynamic SSbond - additional check
4883          if (ii.gt.nres
4884      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4885           call ssbond_ene(iii,jjj,eij)
4886           ehpb=ehpb+2*eij
4887          endif
4888 cd          write (iout,*) "eij",eij
4889         else
4890 C Calculate the distance between the two points and its difference from the
4891 C target distance.
4892           dd=dist(ii,jj)
4893             rdis=dd-dhpb(i)
4894 C Get the force constant corresponding to this distance.
4895             waga=forcon(i)
4896 C Calculate the contribution to energy.
4897             ehpb=ehpb+waga*rdis*rdis
4898 C
4899 C Evaluate gradient.
4900 C
4901             fac=waga*rdis/dd
4902 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4903 cd   &   ' waga=',waga,' fac=',fac
4904             do j=1,3
4905               ggg(j)=fac*(c(j,jj)-c(j,ii))
4906             enddo
4907 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4908 C If this is a SC-SC distance, we need to calculate the contributions to the
4909 C Cartesian gradient in the SC vectors (ghpbx).
4910           if (iii.lt.ii) then
4911           do j=1,3
4912             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4913             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4914           enddo
4915           endif
4916 cgrad        do j=iii,jjj-1
4917 cgrad          do k=1,3
4918 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4919 cgrad          enddo
4920 cgrad        enddo
4921           do k=1,3
4922             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4923             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4924           enddo
4925         endif
4926        endif
4927       enddo
4928       ehpb=0.5D0*ehpb
4929       return
4930       end
4931 C--------------------------------------------------------------------------
4932       subroutine ssbond_ene(i,j,eij)
4933 C
4934 C Calculate the distance and angle dependent SS-bond potential energy
4935 C using a free-energy function derived based on RHF/6-31G** ab initio
4936 C calculations of diethyl disulfide.
4937 C
4938 C A. Liwo and U. Kozlowska, 11/24/03
4939 C
4940       implicit real*8 (a-h,o-z)
4941       include 'DIMENSIONS'
4942       include 'COMMON.SBRIDGE'
4943       include 'COMMON.CHAIN'
4944       include 'COMMON.DERIV'
4945       include 'COMMON.LOCAL'
4946       include 'COMMON.INTERACT'
4947       include 'COMMON.VAR'
4948       include 'COMMON.IOUNITS'
4949       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4950       itypi=iabs(itype(i))
4951       xi=c(1,nres+i)
4952       yi=c(2,nres+i)
4953       zi=c(3,nres+i)
4954       dxi=dc_norm(1,nres+i)
4955       dyi=dc_norm(2,nres+i)
4956       dzi=dc_norm(3,nres+i)
4957 c      dsci_inv=dsc_inv(itypi)
4958       dsci_inv=vbld_inv(nres+i)
4959       itypj=iabs(itype(j))
4960 c      dscj_inv=dsc_inv(itypj)
4961       dscj_inv=vbld_inv(nres+j)
4962       xj=c(1,nres+j)-xi
4963       yj=c(2,nres+j)-yi
4964       zj=c(3,nres+j)-zi
4965       dxj=dc_norm(1,nres+j)
4966       dyj=dc_norm(2,nres+j)
4967       dzj=dc_norm(3,nres+j)
4968       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4969       rij=dsqrt(rrij)
4970       erij(1)=xj*rij
4971       erij(2)=yj*rij
4972       erij(3)=zj*rij
4973       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4974       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4975       om12=dxi*dxj+dyi*dyj+dzi*dzj
4976       do k=1,3
4977         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4978         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4979       enddo
4980       rij=1.0d0/rij
4981       deltad=rij-d0cm
4982       deltat1=1.0d0-om1
4983       deltat2=1.0d0+om2
4984       deltat12=om2-om1+2.0d0
4985       cosphi=om12-om1*om2
4986       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4987      &  +akct*deltad*deltat12
4988      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4989 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4990 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4991 c     &  " deltat12",deltat12," eij",eij
4992       ed=2*akcm*deltad+akct*deltat12
4993       pom1=akct*deltad
4994       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4995       eom1=-2*akth*deltat1-pom1-om2*pom2
4996       eom2= 2*akth*deltat2+pom1-om1*pom2
4997       eom12=pom2
4998       do k=1,3
4999         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5000         ghpbx(k,i)=ghpbx(k,i)-ggk
5001      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5002      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5003         ghpbx(k,j)=ghpbx(k,j)+ggk
5004      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5005      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5006         ghpbc(k,i)=ghpbc(k,i)-ggk
5007         ghpbc(k,j)=ghpbc(k,j)+ggk
5008       enddo
5009 C
5010 C Calculate the components of the gradient in DC and X
5011 C
5012 cgrad      do k=i,j-1
5013 cgrad        do l=1,3
5014 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5015 cgrad        enddo
5016 cgrad      enddo
5017       return
5018       end
5019 C--------------------------------------------------------------------------
5020       subroutine ebond(estr)
5021 c
5022 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5023 c
5024       implicit real*8 (a-h,o-z)
5025       include 'DIMENSIONS'
5026       include 'COMMON.LOCAL'
5027       include 'COMMON.GEO'
5028       include 'COMMON.INTERACT'
5029       include 'COMMON.DERIV'
5030       include 'COMMON.VAR'
5031       include 'COMMON.CHAIN'
5032       include 'COMMON.IOUNITS'
5033       include 'COMMON.NAMES'
5034       include 'COMMON.FFIELD'
5035       include 'COMMON.CONTROL'
5036       include 'COMMON.SETUP'
5037       double precision u(3),ud(3)
5038       estr=0.0d0
5039       estr1=0.0d0
5040       do i=ibondp_start,ibondp_end
5041         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5042 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5043 c          do j=1,3
5044 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5045 c     &      *dc(j,i-1)/vbld(i)
5046 c          enddo
5047 c          if (energy_dec) write(iout,*)
5048 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5049 c        else
5050 C       Checking if it involves dummy (NH3+ or COO-) group
5051          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5052 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5053         diff = vbld(i)-vbldpDUM
5054          else
5055 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5056         diff = vbld(i)-vbldp0
5057          endif
5058         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5059      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5060         estr=estr+diff*diff
5061         do j=1,3
5062           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5063         enddo
5064 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5065 c        endif
5066       enddo
5067       estr=0.5d0*AKP*estr+estr1
5068 c
5069 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5070 c
5071       do i=ibond_start,ibond_end
5072         iti=iabs(itype(i))
5073         if (iti.ne.10 .and. iti.ne.ntyp1) then
5074           nbi=nbondterm(iti)
5075           if (nbi.eq.1) then
5076             diff=vbld(i+nres)-vbldsc0(1,iti)
5077             if (energy_dec)  write (iout,*)
5078      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5079      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5080             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5081             do j=1,3
5082               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5083             enddo
5084           else
5085             do j=1,nbi
5086               diff=vbld(i+nres)-vbldsc0(j,iti)
5087               ud(j)=aksc(j,iti)*diff
5088               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5089             enddo
5090             uprod=u(1)
5091             do j=2,nbi
5092               uprod=uprod*u(j)
5093             enddo
5094             usum=0.0d0
5095             usumsqder=0.0d0
5096             do j=1,nbi
5097               uprod1=1.0d0
5098               uprod2=1.0d0
5099               do k=1,nbi
5100                 if (k.ne.j) then
5101                   uprod1=uprod1*u(k)
5102                   uprod2=uprod2*u(k)*u(k)
5103                 endif
5104               enddo
5105               usum=usum+uprod1
5106               usumsqder=usumsqder+ud(j)*uprod2
5107             enddo
5108             estr=estr+uprod/usum
5109             do j=1,3
5110              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5111             enddo
5112           endif
5113         endif
5114       enddo
5115       return
5116       end
5117 #ifdef CRYST_THETA
5118 C--------------------------------------------------------------------------
5119       subroutine ebend(etheta)
5120 C
5121 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5122 C angles gamma and its derivatives in consecutive thetas and gammas.
5123 C
5124       implicit real*8 (a-h,o-z)
5125       include 'DIMENSIONS'
5126       include 'COMMON.LOCAL'
5127       include 'COMMON.GEO'
5128       include 'COMMON.INTERACT'
5129       include 'COMMON.DERIV'
5130       include 'COMMON.VAR'
5131       include 'COMMON.CHAIN'
5132       include 'COMMON.IOUNITS'
5133       include 'COMMON.NAMES'
5134       include 'COMMON.FFIELD'
5135       include 'COMMON.CONTROL'
5136       common /calcthet/ term1,term2,termm,diffak,ratak,
5137      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5138      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5139       double precision y(2),z(2)
5140       delta=0.02d0*pi
5141 c      time11=dexp(-2*time)
5142 c      time12=1.0d0
5143       etheta=0.0D0
5144 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5145       do i=ithet_start,ithet_end
5146         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5147      &  .or.itype(i).eq.ntyp1) cycle
5148 C Zero the energy function and its derivative at 0 or pi.
5149         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5150         it=itype(i-1)
5151         ichir1=isign(1,itype(i-2))
5152         ichir2=isign(1,itype(i))
5153          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5154          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5155          if (itype(i-1).eq.10) then
5156           itype1=isign(10,itype(i-2))
5157           ichir11=isign(1,itype(i-2))
5158           ichir12=isign(1,itype(i-2))
5159           itype2=isign(10,itype(i))
5160           ichir21=isign(1,itype(i))
5161           ichir22=isign(1,itype(i))
5162          endif
5163
5164         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5165 #ifdef OSF
5166           phii=phi(i)
5167           if (phii.ne.phii) phii=150.0
5168 #else
5169           phii=phi(i)
5170 #endif
5171           y(1)=dcos(phii)
5172           y(2)=dsin(phii)
5173         else
5174           y(1)=0.0D0
5175           y(2)=0.0D0
5176         endif
5177         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5178 #ifdef OSF
5179           phii1=phi(i+1)
5180           if (phii1.ne.phii1) phii1=150.0
5181           phii1=pinorm(phii1)
5182           z(1)=cos(phii1)
5183 #else
5184           phii1=phi(i+1)
5185 #endif
5186           z(1)=dcos(phii1)
5187           z(2)=dsin(phii1)
5188         else
5189           z(1)=0.0D0
5190           z(2)=0.0D0
5191         endif
5192 C Calculate the "mean" value of theta from the part of the distribution
5193 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5194 C In following comments this theta will be referred to as t_c.
5195         thet_pred_mean=0.0d0
5196         do k=1,2
5197             athetk=athet(k,it,ichir1,ichir2)
5198             bthetk=bthet(k,it,ichir1,ichir2)
5199           if (it.eq.10) then
5200              athetk=athet(k,itype1,ichir11,ichir12)
5201              bthetk=bthet(k,itype2,ichir21,ichir22)
5202           endif
5203          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5204 c         write(iout,*) 'chuj tu', y(k),z(k)
5205         enddo
5206         dthett=thet_pred_mean*ssd
5207         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5208 C Derivatives of the "mean" values in gamma1 and gamma2.
5209         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5210      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5211          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5212      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5213          if (it.eq.10) then
5214       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5215      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5216         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5217      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5218          endif
5219         if (theta(i).gt.pi-delta) then
5220           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5221      &         E_tc0)
5222           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5223           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5224           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5225      &        E_theta)
5226           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5227      &        E_tc)
5228         else if (theta(i).lt.delta) then
5229           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5230           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5231           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5232      &        E_theta)
5233           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5234           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5235      &        E_tc)
5236         else
5237           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5238      &        E_theta,E_tc)
5239         endif
5240         etheta=etheta+ethetai
5241         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5242      &      'ebend',i,ethetai,theta(i),itype(i)
5243         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5244         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5245         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5246       enddo
5247 C Ufff.... We've done all this!!!
5248       return
5249       end
5250 C---------------------------------------------------------------------------
5251       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5252      &     E_tc)
5253       implicit real*8 (a-h,o-z)
5254       include 'DIMENSIONS'
5255       include 'COMMON.LOCAL'
5256       include 'COMMON.IOUNITS'
5257       common /calcthet/ term1,term2,termm,diffak,ratak,
5258      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5259      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5260 C Calculate the contributions to both Gaussian lobes.
5261 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5262 C The "polynomial part" of the "standard deviation" of this part of
5263 C the distributioni.
5264 ccc        write (iout,*) thetai,thet_pred_mean
5265         sig=polthet(3,it)
5266         do j=2,0,-1
5267           sig=sig*thet_pred_mean+polthet(j,it)
5268         enddo
5269 C Derivative of the "interior part" of the "standard deviation of the"
5270 C gamma-dependent Gaussian lobe in t_c.
5271         sigtc=3*polthet(3,it)
5272         do j=2,1,-1
5273           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5274         enddo
5275         sigtc=sig*sigtc
5276 C Set the parameters of both Gaussian lobes of the distribution.
5277 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5278         fac=sig*sig+sigc0(it)
5279         sigcsq=fac+fac
5280         sigc=1.0D0/sigcsq
5281 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5282         sigsqtc=-4.0D0*sigcsq*sigtc
5283 c       print *,i,sig,sigtc,sigsqtc
5284 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5285         sigtc=-sigtc/(fac*fac)
5286 C Following variable is sigma(t_c)**(-2)
5287         sigcsq=sigcsq*sigcsq
5288         sig0i=sig0(it)
5289         sig0inv=1.0D0/sig0i**2
5290         delthec=thetai-thet_pred_mean
5291         delthe0=thetai-theta0i
5292         term1=-0.5D0*sigcsq*delthec*delthec
5293         term2=-0.5D0*sig0inv*delthe0*delthe0
5294 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5295 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5296 C NaNs in taking the logarithm. We extract the largest exponent which is added
5297 C to the energy (this being the log of the distribution) at the end of energy
5298 C term evaluation for this virtual-bond angle.
5299         if (term1.gt.term2) then
5300           termm=term1
5301           term2=dexp(term2-termm)
5302           term1=1.0d0
5303         else
5304           termm=term2
5305           term1=dexp(term1-termm)
5306           term2=1.0d0
5307         endif
5308 C The ratio between the gamma-independent and gamma-dependent lobes of
5309 C the distribution is a Gaussian function of thet_pred_mean too.
5310         diffak=gthet(2,it)-thet_pred_mean
5311         ratak=diffak/gthet(3,it)**2
5312         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5313 C Let's differentiate it in thet_pred_mean NOW.
5314         aktc=ak*ratak
5315 C Now put together the distribution terms to make complete distribution.
5316         termexp=term1+ak*term2
5317         termpre=sigc+ak*sig0i
5318 C Contribution of the bending energy from this theta is just the -log of
5319 C the sum of the contributions from the two lobes and the pre-exponential
5320 C factor. Simple enough, isn't it?
5321         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5322 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5323 C NOW the derivatives!!!
5324 C 6/6/97 Take into account the deformation.
5325         E_theta=(delthec*sigcsq*term1
5326      &       +ak*delthe0*sig0inv*term2)/termexp
5327         E_tc=((sigtc+aktc*sig0i)/termpre
5328      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5329      &       aktc*term2)/termexp)
5330       return
5331       end
5332 c-----------------------------------------------------------------------------
5333       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5334       implicit real*8 (a-h,o-z)
5335       include 'DIMENSIONS'
5336       include 'COMMON.LOCAL'
5337       include 'COMMON.IOUNITS'
5338       common /calcthet/ term1,term2,termm,diffak,ratak,
5339      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5340      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5341       delthec=thetai-thet_pred_mean
5342       delthe0=thetai-theta0i
5343 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5344       t3 = thetai-thet_pred_mean
5345       t6 = t3**2
5346       t9 = term1
5347       t12 = t3*sigcsq
5348       t14 = t12+t6*sigsqtc
5349       t16 = 1.0d0
5350       t21 = thetai-theta0i
5351       t23 = t21**2
5352       t26 = term2
5353       t27 = t21*t26
5354       t32 = termexp
5355       t40 = t32**2
5356       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5357      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5358      & *(-t12*t9-ak*sig0inv*t27)
5359       return
5360       end
5361 #else
5362 C--------------------------------------------------------------------------
5363       subroutine ebend(etheta)
5364 C
5365 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5366 C angles gamma and its derivatives in consecutive thetas and gammas.
5367 C ab initio-derived potentials from
5368 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5369 C
5370       implicit real*8 (a-h,o-z)
5371       include 'DIMENSIONS'
5372       include 'COMMON.LOCAL'
5373       include 'COMMON.GEO'
5374       include 'COMMON.INTERACT'
5375       include 'COMMON.DERIV'
5376       include 'COMMON.VAR'
5377       include 'COMMON.CHAIN'
5378       include 'COMMON.IOUNITS'
5379       include 'COMMON.NAMES'
5380       include 'COMMON.FFIELD'
5381       include 'COMMON.CONTROL'
5382       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5383      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5384      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5385      & sinph1ph2(maxdouble,maxdouble)
5386       logical lprn /.false./, lprn1 /.false./
5387       etheta=0.0D0
5388       do i=ithet_start,ithet_end
5389 c        print *,i,itype(i-1),itype(i),itype(i-2)
5390         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5391      &  .or.itype(i).eq.ntyp1) cycle
5392 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5393
5394         if (iabs(itype(i+1)).eq.20) iblock=2
5395         if (iabs(itype(i+1)).ne.20) iblock=1
5396         dethetai=0.0d0
5397         dephii=0.0d0
5398         dephii1=0.0d0
5399         theti2=0.5d0*theta(i)
5400         ityp2=ithetyp((itype(i-1)))
5401         do k=1,nntheterm
5402           coskt(k)=dcos(k*theti2)
5403           sinkt(k)=dsin(k*theti2)
5404         enddo
5405         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5406 #ifdef OSF
5407           phii=phi(i)
5408           if (phii.ne.phii) phii=150.0
5409 #else
5410           phii=phi(i)
5411 #endif
5412           ityp1=ithetyp((itype(i-2)))
5413 C propagation of chirality for glycine type
5414           do k=1,nsingle
5415             cosph1(k)=dcos(k*phii)
5416             sinph1(k)=dsin(k*phii)
5417           enddo
5418         else
5419           phii=0.0d0
5420           ityp1=nthetyp+1
5421           do k=1,nsingle
5422             cosph1(k)=0.0d0
5423             sinph1(k)=0.0d0
5424           enddo
5425         endif
5426         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5427 #ifdef OSF
5428           phii1=phi(i+1)
5429           if (phii1.ne.phii1) phii1=150.0
5430           phii1=pinorm(phii1)
5431 #else
5432           phii1=phi(i+1)
5433 #endif
5434           ityp3=ithetyp((itype(i)))
5435           do k=1,nsingle
5436             cosph2(k)=dcos(k*phii1)
5437             sinph2(k)=dsin(k*phii1)
5438           enddo
5439         else
5440           phii1=0.0d0
5441           ityp3=nthetyp+1
5442           do k=1,nsingle
5443             cosph2(k)=0.0d0
5444             sinph2(k)=0.0d0
5445           enddo
5446         endif
5447         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5448         do k=1,ndouble
5449           do l=1,k-1
5450             ccl=cosph1(l)*cosph2(k-l)
5451             ssl=sinph1(l)*sinph2(k-l)
5452             scl=sinph1(l)*cosph2(k-l)
5453             csl=cosph1(l)*sinph2(k-l)
5454             cosph1ph2(l,k)=ccl-ssl
5455             cosph1ph2(k,l)=ccl+ssl
5456             sinph1ph2(l,k)=scl+csl
5457             sinph1ph2(k,l)=scl-csl
5458           enddo
5459         enddo
5460         if (lprn) then
5461         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5462      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5463         write (iout,*) "coskt and sinkt"
5464         do k=1,nntheterm
5465           write (iout,*) k,coskt(k),sinkt(k)
5466         enddo
5467         endif
5468         do k=1,ntheterm
5469           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5470           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5471      &      *coskt(k)
5472           if (lprn)
5473      &    write (iout,*) "k",k,"
5474      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5475      &     " ethetai",ethetai
5476         enddo
5477         if (lprn) then
5478         write (iout,*) "cosph and sinph"
5479         do k=1,nsingle
5480           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5481         enddo
5482         write (iout,*) "cosph1ph2 and sinph2ph2"
5483         do k=2,ndouble
5484           do l=1,k-1
5485             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5486      &         sinph1ph2(l,k),sinph1ph2(k,l)
5487           enddo
5488         enddo
5489         write(iout,*) "ethetai",ethetai
5490         endif
5491         do m=1,ntheterm2
5492           do k=1,nsingle
5493             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5494      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5495      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5496      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5497             ethetai=ethetai+sinkt(m)*aux
5498             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5499             dephii=dephii+k*sinkt(m)*(
5500      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5501      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5502             dephii1=dephii1+k*sinkt(m)*(
5503      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5504      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5505             if (lprn)
5506      &      write (iout,*) "m",m," k",k," bbthet",
5507      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5508      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5509      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5510      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5511           enddo
5512         enddo
5513         if (lprn)
5514      &  write(iout,*) "ethetai",ethetai
5515         do m=1,ntheterm3
5516           do k=2,ndouble
5517             do l=1,k-1
5518               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5519      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5520      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5521      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5522               ethetai=ethetai+sinkt(m)*aux
5523               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5524               dephii=dephii+l*sinkt(m)*(
5525      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5526      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5527      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5528      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5529               dephii1=dephii1+(k-l)*sinkt(m)*(
5530      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5531      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5532      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5533      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5534               if (lprn) then
5535               write (iout,*) "m",m," k",k," l",l," ffthet",
5536      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5537      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5538      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5539      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5540      &            " ethetai",ethetai
5541               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5542      &            cosph1ph2(k,l)*sinkt(m),
5543      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5544               endif
5545             enddo
5546           enddo
5547         enddo
5548 10      continue
5549 c        lprn1=.true.
5550         if (lprn1)
5551      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5552      &   i,theta(i)*rad2deg,phii*rad2deg,
5553      &   phii1*rad2deg,ethetai
5554 c        lprn1=.false.
5555         etheta=etheta+ethetai
5556         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5557         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5558         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5559       enddo
5560       return
5561       end
5562 #endif
5563 #ifdef CRYST_SC
5564 c-----------------------------------------------------------------------------
5565       subroutine esc(escloc)
5566 C Calculate the local energy of a side chain and its derivatives in the
5567 C corresponding virtual-bond valence angles THETA and the spherical angles
5568 C ALPHA and OMEGA.
5569       implicit real*8 (a-h,o-z)
5570       include 'DIMENSIONS'
5571       include 'COMMON.GEO'
5572       include 'COMMON.LOCAL'
5573       include 'COMMON.VAR'
5574       include 'COMMON.INTERACT'
5575       include 'COMMON.DERIV'
5576       include 'COMMON.CHAIN'
5577       include 'COMMON.IOUNITS'
5578       include 'COMMON.NAMES'
5579       include 'COMMON.FFIELD'
5580       include 'COMMON.CONTROL'
5581       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5582      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5583       common /sccalc/ time11,time12,time112,theti,it,nlobit
5584       delta=0.02d0*pi
5585       escloc=0.0D0
5586 c     write (iout,'(a)') 'ESC'
5587       do i=loc_start,loc_end
5588         it=itype(i)
5589         if (it.eq.ntyp1) cycle
5590         if (it.eq.10) goto 1
5591         nlobit=nlob(iabs(it))
5592 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5593 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5594         theti=theta(i+1)-pipol
5595         x(1)=dtan(theti)
5596         x(2)=alph(i)
5597         x(3)=omeg(i)
5598
5599         if (x(2).gt.pi-delta) then
5600           xtemp(1)=x(1)
5601           xtemp(2)=pi-delta
5602           xtemp(3)=x(3)
5603           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5604           xtemp(2)=pi
5605           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5606           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5607      &        escloci,dersc(2))
5608           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5609      &        ddersc0(1),dersc(1))
5610           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5611      &        ddersc0(3),dersc(3))
5612           xtemp(2)=pi-delta
5613           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5614           xtemp(2)=pi
5615           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5616           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5617      &            dersc0(2),esclocbi,dersc02)
5618           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5619      &            dersc12,dersc01)
5620           call splinthet(x(2),0.5d0*delta,ss,ssd)
5621           dersc0(1)=dersc01
5622           dersc0(2)=dersc02
5623           dersc0(3)=0.0d0
5624           do k=1,3
5625             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5626           enddo
5627           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5628 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5629 c    &             esclocbi,ss,ssd
5630           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5631 c         escloci=esclocbi
5632 c         write (iout,*) escloci
5633         else if (x(2).lt.delta) then
5634           xtemp(1)=x(1)
5635           xtemp(2)=delta
5636           xtemp(3)=x(3)
5637           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5638           xtemp(2)=0.0d0
5639           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5640           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5641      &        escloci,dersc(2))
5642           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5643      &        ddersc0(1),dersc(1))
5644           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5645      &        ddersc0(3),dersc(3))
5646           xtemp(2)=delta
5647           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5648           xtemp(2)=0.0d0
5649           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5650           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5651      &            dersc0(2),esclocbi,dersc02)
5652           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5653      &            dersc12,dersc01)
5654           dersc0(1)=dersc01
5655           dersc0(2)=dersc02
5656           dersc0(3)=0.0d0
5657           call splinthet(x(2),0.5d0*delta,ss,ssd)
5658           do k=1,3
5659             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5660           enddo
5661           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5662 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5663 c    &             esclocbi,ss,ssd
5664           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5665 c         write (iout,*) escloci
5666         else
5667           call enesc(x,escloci,dersc,ddummy,.false.)
5668         endif
5669
5670         escloc=escloc+escloci
5671         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5672      &     'escloc',i,escloci
5673 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5674
5675         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5676      &   wscloc*dersc(1)
5677         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5678         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5679     1   continue
5680       enddo
5681       return
5682       end
5683 C---------------------------------------------------------------------------
5684       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5685       implicit real*8 (a-h,o-z)
5686       include 'DIMENSIONS'
5687       include 'COMMON.GEO'
5688       include 'COMMON.LOCAL'
5689       include 'COMMON.IOUNITS'
5690       common /sccalc/ time11,time12,time112,theti,it,nlobit
5691       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5692       double precision contr(maxlob,-1:1)
5693       logical mixed
5694 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5695         escloc_i=0.0D0
5696         do j=1,3
5697           dersc(j)=0.0D0
5698           if (mixed) ddersc(j)=0.0d0
5699         enddo
5700         x3=x(3)
5701
5702 C Because of periodicity of the dependence of the SC energy in omega we have
5703 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5704 C To avoid underflows, first compute & store the exponents.
5705
5706         do iii=-1,1
5707
5708           x(3)=x3+iii*dwapi
5709
5710           do j=1,nlobit
5711             do k=1,3
5712               z(k)=x(k)-censc(k,j,it)
5713             enddo
5714             do k=1,3
5715               Axk=0.0D0
5716               do l=1,3
5717                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5718               enddo
5719               Ax(k,j,iii)=Axk
5720             enddo
5721             expfac=0.0D0
5722             do k=1,3
5723               expfac=expfac+Ax(k,j,iii)*z(k)
5724             enddo
5725             contr(j,iii)=expfac
5726           enddo ! j
5727
5728         enddo ! iii
5729
5730         x(3)=x3
5731 C As in the case of ebend, we want to avoid underflows in exponentiation and
5732 C subsequent NaNs and INFs in energy calculation.
5733 C Find the largest exponent
5734         emin=contr(1,-1)
5735         do iii=-1,1
5736           do j=1,nlobit
5737             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5738           enddo
5739         enddo
5740         emin=0.5D0*emin
5741 cd      print *,'it=',it,' emin=',emin
5742
5743 C Compute the contribution to SC energy and derivatives
5744         do iii=-1,1
5745
5746           do j=1,nlobit
5747 #ifdef OSF
5748             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5749             if(adexp.ne.adexp) adexp=1.0
5750             expfac=dexp(adexp)
5751 #else
5752             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5753 #endif
5754 cd          print *,'j=',j,' expfac=',expfac
5755             escloc_i=escloc_i+expfac
5756             do k=1,3
5757               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5758             enddo
5759             if (mixed) then
5760               do k=1,3,2
5761                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5762      &            +gaussc(k,2,j,it))*expfac
5763               enddo
5764             endif
5765           enddo
5766
5767         enddo ! iii
5768
5769         dersc(1)=dersc(1)/cos(theti)**2
5770         ddersc(1)=ddersc(1)/cos(theti)**2
5771         ddersc(3)=ddersc(3)
5772
5773         escloci=-(dlog(escloc_i)-emin)
5774         do j=1,3
5775           dersc(j)=dersc(j)/escloc_i
5776         enddo
5777         if (mixed) then
5778           do j=1,3,2
5779             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5780           enddo
5781         endif
5782       return
5783       end
5784 C------------------------------------------------------------------------------
5785       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5786       implicit real*8 (a-h,o-z)
5787       include 'DIMENSIONS'
5788       include 'COMMON.GEO'
5789       include 'COMMON.LOCAL'
5790       include 'COMMON.IOUNITS'
5791       common /sccalc/ time11,time12,time112,theti,it,nlobit
5792       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5793       double precision contr(maxlob)
5794       logical mixed
5795
5796       escloc_i=0.0D0
5797
5798       do j=1,3
5799         dersc(j)=0.0D0
5800       enddo
5801
5802       do j=1,nlobit
5803         do k=1,2
5804           z(k)=x(k)-censc(k,j,it)
5805         enddo
5806         z(3)=dwapi
5807         do k=1,3
5808           Axk=0.0D0
5809           do l=1,3
5810             Axk=Axk+gaussc(l,k,j,it)*z(l)
5811           enddo
5812           Ax(k,j)=Axk
5813         enddo
5814         expfac=0.0D0
5815         do k=1,3
5816           expfac=expfac+Ax(k,j)*z(k)
5817         enddo
5818         contr(j)=expfac
5819       enddo ! j
5820
5821 C As in the case of ebend, we want to avoid underflows in exponentiation and
5822 C subsequent NaNs and INFs in energy calculation.
5823 C Find the largest exponent
5824       emin=contr(1)
5825       do j=1,nlobit
5826         if (emin.gt.contr(j)) emin=contr(j)
5827       enddo
5828       emin=0.5D0*emin
5829
5830 C Compute the contribution to SC energy and derivatives
5831
5832       dersc12=0.0d0
5833       do j=1,nlobit
5834         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5835         escloc_i=escloc_i+expfac
5836         do k=1,2
5837           dersc(k)=dersc(k)+Ax(k,j)*expfac
5838         enddo
5839         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5840      &            +gaussc(1,2,j,it))*expfac
5841         dersc(3)=0.0d0
5842       enddo
5843
5844       dersc(1)=dersc(1)/cos(theti)**2
5845       dersc12=dersc12/cos(theti)**2
5846       escloci=-(dlog(escloc_i)-emin)
5847       do j=1,2
5848         dersc(j)=dersc(j)/escloc_i
5849       enddo
5850       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5851       return
5852       end
5853 #else
5854 c----------------------------------------------------------------------------------
5855       subroutine esc(escloc)
5856 C Calculate the local energy of a side chain and its derivatives in the
5857 C corresponding virtual-bond valence angles THETA and the spherical angles
5858 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5859 C added by Urszula Kozlowska. 07/11/2007
5860 C
5861       implicit real*8 (a-h,o-z)
5862       include 'DIMENSIONS'
5863       include 'COMMON.GEO'
5864       include 'COMMON.LOCAL'
5865       include 'COMMON.VAR'
5866       include 'COMMON.SCROT'
5867       include 'COMMON.INTERACT'
5868       include 'COMMON.DERIV'
5869       include 'COMMON.CHAIN'
5870       include 'COMMON.IOUNITS'
5871       include 'COMMON.NAMES'
5872       include 'COMMON.FFIELD'
5873       include 'COMMON.CONTROL'
5874       include 'COMMON.VECTORS'
5875       double precision x_prime(3),y_prime(3),z_prime(3)
5876      &    , sumene,dsc_i,dp2_i,x(65),
5877      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5878      &    de_dxx,de_dyy,de_dzz,de_dt
5879       double precision s1_t,s1_6_t,s2_t,s2_6_t
5880       double precision
5881      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5882      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5883      & dt_dCi(3),dt_dCi1(3)
5884       common /sccalc/ time11,time12,time112,theti,it,nlobit
5885       delta=0.02d0*pi
5886       escloc=0.0D0
5887       do i=loc_start,loc_end
5888         if (itype(i).eq.ntyp1) cycle
5889         costtab(i+1) =dcos(theta(i+1))
5890         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5891         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5892         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5893         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5894         cosfac=dsqrt(cosfac2)
5895         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5896         sinfac=dsqrt(sinfac2)
5897         it=iabs(itype(i))
5898         if (it.eq.10) goto 1
5899 c
5900 C  Compute the axes of tghe local cartesian coordinates system; store in
5901 c   x_prime, y_prime and z_prime
5902 c
5903         do j=1,3
5904           x_prime(j) = 0.00
5905           y_prime(j) = 0.00
5906           z_prime(j) = 0.00
5907         enddo
5908 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5909 C     &   dc_norm(3,i+nres)
5910         do j = 1,3
5911           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5912           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5913         enddo
5914         do j = 1,3
5915           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5916         enddo
5917 c       write (2,*) "i",i
5918 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5919 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5920 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5921 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5922 c      & " xy",scalar(x_prime(1),y_prime(1)),
5923 c      & " xz",scalar(x_prime(1),z_prime(1)),
5924 c      & " yy",scalar(y_prime(1),y_prime(1)),
5925 c      & " yz",scalar(y_prime(1),z_prime(1)),
5926 c      & " zz",scalar(z_prime(1),z_prime(1))
5927 c
5928 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5929 C to local coordinate system. Store in xx, yy, zz.
5930 c
5931         xx=0.0d0
5932         yy=0.0d0
5933         zz=0.0d0
5934         do j = 1,3
5935           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5936           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5937           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5938         enddo
5939
5940         xxtab(i)=xx
5941         yytab(i)=yy
5942         zztab(i)=zz
5943 C
5944 C Compute the energy of the ith side cbain
5945 C
5946 c        write (2,*) "xx",xx," yy",yy," zz",zz
5947         it=iabs(itype(i))
5948         do j = 1,65
5949           x(j) = sc_parmin(j,it)
5950         enddo
5951 #ifdef CHECK_COORD
5952 Cc diagnostics - remove later
5953         xx1 = dcos(alph(2))
5954         yy1 = dsin(alph(2))*dcos(omeg(2))
5955         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5956         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5957      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5958      &    xx1,yy1,zz1
5959 C,"  --- ", xx_w,yy_w,zz_w
5960 c end diagnostics
5961 #endif
5962         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5963      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5964      &   + x(10)*yy*zz
5965         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5966      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5967      & + x(20)*yy*zz
5968         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5969      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5970      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5971      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5972      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5973      &  +x(40)*xx*yy*zz
5974         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5975      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5976      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5977      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5978      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5979      &  +x(60)*xx*yy*zz
5980         dsc_i   = 0.743d0+x(61)
5981         dp2_i   = 1.9d0+x(62)
5982         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5983      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5984         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5985      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5986         s1=(1+x(63))/(0.1d0 + dscp1)
5987         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5988         s2=(1+x(65))/(0.1d0 + dscp2)
5989         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5990         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5991      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5992 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5993 c     &   sumene4,
5994 c     &   dscp1,dscp2,sumene
5995 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5996         escloc = escloc + sumene
5997 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5998 c     & ,zz,xx,yy
5999 c#define DEBUG
6000 #ifdef DEBUG
6001 C
6002 C This section to check the numerical derivatives of the energy of ith side
6003 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6004 C #define DEBUG in the code to turn it on.
6005 C
6006         write (2,*) "sumene               =",sumene
6007         aincr=1.0d-7
6008         xxsave=xx
6009         xx=xx+aincr
6010         write (2,*) xx,yy,zz
6011         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6012         de_dxx_num=(sumenep-sumene)/aincr
6013         xx=xxsave
6014         write (2,*) "xx+ sumene from enesc=",sumenep
6015         yysave=yy
6016         yy=yy+aincr
6017         write (2,*) xx,yy,zz
6018         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6019         de_dyy_num=(sumenep-sumene)/aincr
6020         yy=yysave
6021         write (2,*) "yy+ sumene from enesc=",sumenep
6022         zzsave=zz
6023         zz=zz+aincr
6024         write (2,*) xx,yy,zz
6025         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6026         de_dzz_num=(sumenep-sumene)/aincr
6027         zz=zzsave
6028         write (2,*) "zz+ sumene from enesc=",sumenep
6029         costsave=cost2tab(i+1)
6030         sintsave=sint2tab(i+1)
6031         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6032         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6033         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6034         de_dt_num=(sumenep-sumene)/aincr
6035         write (2,*) " t+ sumene from enesc=",sumenep
6036         cost2tab(i+1)=costsave
6037         sint2tab(i+1)=sintsave
6038 C End of diagnostics section.
6039 #endif
6040 C
6041 C Compute the gradient of esc
6042 C
6043 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6044         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6045         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6046         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6047         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6048         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6049         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6050         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6051         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6052         pom1=(sumene3*sint2tab(i+1)+sumene1)
6053      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6054         pom2=(sumene4*cost2tab(i+1)+sumene2)
6055      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6056         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6057         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6058      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6059      &  +x(40)*yy*zz
6060         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6061         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6062      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6063      &  +x(60)*yy*zz
6064         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6065      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6066      &        +(pom1+pom2)*pom_dx
6067 #ifdef DEBUG
6068         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6069 #endif
6070 C
6071         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6072         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6073      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6074      &  +x(40)*xx*zz
6075         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6076         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6077      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6078      &  +x(59)*zz**2 +x(60)*xx*zz
6079         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6080      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6081      &        +(pom1-pom2)*pom_dy
6082 #ifdef DEBUG
6083         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6084 #endif
6085 C
6086         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6087      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6088      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6089      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6090      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6091      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6092      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6093      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6094 #ifdef DEBUG
6095         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6096 #endif
6097 C
6098         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6099      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6100      &  +pom1*pom_dt1+pom2*pom_dt2
6101 #ifdef DEBUG
6102         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6103 #endif
6104 c#undef DEBUG
6105 c
6106 C
6107        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6108        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6109        cosfac2xx=cosfac2*xx
6110        sinfac2yy=sinfac2*yy
6111        do k = 1,3
6112          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6113      &      vbld_inv(i+1)
6114          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6115      &      vbld_inv(i)
6116          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6117          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6118 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6119 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6120 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6121 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6122          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6123          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6124          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6125          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6126          dZZ_Ci1(k)=0.0d0
6127          dZZ_Ci(k)=0.0d0
6128          do j=1,3
6129            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6130      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6131            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6132      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6133          enddo
6134
6135          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6136          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6137          dZZ_XYZ(k)=vbld_inv(i+nres)*
6138      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6139 c
6140          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6141          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6142        enddo
6143
6144        do k=1,3
6145          dXX_Ctab(k,i)=dXX_Ci(k)
6146          dXX_C1tab(k,i)=dXX_Ci1(k)
6147          dYY_Ctab(k,i)=dYY_Ci(k)
6148          dYY_C1tab(k,i)=dYY_Ci1(k)
6149          dZZ_Ctab(k,i)=dZZ_Ci(k)
6150          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6151          dXX_XYZtab(k,i)=dXX_XYZ(k)
6152          dYY_XYZtab(k,i)=dYY_XYZ(k)
6153          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6154        enddo
6155
6156        do k = 1,3
6157 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6158 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6159 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6160 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6161 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6162 c     &    dt_dci(k)
6163 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6164 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6165          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6166      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6167          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6168      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6169          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6170      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6171        enddo
6172 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6173 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6174
6175 C to check gradient call subroutine check_grad
6176
6177     1 continue
6178       enddo
6179       return
6180       end
6181 c------------------------------------------------------------------------------
6182       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6183       implicit none
6184       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6185      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6186       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6187      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6188      &   + x(10)*yy*zz
6189       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6190      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6191      & + x(20)*yy*zz
6192       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6193      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6194      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6195      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6196      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6197      &  +x(40)*xx*yy*zz
6198       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6199      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6200      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6201      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6202      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6203      &  +x(60)*xx*yy*zz
6204       dsc_i   = 0.743d0+x(61)
6205       dp2_i   = 1.9d0+x(62)
6206       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6207      &          *(xx*cost2+yy*sint2))
6208       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6209      &          *(xx*cost2-yy*sint2))
6210       s1=(1+x(63))/(0.1d0 + dscp1)
6211       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6212       s2=(1+x(65))/(0.1d0 + dscp2)
6213       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6214       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6215      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6216       enesc=sumene
6217       return
6218       end
6219 #endif
6220 c------------------------------------------------------------------------------
6221       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6222 C
6223 C This procedure calculates two-body contact function g(rij) and its derivative:
6224 C
6225 C           eps0ij                                     !       x < -1
6226 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6227 C            0                                         !       x > 1
6228 C
6229 C where x=(rij-r0ij)/delta
6230 C
6231 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6232 C
6233       implicit none
6234       double precision rij,r0ij,eps0ij,fcont,fprimcont
6235       double precision x,x2,x4,delta
6236 c     delta=0.02D0*r0ij
6237 c      delta=0.2D0*r0ij
6238       x=(rij-r0ij)/delta
6239       if (x.lt.-1.0D0) then
6240         fcont=eps0ij
6241         fprimcont=0.0D0
6242       else if (x.le.1.0D0) then
6243         x2=x*x
6244         x4=x2*x2
6245         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6246         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6247       else
6248         fcont=0.0D0
6249         fprimcont=0.0D0
6250       endif
6251       return
6252       end
6253 c------------------------------------------------------------------------------
6254       subroutine splinthet(theti,delta,ss,ssder)
6255       implicit real*8 (a-h,o-z)
6256       include 'DIMENSIONS'
6257       include 'COMMON.VAR'
6258       include 'COMMON.GEO'
6259       thetup=pi-delta
6260       thetlow=delta
6261       if (theti.gt.pipol) then
6262         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6263       else
6264         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6265         ssder=-ssder
6266       endif
6267       return
6268       end
6269 c------------------------------------------------------------------------------
6270       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6271       implicit none
6272       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6273       double precision ksi,ksi2,ksi3,a1,a2,a3
6274       a1=fprim0*delta/(f1-f0)
6275       a2=3.0d0-2.0d0*a1
6276       a3=a1-2.0d0
6277       ksi=(x-x0)/delta
6278       ksi2=ksi*ksi
6279       ksi3=ksi2*ksi
6280       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6281       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6282       return
6283       end
6284 c------------------------------------------------------------------------------
6285       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6286       implicit none
6287       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6288       double precision ksi,ksi2,ksi3,a1,a2,a3
6289       ksi=(x-x0)/delta
6290       ksi2=ksi*ksi
6291       ksi3=ksi2*ksi
6292       a1=fprim0x*delta
6293       a2=3*(f1x-f0x)-2*fprim0x*delta
6294       a3=fprim0x*delta-2*(f1x-f0x)
6295       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6296       return
6297       end
6298 C-----------------------------------------------------------------------------
6299 #ifdef CRYST_TOR
6300 C-----------------------------------------------------------------------------
6301       subroutine etor(etors,edihcnstr)
6302       implicit real*8 (a-h,o-z)
6303       include 'DIMENSIONS'
6304       include 'COMMON.VAR'
6305       include 'COMMON.GEO'
6306       include 'COMMON.LOCAL'
6307       include 'COMMON.TORSION'
6308       include 'COMMON.INTERACT'
6309       include 'COMMON.DERIV'
6310       include 'COMMON.CHAIN'
6311       include 'COMMON.NAMES'
6312       include 'COMMON.IOUNITS'
6313       include 'COMMON.FFIELD'
6314       include 'COMMON.TORCNSTR'
6315       include 'COMMON.CONTROL'
6316       logical lprn
6317 C Set lprn=.true. for debugging
6318       lprn=.false.
6319 c      lprn=.true.
6320       etors=0.0D0
6321       do i=iphi_start,iphi_end
6322       etors_ii=0.0D0
6323         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6324      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6325         itori=itortyp(itype(i-2))
6326         itori1=itortyp(itype(i-1))
6327         phii=phi(i)
6328         gloci=0.0D0
6329 C Proline-Proline pair is a special case...
6330         if (itori.eq.3 .and. itori1.eq.3) then
6331           if (phii.gt.-dwapi3) then
6332             cosphi=dcos(3*phii)
6333             fac=1.0D0/(1.0D0-cosphi)
6334             etorsi=v1(1,3,3)*fac
6335             etorsi=etorsi+etorsi
6336             etors=etors+etorsi-v1(1,3,3)
6337             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6338             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6339           endif
6340           do j=1,3
6341             v1ij=v1(j+1,itori,itori1)
6342             v2ij=v2(j+1,itori,itori1)
6343             cosphi=dcos(j*phii)
6344             sinphi=dsin(j*phii)
6345             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6346             if (energy_dec) etors_ii=etors_ii+
6347      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6348             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6349           enddo
6350         else
6351           do j=1,nterm_old
6352             v1ij=v1(j,itori,itori1)
6353             v2ij=v2(j,itori,itori1)
6354             cosphi=dcos(j*phii)
6355             sinphi=dsin(j*phii)
6356             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6357             if (energy_dec) etors_ii=etors_ii+
6358      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6359             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6360           enddo
6361         endif
6362         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6363              'etor',i,etors_ii
6364         if (lprn)
6365      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6366      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6367      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6368         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6369 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6370       enddo
6371 ! 6/20/98 - dihedral angle constraints
6372       edihcnstr=0.0d0
6373       do i=1,ndih_constr
6374         itori=idih_constr(i)
6375         phii=phi(itori)
6376         difi=phii-phi0(i)
6377         if (difi.gt.drange(i)) then
6378           difi=difi-drange(i)
6379           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6380           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6381         else if (difi.lt.-drange(i)) then
6382           difi=difi+drange(i)
6383           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6384           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6385         endif
6386 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6387 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6388       enddo
6389 !      write (iout,*) 'edihcnstr',edihcnstr
6390       return
6391       end
6392 c------------------------------------------------------------------------------
6393       subroutine etor_d(etors_d)
6394       etors_d=0.0d0
6395       return
6396       end
6397 c----------------------------------------------------------------------------
6398 #else
6399       subroutine etor(etors,edihcnstr)
6400       implicit real*8 (a-h,o-z)
6401       include 'DIMENSIONS'
6402       include 'COMMON.VAR'
6403       include 'COMMON.GEO'
6404       include 'COMMON.LOCAL'
6405       include 'COMMON.TORSION'
6406       include 'COMMON.INTERACT'
6407       include 'COMMON.DERIV'
6408       include 'COMMON.CHAIN'
6409       include 'COMMON.NAMES'
6410       include 'COMMON.IOUNITS'
6411       include 'COMMON.FFIELD'
6412       include 'COMMON.TORCNSTR'
6413       include 'COMMON.CONTROL'
6414       logical lprn
6415 C Set lprn=.true. for debugging
6416       lprn=.false.
6417 c     lprn=.true.
6418       etors=0.0D0
6419       do i=iphi_start,iphi_end
6420 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6421 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6422 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6423 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6424         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6425      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6426 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6427 C For introducing the NH3+ and COO- group please check the etor_d for reference
6428 C and guidance
6429         etors_ii=0.0D0
6430          if (iabs(itype(i)).eq.20) then
6431          iblock=2
6432          else
6433          iblock=1
6434          endif
6435         itori=itortyp(itype(i-2))
6436         itori1=itortyp(itype(i-1))
6437         phii=phi(i)
6438         gloci=0.0D0
6439 C Regular cosine and sine terms
6440         do j=1,nterm(itori,itori1,iblock)
6441           v1ij=v1(j,itori,itori1,iblock)
6442           v2ij=v2(j,itori,itori1,iblock)
6443           cosphi=dcos(j*phii)
6444           sinphi=dsin(j*phii)
6445           etors=etors+v1ij*cosphi+v2ij*sinphi
6446           if (energy_dec) etors_ii=etors_ii+
6447      &                v1ij*cosphi+v2ij*sinphi
6448           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6449         enddo
6450 C Lorentz terms
6451 C                         v1
6452 C  E = SUM ----------------------------------- - v1
6453 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6454 C
6455         cosphi=dcos(0.5d0*phii)
6456         sinphi=dsin(0.5d0*phii)
6457         do j=1,nlor(itori,itori1,iblock)
6458           vl1ij=vlor1(j,itori,itori1)
6459           vl2ij=vlor2(j,itori,itori1)
6460           vl3ij=vlor3(j,itori,itori1)
6461           pom=vl2ij*cosphi+vl3ij*sinphi
6462           pom1=1.0d0/(pom*pom+1.0d0)
6463           etors=etors+vl1ij*pom1
6464           if (energy_dec) etors_ii=etors_ii+
6465      &                vl1ij*pom1
6466           pom=-pom*pom1*pom1
6467           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6468         enddo
6469 C Subtract the constant term
6470         etors=etors-v0(itori,itori1,iblock)
6471           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6472      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6473         if (lprn)
6474      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6475      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6476      &  (v1(j,itori,itori1,iblock),j=1,6),
6477      &  (v2(j,itori,itori1,iblock),j=1,6)
6478         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6479 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6480       enddo
6481 ! 6/20/98 - dihedral angle constraints
6482       edihcnstr=0.0d0
6483 c      do i=1,ndih_constr
6484       do i=idihconstr_start,idihconstr_end
6485         itori=idih_constr(i)
6486         phii=phi(itori)
6487         difi=pinorm(phii-phi0(i))
6488         if (difi.gt.drange(i)) then
6489           difi=difi-drange(i)
6490           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6491           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6492         else if (difi.lt.-drange(i)) then
6493           difi=difi+drange(i)
6494           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6495           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6496         else
6497           difi=0.0
6498         endif
6499 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6500 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6501 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6502       enddo
6503 cd       write (iout,*) 'edihcnstr',edihcnstr
6504       return
6505       end
6506 c----------------------------------------------------------------------------
6507       subroutine etor_d(etors_d)
6508 C 6/23/01 Compute double torsional energy
6509       implicit real*8 (a-h,o-z)
6510       include 'DIMENSIONS'
6511       include 'COMMON.VAR'
6512       include 'COMMON.GEO'
6513       include 'COMMON.LOCAL'
6514       include 'COMMON.TORSION'
6515       include 'COMMON.INTERACT'
6516       include 'COMMON.DERIV'
6517       include 'COMMON.CHAIN'
6518       include 'COMMON.NAMES'
6519       include 'COMMON.IOUNITS'
6520       include 'COMMON.FFIELD'
6521       include 'COMMON.TORCNSTR'
6522       logical lprn
6523 C Set lprn=.true. for debugging
6524       lprn=.false.
6525 c     lprn=.true.
6526       etors_d=0.0D0
6527 c      write(iout,*) "a tu??"
6528       do i=iphid_start,iphid_end
6529 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6530 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6531 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6532 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6533 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6534          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6535      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6536      &  (itype(i+1).eq.ntyp1)) cycle
6537 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6538         itori=itortyp(itype(i-2))
6539         itori1=itortyp(itype(i-1))
6540         itori2=itortyp(itype(i))
6541         phii=phi(i)
6542         phii1=phi(i+1)
6543         gloci1=0.0D0
6544         gloci2=0.0D0
6545         iblock=1
6546         if (iabs(itype(i+1)).eq.20) iblock=2
6547 C Iblock=2 Proline type
6548 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6549 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6550 C        if (itype(i+1).eq.ntyp1) iblock=3
6551 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6552 C IS or IS NOT need for this
6553 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6554 C        is (itype(i-3).eq.ntyp1) ntblock=2
6555 C        ntblock is N-terminal blocking group
6556
6557 C Regular cosine and sine terms
6558         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6559 C Example of changes for NH3+ blocking group
6560 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6561 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6562           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6563           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6564           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6565           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6566           cosphi1=dcos(j*phii)
6567           sinphi1=dsin(j*phii)
6568           cosphi2=dcos(j*phii1)
6569           sinphi2=dsin(j*phii1)
6570           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6571      &     v2cij*cosphi2+v2sij*sinphi2
6572           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6573           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6574         enddo
6575         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6576           do l=1,k-1
6577             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6578             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6579             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6580             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6581             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6582             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6583             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6584             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6585             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6586      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6587             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6588      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6589             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6590      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6591           enddo
6592         enddo
6593         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6594         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6595       enddo
6596       return
6597       end
6598 #endif
6599 c------------------------------------------------------------------------------
6600       subroutine eback_sc_corr(esccor)
6601 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6602 c        conformational states; temporarily implemented as differences
6603 c        between UNRES torsional potentials (dependent on three types of
6604 c        residues) and the torsional potentials dependent on all 20 types
6605 c        of residues computed from AM1  energy surfaces of terminally-blocked
6606 c        amino-acid residues.
6607       implicit real*8 (a-h,o-z)
6608       include 'DIMENSIONS'
6609       include 'COMMON.VAR'
6610       include 'COMMON.GEO'
6611       include 'COMMON.LOCAL'
6612       include 'COMMON.TORSION'
6613       include 'COMMON.SCCOR'
6614       include 'COMMON.INTERACT'
6615       include 'COMMON.DERIV'
6616       include 'COMMON.CHAIN'
6617       include 'COMMON.NAMES'
6618       include 'COMMON.IOUNITS'
6619       include 'COMMON.FFIELD'
6620       include 'COMMON.CONTROL'
6621       logical lprn
6622 C Set lprn=.true. for debugging
6623       lprn=.false.
6624 c      lprn=.true.
6625 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6626       esccor=0.0D0
6627       do i=itau_start,itau_end
6628         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6629         esccor_ii=0.0D0
6630         isccori=isccortyp(itype(i-2))
6631         isccori1=isccortyp(itype(i-1))
6632 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6633         phii=phi(i)
6634         do intertyp=1,3 !intertyp
6635 cc Added 09 May 2012 (Adasko)
6636 cc  Intertyp means interaction type of backbone mainchain correlation:
6637 c   1 = SC...Ca...Ca...Ca
6638 c   2 = Ca...Ca...Ca...SC
6639 c   3 = SC...Ca...Ca...SCi
6640         gloci=0.0D0
6641         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6642      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6643      &      (itype(i-1).eq.ntyp1)))
6644      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6645      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6646      &     .or.(itype(i).eq.ntyp1)))
6647      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6648      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6649      &      (itype(i-3).eq.ntyp1)))) cycle
6650         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6651         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6652      & cycle
6653        do j=1,nterm_sccor(isccori,isccori1)
6654           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6655           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6656           cosphi=dcos(j*tauangle(intertyp,i))
6657           sinphi=dsin(j*tauangle(intertyp,i))
6658           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6659           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6660         enddo
6661 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6662         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6663         if (lprn)
6664      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6665      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6666      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6667      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6668         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6669        enddo !intertyp
6670       enddo
6671
6672       return
6673       end
6674 c----------------------------------------------------------------------------
6675       subroutine multibody(ecorr)
6676 C This subroutine calculates multi-body contributions to energy following
6677 C the idea of Skolnick et al. If side chains I and J make a contact and
6678 C at the same time side chains I+1 and J+1 make a contact, an extra
6679 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6680       implicit real*8 (a-h,o-z)
6681       include 'DIMENSIONS'
6682       include 'COMMON.IOUNITS'
6683       include 'COMMON.DERIV'
6684       include 'COMMON.INTERACT'
6685       include 'COMMON.CONTACTS'
6686       double precision gx(3),gx1(3)
6687       logical lprn
6688
6689 C Set lprn=.true. for debugging
6690       lprn=.false.
6691
6692       if (lprn) then
6693         write (iout,'(a)') 'Contact function values:'
6694         do i=nnt,nct-2
6695           write (iout,'(i2,20(1x,i2,f10.5))')
6696      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6697         enddo
6698       endif
6699       ecorr=0.0D0
6700       do i=nnt,nct
6701         do j=1,3
6702           gradcorr(j,i)=0.0D0
6703           gradxorr(j,i)=0.0D0
6704         enddo
6705       enddo
6706       do i=nnt,nct-2
6707
6708         DO ISHIFT = 3,4
6709
6710         i1=i+ishift
6711         num_conti=num_cont(i)
6712         num_conti1=num_cont(i1)
6713         do jj=1,num_conti
6714           j=jcont(jj,i)
6715           do kk=1,num_conti1
6716             j1=jcont(kk,i1)
6717             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6718 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6719 cd   &                   ' ishift=',ishift
6720 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6721 C The system gains extra energy.
6722               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6723             endif   ! j1==j+-ishift
6724           enddo     ! kk
6725         enddo       ! jj
6726
6727         ENDDO ! ISHIFT
6728
6729       enddo         ! i
6730       return
6731       end
6732 c------------------------------------------------------------------------------
6733       double precision function esccorr(i,j,k,l,jj,kk)
6734       implicit real*8 (a-h,o-z)
6735       include 'DIMENSIONS'
6736       include 'COMMON.IOUNITS'
6737       include 'COMMON.DERIV'
6738       include 'COMMON.INTERACT'
6739       include 'COMMON.CONTACTS'
6740       double precision gx(3),gx1(3)
6741       logical lprn
6742       lprn=.false.
6743       eij=facont(jj,i)
6744       ekl=facont(kk,k)
6745 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6746 C Calculate the multi-body contribution to energy.
6747 C Calculate multi-body contributions to the gradient.
6748 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6749 cd   & k,l,(gacont(m,kk,k),m=1,3)
6750       do m=1,3
6751         gx(m) =ekl*gacont(m,jj,i)
6752         gx1(m)=eij*gacont(m,kk,k)
6753         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6754         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6755         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6756         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6757       enddo
6758       do m=i,j-1
6759         do ll=1,3
6760           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6761         enddo
6762       enddo
6763       do m=k,l-1
6764         do ll=1,3
6765           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6766         enddo
6767       enddo
6768       esccorr=-eij*ekl
6769       return
6770       end
6771 c------------------------------------------------------------------------------
6772       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6773 C This subroutine calculates multi-body contributions to hydrogen-bonding
6774       implicit real*8 (a-h,o-z)
6775       include 'DIMENSIONS'
6776       include 'COMMON.IOUNITS'
6777 #ifdef MPI
6778       include "mpif.h"
6779       parameter (max_cont=maxconts)
6780       parameter (max_dim=26)
6781       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6782       double precision zapas(max_dim,maxconts,max_fg_procs),
6783      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6784       common /przechowalnia/ zapas
6785       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6786      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6787 #endif
6788       include 'COMMON.SETUP'
6789       include 'COMMON.FFIELD'
6790       include 'COMMON.DERIV'
6791       include 'COMMON.INTERACT'
6792       include 'COMMON.CONTACTS'
6793       include 'COMMON.CONTROL'
6794       include 'COMMON.LOCAL'
6795       double precision gx(3),gx1(3),time00
6796       logical lprn,ldone
6797
6798 C Set lprn=.true. for debugging
6799       lprn=.false.
6800 #ifdef MPI
6801       n_corr=0
6802       n_corr1=0
6803       if (nfgtasks.le.1) goto 30
6804       if (lprn) then
6805         write (iout,'(a)') 'Contact function values before RECEIVE:'
6806         do i=nnt,nct-2
6807           write (iout,'(2i3,50(1x,i2,f5.2))')
6808      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6809      &    j=1,num_cont_hb(i))
6810         enddo
6811       endif
6812       call flush(iout)
6813       do i=1,ntask_cont_from
6814         ncont_recv(i)=0
6815       enddo
6816       do i=1,ntask_cont_to
6817         ncont_sent(i)=0
6818       enddo
6819 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6820 c     & ntask_cont_to
6821 C Make the list of contacts to send to send to other procesors
6822 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6823 c      call flush(iout)
6824       do i=iturn3_start,iturn3_end
6825 c        write (iout,*) "make contact list turn3",i," num_cont",
6826 c     &    num_cont_hb(i)
6827         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6828       enddo
6829       do i=iturn4_start,iturn4_end
6830 c        write (iout,*) "make contact list turn4",i," num_cont",
6831 c     &   num_cont_hb(i)
6832         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6833       enddo
6834       do ii=1,nat_sent
6835         i=iat_sent(ii)
6836 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6837 c     &    num_cont_hb(i)
6838         do j=1,num_cont_hb(i)
6839         do k=1,4
6840           jjc=jcont_hb(j,i)
6841           iproc=iint_sent_local(k,jjc,ii)
6842 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6843           if (iproc.gt.0) then
6844             ncont_sent(iproc)=ncont_sent(iproc)+1
6845             nn=ncont_sent(iproc)
6846             zapas(1,nn,iproc)=i
6847             zapas(2,nn,iproc)=jjc
6848             zapas(3,nn,iproc)=facont_hb(j,i)
6849             zapas(4,nn,iproc)=ees0p(j,i)
6850             zapas(5,nn,iproc)=ees0m(j,i)
6851             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6852             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6853             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6854             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6855             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6856             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6857             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6858             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6859             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6860             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6861             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6862             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6863             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6864             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6865             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6866             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6867             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6868             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6869             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6870             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6871             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6872           endif
6873         enddo
6874         enddo
6875       enddo
6876       if (lprn) then
6877       write (iout,*)
6878      &  "Numbers of contacts to be sent to other processors",
6879      &  (ncont_sent(i),i=1,ntask_cont_to)
6880       write (iout,*) "Contacts sent"
6881       do ii=1,ntask_cont_to
6882         nn=ncont_sent(ii)
6883         iproc=itask_cont_to(ii)
6884         write (iout,*) nn," contacts to processor",iproc,
6885      &   " of CONT_TO_COMM group"
6886         do i=1,nn
6887           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6888         enddo
6889       enddo
6890       call flush(iout)
6891       endif
6892       CorrelType=477
6893       CorrelID=fg_rank+1
6894       CorrelType1=478
6895       CorrelID1=nfgtasks+fg_rank+1
6896       ireq=0
6897 C Receive the numbers of needed contacts from other processors
6898       do ii=1,ntask_cont_from
6899         iproc=itask_cont_from(ii)
6900         ireq=ireq+1
6901         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6902      &    FG_COMM,req(ireq),IERR)
6903       enddo
6904 c      write (iout,*) "IRECV ended"
6905 c      call flush(iout)
6906 C Send the number of contacts needed by other processors
6907       do ii=1,ntask_cont_to
6908         iproc=itask_cont_to(ii)
6909         ireq=ireq+1
6910         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6911      &    FG_COMM,req(ireq),IERR)
6912       enddo
6913 c      write (iout,*) "ISEND ended"
6914 c      write (iout,*) "number of requests (nn)",ireq
6915       call flush(iout)
6916       if (ireq.gt.0)
6917      &  call MPI_Waitall(ireq,req,status_array,ierr)
6918 c      write (iout,*)
6919 c     &  "Numbers of contacts to be received from other processors",
6920 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6921 c      call flush(iout)
6922 C Receive contacts
6923       ireq=0
6924       do ii=1,ntask_cont_from
6925         iproc=itask_cont_from(ii)
6926         nn=ncont_recv(ii)
6927 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6928 c     &   " of CONT_TO_COMM group"
6929         call flush(iout)
6930         if (nn.gt.0) then
6931           ireq=ireq+1
6932           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6933      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6934 c          write (iout,*) "ireq,req",ireq,req(ireq)
6935         endif
6936       enddo
6937 C Send the contacts to processors that need them
6938       do ii=1,ntask_cont_to
6939         iproc=itask_cont_to(ii)
6940         nn=ncont_sent(ii)
6941 c        write (iout,*) nn," contacts to processor",iproc,
6942 c     &   " of CONT_TO_COMM group"
6943         if (nn.gt.0) then
6944           ireq=ireq+1
6945           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6946      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6947 c          write (iout,*) "ireq,req",ireq,req(ireq)
6948 c          do i=1,nn
6949 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6950 c          enddo
6951         endif
6952       enddo
6953 c      write (iout,*) "number of requests (contacts)",ireq
6954 c      write (iout,*) "req",(req(i),i=1,4)
6955 c      call flush(iout)
6956       if (ireq.gt.0)
6957      & call MPI_Waitall(ireq,req,status_array,ierr)
6958       do iii=1,ntask_cont_from
6959         iproc=itask_cont_from(iii)
6960         nn=ncont_recv(iii)
6961         if (lprn) then
6962         write (iout,*) "Received",nn," contacts from processor",iproc,
6963      &   " of CONT_FROM_COMM group"
6964         call flush(iout)
6965         do i=1,nn
6966           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6967         enddo
6968         call flush(iout)
6969         endif
6970         do i=1,nn
6971           ii=zapas_recv(1,i,iii)
6972 c Flag the received contacts to prevent double-counting
6973           jj=-zapas_recv(2,i,iii)
6974 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6975 c          call flush(iout)
6976           nnn=num_cont_hb(ii)+1
6977           num_cont_hb(ii)=nnn
6978           jcont_hb(nnn,ii)=jj
6979           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6980           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6981           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6982           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6983           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6984           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6985           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6986           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6987           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6988           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6989           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6990           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6991           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6992           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6993           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6994           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6995           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6996           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6997           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6998           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6999           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7000           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7001           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7002           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7003         enddo
7004       enddo
7005       call flush(iout)
7006       if (lprn) then
7007         write (iout,'(a)') 'Contact function values after receive:'
7008         do i=nnt,nct-2
7009           write (iout,'(2i3,50(1x,i3,f5.2))')
7010      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7011      &    j=1,num_cont_hb(i))
7012         enddo
7013         call flush(iout)
7014       endif
7015    30 continue
7016 #endif
7017       if (lprn) then
7018         write (iout,'(a)') 'Contact function values:'
7019         do i=nnt,nct-2
7020           write (iout,'(2i3,50(1x,i3,f5.2))')
7021      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7022      &    j=1,num_cont_hb(i))
7023         enddo
7024       endif
7025       ecorr=0.0D0
7026 C Remove the loop below after debugging !!!
7027       do i=nnt,nct
7028         do j=1,3
7029           gradcorr(j,i)=0.0D0
7030           gradxorr(j,i)=0.0D0
7031         enddo
7032       enddo
7033 C Calculate the local-electrostatic correlation terms
7034       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7035         i1=i+1
7036         num_conti=num_cont_hb(i)
7037         num_conti1=num_cont_hb(i+1)
7038         do jj=1,num_conti
7039           j=jcont_hb(jj,i)
7040           jp=iabs(j)
7041           do kk=1,num_conti1
7042             j1=jcont_hb(kk,i1)
7043             jp1=iabs(j1)
7044 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7045 c     &         ' jj=',jj,' kk=',kk
7046             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7047      &          .or. j.lt.0 .and. j1.gt.0) .and.
7048      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7049 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7050 C The system gains extra energy.
7051               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7052               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7053      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7054               n_corr=n_corr+1
7055             else if (j1.eq.j) then
7056 C Contacts I-J and I-(J+1) occur simultaneously.
7057 C The system loses extra energy.
7058 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7059             endif
7060           enddo ! kk
7061           do kk=1,num_conti
7062             j1=jcont_hb(kk,i)
7063 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7064 c    &         ' jj=',jj,' kk=',kk
7065             if (j1.eq.j+1) then
7066 C Contacts I-J and (I+1)-J occur simultaneously.
7067 C The system loses extra energy.
7068 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7069             endif ! j1==j+1
7070           enddo ! kk
7071         enddo ! jj
7072       enddo ! i
7073       return
7074       end
7075 c------------------------------------------------------------------------------
7076       subroutine add_hb_contact(ii,jj,itask)
7077       implicit real*8 (a-h,o-z)
7078       include "DIMENSIONS"
7079       include "COMMON.IOUNITS"
7080       integer max_cont
7081       integer max_dim
7082       parameter (max_cont=maxconts)
7083       parameter (max_dim=26)
7084       include "COMMON.CONTACTS"
7085       double precision zapas(max_dim,maxconts,max_fg_procs),
7086      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7087       common /przechowalnia/ zapas
7088       integer i,j,ii,jj,iproc,itask(4),nn
7089 c      write (iout,*) "itask",itask
7090       do i=1,2
7091         iproc=itask(i)
7092         if (iproc.gt.0) then
7093           do j=1,num_cont_hb(ii)
7094             jjc=jcont_hb(j,ii)
7095 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7096             if (jjc.eq.jj) then
7097               ncont_sent(iproc)=ncont_sent(iproc)+1
7098               nn=ncont_sent(iproc)
7099               zapas(1,nn,iproc)=ii
7100               zapas(2,nn,iproc)=jjc
7101               zapas(3,nn,iproc)=facont_hb(j,ii)
7102               zapas(4,nn,iproc)=ees0p(j,ii)
7103               zapas(5,nn,iproc)=ees0m(j,ii)
7104               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7105               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7106               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7107               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7108               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7109               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7110               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7111               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7112               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7113               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7114               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7115               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7116               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7117               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7118               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7119               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7120               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7121               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7122               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7123               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7124               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7125               exit
7126             endif
7127           enddo
7128         endif
7129       enddo
7130       return
7131       end
7132 c------------------------------------------------------------------------------
7133       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7134      &  n_corr1)
7135 C This subroutine calculates multi-body contributions to hydrogen-bonding
7136       implicit real*8 (a-h,o-z)
7137       include 'DIMENSIONS'
7138       include 'COMMON.IOUNITS'
7139 #ifdef MPI
7140       include "mpif.h"
7141       parameter (max_cont=maxconts)
7142       parameter (max_dim=70)
7143       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7144       double precision zapas(max_dim,maxconts,max_fg_procs),
7145      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7146       common /przechowalnia/ zapas
7147       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7148      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7149 #endif
7150       include 'COMMON.SETUP'
7151       include 'COMMON.FFIELD'
7152       include 'COMMON.DERIV'
7153       include 'COMMON.LOCAL'
7154       include 'COMMON.INTERACT'
7155       include 'COMMON.CONTACTS'
7156       include 'COMMON.CHAIN'
7157       include 'COMMON.CONTROL'
7158       double precision gx(3),gx1(3)
7159       integer num_cont_hb_old(maxres)
7160       logical lprn,ldone
7161       double precision eello4,eello5,eelo6,eello_turn6
7162       external eello4,eello5,eello6,eello_turn6
7163 C Set lprn=.true. for debugging
7164       lprn=.false.
7165       eturn6=0.0d0
7166 #ifdef MPI
7167       do i=1,nres
7168         num_cont_hb_old(i)=num_cont_hb(i)
7169       enddo
7170       n_corr=0
7171       n_corr1=0
7172       if (nfgtasks.le.1) goto 30
7173       if (lprn) then
7174         write (iout,'(a)') 'Contact function values before RECEIVE:'
7175         do i=nnt,nct-2
7176           write (iout,'(2i3,50(1x,i2,f5.2))')
7177      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7178      &    j=1,num_cont_hb(i))
7179         enddo
7180       endif
7181       call flush(iout)
7182       do i=1,ntask_cont_from
7183         ncont_recv(i)=0
7184       enddo
7185       do i=1,ntask_cont_to
7186         ncont_sent(i)=0
7187       enddo
7188 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7189 c     & ntask_cont_to
7190 C Make the list of contacts to send to send to other procesors
7191       do i=iturn3_start,iturn3_end
7192 c        write (iout,*) "make contact list turn3",i," num_cont",
7193 c     &    num_cont_hb(i)
7194         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7195       enddo
7196       do i=iturn4_start,iturn4_end
7197 c        write (iout,*) "make contact list turn4",i," num_cont",
7198 c     &   num_cont_hb(i)
7199         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7200       enddo
7201       do ii=1,nat_sent
7202         i=iat_sent(ii)
7203 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7204 c     &    num_cont_hb(i)
7205         do j=1,num_cont_hb(i)
7206         do k=1,4
7207           jjc=jcont_hb(j,i)
7208           iproc=iint_sent_local(k,jjc,ii)
7209 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7210           if (iproc.ne.0) then
7211             ncont_sent(iproc)=ncont_sent(iproc)+1
7212             nn=ncont_sent(iproc)
7213             zapas(1,nn,iproc)=i
7214             zapas(2,nn,iproc)=jjc
7215             zapas(3,nn,iproc)=d_cont(j,i)
7216             ind=3
7217             do kk=1,3
7218               ind=ind+1
7219               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7220             enddo
7221             do kk=1,2
7222               do ll=1,2
7223                 ind=ind+1
7224                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7225               enddo
7226             enddo
7227             do jj=1,5
7228               do kk=1,3
7229                 do ll=1,2
7230                   do mm=1,2
7231                     ind=ind+1
7232                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7233                   enddo
7234                 enddo
7235               enddo
7236             enddo
7237           endif
7238         enddo
7239         enddo
7240       enddo
7241       if (lprn) then
7242       write (iout,*)
7243      &  "Numbers of contacts to be sent to other processors",
7244      &  (ncont_sent(i),i=1,ntask_cont_to)
7245       write (iout,*) "Contacts sent"
7246       do ii=1,ntask_cont_to
7247         nn=ncont_sent(ii)
7248         iproc=itask_cont_to(ii)
7249         write (iout,*) nn," contacts to processor",iproc,
7250      &   " of CONT_TO_COMM group"
7251         do i=1,nn
7252           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7253         enddo
7254       enddo
7255       call flush(iout)
7256       endif
7257       CorrelType=477
7258       CorrelID=fg_rank+1
7259       CorrelType1=478
7260       CorrelID1=nfgtasks+fg_rank+1
7261       ireq=0
7262 C Receive the numbers of needed contacts from other processors
7263       do ii=1,ntask_cont_from
7264         iproc=itask_cont_from(ii)
7265         ireq=ireq+1
7266         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7267      &    FG_COMM,req(ireq),IERR)
7268       enddo
7269 c      write (iout,*) "IRECV ended"
7270 c      call flush(iout)
7271 C Send the number of contacts needed by other processors
7272       do ii=1,ntask_cont_to
7273         iproc=itask_cont_to(ii)
7274         ireq=ireq+1
7275         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7276      &    FG_COMM,req(ireq),IERR)
7277       enddo
7278 c      write (iout,*) "ISEND ended"
7279 c      write (iout,*) "number of requests (nn)",ireq
7280       call flush(iout)
7281       if (ireq.gt.0)
7282      &  call MPI_Waitall(ireq,req,status_array,ierr)
7283 c      write (iout,*)
7284 c     &  "Numbers of contacts to be received from other processors",
7285 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7286 c      call flush(iout)
7287 C Receive contacts
7288       ireq=0
7289       do ii=1,ntask_cont_from
7290         iproc=itask_cont_from(ii)
7291         nn=ncont_recv(ii)
7292 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7293 c     &   " of CONT_TO_COMM group"
7294         call flush(iout)
7295         if (nn.gt.0) then
7296           ireq=ireq+1
7297           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7298      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7299 c          write (iout,*) "ireq,req",ireq,req(ireq)
7300         endif
7301       enddo
7302 C Send the contacts to processors that need them
7303       do ii=1,ntask_cont_to
7304         iproc=itask_cont_to(ii)
7305         nn=ncont_sent(ii)
7306 c        write (iout,*) nn," contacts to processor",iproc,
7307 c     &   " of CONT_TO_COMM group"
7308         if (nn.gt.0) then
7309           ireq=ireq+1
7310           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7311      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7312 c          write (iout,*) "ireq,req",ireq,req(ireq)
7313 c          do i=1,nn
7314 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7315 c          enddo
7316         endif
7317       enddo
7318 c      write (iout,*) "number of requests (contacts)",ireq
7319 c      write (iout,*) "req",(req(i),i=1,4)
7320 c      call flush(iout)
7321       if (ireq.gt.0)
7322      & call MPI_Waitall(ireq,req,status_array,ierr)
7323       do iii=1,ntask_cont_from
7324         iproc=itask_cont_from(iii)
7325         nn=ncont_recv(iii)
7326         if (lprn) then
7327         write (iout,*) "Received",nn," contacts from processor",iproc,
7328      &   " of CONT_FROM_COMM group"
7329         call flush(iout)
7330         do i=1,nn
7331           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7332         enddo
7333         call flush(iout)
7334         endif
7335         do i=1,nn
7336           ii=zapas_recv(1,i,iii)
7337 c Flag the received contacts to prevent double-counting
7338           jj=-zapas_recv(2,i,iii)
7339 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7340 c          call flush(iout)
7341           nnn=num_cont_hb(ii)+1
7342           num_cont_hb(ii)=nnn
7343           jcont_hb(nnn,ii)=jj
7344           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7345           ind=3
7346           do kk=1,3
7347             ind=ind+1
7348             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7349           enddo
7350           do kk=1,2
7351             do ll=1,2
7352               ind=ind+1
7353               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7354             enddo
7355           enddo
7356           do jj=1,5
7357             do kk=1,3
7358               do ll=1,2
7359                 do mm=1,2
7360                   ind=ind+1
7361                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7362                 enddo
7363               enddo
7364             enddo
7365           enddo
7366         enddo
7367       enddo
7368       call flush(iout)
7369       if (lprn) then
7370         write (iout,'(a)') 'Contact function values after receive:'
7371         do i=nnt,nct-2
7372           write (iout,'(2i3,50(1x,i3,5f6.3))')
7373      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7374      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7375         enddo
7376         call flush(iout)
7377       endif
7378    30 continue
7379 #endif
7380       if (lprn) then
7381         write (iout,'(a)') 'Contact function values:'
7382         do i=nnt,nct-2
7383           write (iout,'(2i3,50(1x,i2,5f6.3))')
7384      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7385      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7386         enddo
7387       endif
7388       ecorr=0.0D0
7389       ecorr5=0.0d0
7390       ecorr6=0.0d0
7391 C Remove the loop below after debugging !!!
7392       do i=nnt,nct
7393         do j=1,3
7394           gradcorr(j,i)=0.0D0
7395           gradxorr(j,i)=0.0D0
7396         enddo
7397       enddo
7398 C Calculate the dipole-dipole interaction energies
7399       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7400       do i=iatel_s,iatel_e+1
7401         num_conti=num_cont_hb(i)
7402         do jj=1,num_conti
7403           j=jcont_hb(jj,i)
7404 #ifdef MOMENT
7405           call dipole(i,j,jj)
7406 #endif
7407         enddo
7408       enddo
7409       endif
7410 C Calculate the local-electrostatic correlation terms
7411 c                write (iout,*) "gradcorr5 in eello5 before loop"
7412 c                do iii=1,nres
7413 c                  write (iout,'(i5,3f10.5)')
7414 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7415 c                enddo
7416       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7417 c        write (iout,*) "corr loop i",i
7418         i1=i+1
7419         num_conti=num_cont_hb(i)
7420         num_conti1=num_cont_hb(i+1)
7421         do jj=1,num_conti
7422           j=jcont_hb(jj,i)
7423           jp=iabs(j)
7424           do kk=1,num_conti1
7425             j1=jcont_hb(kk,i1)
7426             jp1=iabs(j1)
7427 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7428 c     &         ' jj=',jj,' kk=',kk
7429 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7430             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7431      &          .or. j.lt.0 .and. j1.gt.0) .and.
7432      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7433 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7434 C The system gains extra energy.
7435               n_corr=n_corr+1
7436               sqd1=dsqrt(d_cont(jj,i))
7437               sqd2=dsqrt(d_cont(kk,i1))
7438               sred_geom = sqd1*sqd2
7439               IF (sred_geom.lt.cutoff_corr) THEN
7440                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7441      &            ekont,fprimcont)
7442 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7443 cd     &         ' jj=',jj,' kk=',kk
7444                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7445                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7446                 do l=1,3
7447                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7448                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7449                 enddo
7450                 n_corr1=n_corr1+1
7451 cd               write (iout,*) 'sred_geom=',sred_geom,
7452 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7453 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7454 cd               write (iout,*) "g_contij",g_contij
7455 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7456 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7457                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7458                 if (wcorr4.gt.0.0d0)
7459      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7460                   if (energy_dec.and.wcorr4.gt.0.0d0)
7461      1                 write (iout,'(a6,4i5,0pf7.3)')
7462      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7463 c                write (iout,*) "gradcorr5 before eello5"
7464 c                do iii=1,nres
7465 c                  write (iout,'(i5,3f10.5)')
7466 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7467 c                enddo
7468                 if (wcorr5.gt.0.0d0)
7469      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7470 c                write (iout,*) "gradcorr5 after eello5"
7471 c                do iii=1,nres
7472 c                  write (iout,'(i5,3f10.5)')
7473 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7474 c                enddo
7475                   if (energy_dec.and.wcorr5.gt.0.0d0)
7476      1                 write (iout,'(a6,4i5,0pf7.3)')
7477      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7478 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7479 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7480                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7481      &               .or. wturn6.eq.0.0d0))then
7482 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7483                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7484                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7485      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7486 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7487 cd     &            'ecorr6=',ecorr6
7488 cd                write (iout,'(4e15.5)') sred_geom,
7489 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7490 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7491 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7492                 else if (wturn6.gt.0.0d0
7493      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7494 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7495                   eturn6=eturn6+eello_turn6(i,jj,kk)
7496                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7497      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7498 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7499                 endif
7500               ENDIF
7501 1111          continue
7502             endif
7503           enddo ! kk
7504         enddo ! jj
7505       enddo ! i
7506       do i=1,nres
7507         num_cont_hb(i)=num_cont_hb_old(i)
7508       enddo
7509 c                write (iout,*) "gradcorr5 in eello5"
7510 c                do iii=1,nres
7511 c                  write (iout,'(i5,3f10.5)')
7512 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7513 c                enddo
7514       return
7515       end
7516 c------------------------------------------------------------------------------
7517       subroutine add_hb_contact_eello(ii,jj,itask)
7518       implicit real*8 (a-h,o-z)
7519       include "DIMENSIONS"
7520       include "COMMON.IOUNITS"
7521       integer max_cont
7522       integer max_dim
7523       parameter (max_cont=maxconts)
7524       parameter (max_dim=70)
7525       include "COMMON.CONTACTS"
7526       double precision zapas(max_dim,maxconts,max_fg_procs),
7527      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7528       common /przechowalnia/ zapas
7529       integer i,j,ii,jj,iproc,itask(4),nn
7530 c      write (iout,*) "itask",itask
7531       do i=1,2
7532         iproc=itask(i)
7533         if (iproc.gt.0) then
7534           do j=1,num_cont_hb(ii)
7535             jjc=jcont_hb(j,ii)
7536 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7537             if (jjc.eq.jj) then
7538               ncont_sent(iproc)=ncont_sent(iproc)+1
7539               nn=ncont_sent(iproc)
7540               zapas(1,nn,iproc)=ii
7541               zapas(2,nn,iproc)=jjc
7542               zapas(3,nn,iproc)=d_cont(j,ii)
7543               ind=3
7544               do kk=1,3
7545                 ind=ind+1
7546                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7547               enddo
7548               do kk=1,2
7549                 do ll=1,2
7550                   ind=ind+1
7551                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7552                 enddo
7553               enddo
7554               do jj=1,5
7555                 do kk=1,3
7556                   do ll=1,2
7557                     do mm=1,2
7558                       ind=ind+1
7559                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7560                     enddo
7561                   enddo
7562                 enddo
7563               enddo
7564               exit
7565             endif
7566           enddo
7567         endif
7568       enddo
7569       return
7570       end
7571 c------------------------------------------------------------------------------
7572       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7573       implicit real*8 (a-h,o-z)
7574       include 'DIMENSIONS'
7575       include 'COMMON.IOUNITS'
7576       include 'COMMON.DERIV'
7577       include 'COMMON.INTERACT'
7578       include 'COMMON.CONTACTS'
7579       double precision gx(3),gx1(3)
7580       logical lprn
7581       lprn=.false.
7582       eij=facont_hb(jj,i)
7583       ekl=facont_hb(kk,k)
7584       ees0pij=ees0p(jj,i)
7585       ees0pkl=ees0p(kk,k)
7586       ees0mij=ees0m(jj,i)
7587       ees0mkl=ees0m(kk,k)
7588       ekont=eij*ekl
7589       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7590 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7591 C Following 4 lines for diagnostics.
7592 cd    ees0pkl=0.0D0
7593 cd    ees0pij=1.0D0
7594 cd    ees0mkl=0.0D0
7595 cd    ees0mij=1.0D0
7596 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7597 c     & 'Contacts ',i,j,
7598 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7599 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7600 c     & 'gradcorr_long'
7601 C Calculate the multi-body contribution to energy.
7602 c      ecorr=ecorr+ekont*ees
7603 C Calculate multi-body contributions to the gradient.
7604       coeffpees0pij=coeffp*ees0pij
7605       coeffmees0mij=coeffm*ees0mij
7606       coeffpees0pkl=coeffp*ees0pkl
7607       coeffmees0mkl=coeffm*ees0mkl
7608       do ll=1,3
7609 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7610         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7611      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7612      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7613         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7614      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7615      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7616 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7617         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7618      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7619      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7620         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7621      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7622      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7623         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7624      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7625      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7626         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7627         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7628         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7629      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7630      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7631         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7632         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7633 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7634       enddo
7635 c      write (iout,*)
7636 cgrad      do m=i+1,j-1
7637 cgrad        do ll=1,3
7638 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7639 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7640 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7641 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7642 cgrad        enddo
7643 cgrad      enddo
7644 cgrad      do m=k+1,l-1
7645 cgrad        do ll=1,3
7646 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7647 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7648 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7649 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7650 cgrad        enddo
7651 cgrad      enddo
7652 c      write (iout,*) "ehbcorr",ekont*ees
7653       ehbcorr=ekont*ees
7654       return
7655       end
7656 #ifdef MOMENT
7657 C---------------------------------------------------------------------------
7658       subroutine dipole(i,j,jj)
7659       implicit real*8 (a-h,o-z)
7660       include 'DIMENSIONS'
7661       include 'COMMON.IOUNITS'
7662       include 'COMMON.CHAIN'
7663       include 'COMMON.FFIELD'
7664       include 'COMMON.DERIV'
7665       include 'COMMON.INTERACT'
7666       include 'COMMON.CONTACTS'
7667       include 'COMMON.TORSION'
7668       include 'COMMON.VAR'
7669       include 'COMMON.GEO'
7670       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7671      &  auxmat(2,2)
7672       iti1 = itortyp(itype(i+1))
7673       if (j.lt.nres-1) then
7674         itj1 = itortyp(itype(j+1))
7675       else
7676         itj1=ntortyp
7677       endif
7678       do iii=1,2
7679         dipi(iii,1)=Ub2(iii,i)
7680         dipderi(iii)=Ub2der(iii,i)
7681         dipi(iii,2)=b1(iii,i+1)
7682         dipj(iii,1)=Ub2(iii,j)
7683         dipderj(iii)=Ub2der(iii,j)
7684         dipj(iii,2)=b1(iii,j+1)
7685       enddo
7686       kkk=0
7687       do iii=1,2
7688         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7689         do jjj=1,2
7690           kkk=kkk+1
7691           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7692         enddo
7693       enddo
7694       do kkk=1,5
7695         do lll=1,3
7696           mmm=0
7697           do iii=1,2
7698             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7699      &        auxvec(1))
7700             do jjj=1,2
7701               mmm=mmm+1
7702               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7703             enddo
7704           enddo
7705         enddo
7706       enddo
7707       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7708       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7709       do iii=1,2
7710         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7711       enddo
7712       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7713       do iii=1,2
7714         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7715       enddo
7716       return
7717       end
7718 #endif
7719 C---------------------------------------------------------------------------
7720       subroutine calc_eello(i,j,k,l,jj,kk)
7721 C
7722 C This subroutine computes matrices and vectors needed to calculate
7723 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7724 C
7725       implicit real*8 (a-h,o-z)
7726       include 'DIMENSIONS'
7727       include 'COMMON.IOUNITS'
7728       include 'COMMON.CHAIN'
7729       include 'COMMON.DERIV'
7730       include 'COMMON.INTERACT'
7731       include 'COMMON.CONTACTS'
7732       include 'COMMON.TORSION'
7733       include 'COMMON.VAR'
7734       include 'COMMON.GEO'
7735       include 'COMMON.FFIELD'
7736       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7737      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7738       logical lprn
7739       common /kutas/ lprn
7740 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7741 cd     & ' jj=',jj,' kk=',kk
7742 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7743 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7744 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7745       do iii=1,2
7746         do jjj=1,2
7747           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7748           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7749         enddo
7750       enddo
7751       call transpose2(aa1(1,1),aa1t(1,1))
7752       call transpose2(aa2(1,1),aa2t(1,1))
7753       do kkk=1,5
7754         do lll=1,3
7755           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7756      &      aa1tder(1,1,lll,kkk))
7757           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7758      &      aa2tder(1,1,lll,kkk))
7759         enddo
7760       enddo
7761       if (l.eq.j+1) then
7762 C parallel orientation of the two CA-CA-CA frames.
7763         if (i.gt.1) then
7764           iti=itortyp(itype(i))
7765         else
7766           iti=ntortyp
7767         endif
7768         itk1=itortyp(itype(k+1))
7769         itj=itortyp(itype(j))
7770         if (l.lt.nres-1) then
7771           itl1=itortyp(itype(l+1))
7772         else
7773           itl1=ntortyp
7774         endif
7775 C A1 kernel(j+1) A2T
7776 cd        do iii=1,2
7777 cd          write (iout,'(3f10.5,5x,3f10.5)')
7778 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7779 cd        enddo
7780         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7781      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7782      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7783 C Following matrices are needed only for 6-th order cumulants
7784         IF (wcorr6.gt.0.0d0) THEN
7785         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7786      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7787      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7788         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7789      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7790      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7791      &   ADtEAderx(1,1,1,1,1,1))
7792         lprn=.false.
7793         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7794      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7795      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7796      &   ADtEA1derx(1,1,1,1,1,1))
7797         ENDIF
7798 C End 6-th order cumulants
7799 cd        lprn=.false.
7800 cd        if (lprn) then
7801 cd        write (2,*) 'In calc_eello6'
7802 cd        do iii=1,2
7803 cd          write (2,*) 'iii=',iii
7804 cd          do kkk=1,5
7805 cd            write (2,*) 'kkk=',kkk
7806 cd            do jjj=1,2
7807 cd              write (2,'(3(2f10.5),5x)')
7808 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7809 cd            enddo
7810 cd          enddo
7811 cd        enddo
7812 cd        endif
7813         call transpose2(EUgder(1,1,k),auxmat(1,1))
7814         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7815         call transpose2(EUg(1,1,k),auxmat(1,1))
7816         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7817         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7818         do iii=1,2
7819           do kkk=1,5
7820             do lll=1,3
7821               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7822      &          EAEAderx(1,1,lll,kkk,iii,1))
7823             enddo
7824           enddo
7825         enddo
7826 C A1T kernel(i+1) A2
7827         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7828      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7829      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7830 C Following matrices are needed only for 6-th order cumulants
7831         IF (wcorr6.gt.0.0d0) THEN
7832         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7833      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7834      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7835         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7836      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7837      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7838      &   ADtEAderx(1,1,1,1,1,2))
7839         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7840      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7841      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7842      &   ADtEA1derx(1,1,1,1,1,2))
7843         ENDIF
7844 C End 6-th order cumulants
7845         call transpose2(EUgder(1,1,l),auxmat(1,1))
7846         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7847         call transpose2(EUg(1,1,l),auxmat(1,1))
7848         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7849         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7850         do iii=1,2
7851           do kkk=1,5
7852             do lll=1,3
7853               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7854      &          EAEAderx(1,1,lll,kkk,iii,2))
7855             enddo
7856           enddo
7857         enddo
7858 C AEAb1 and AEAb2
7859 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7860 C They are needed only when the fifth- or the sixth-order cumulants are
7861 C indluded.
7862         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7863         call transpose2(AEA(1,1,1),auxmat(1,1))
7864         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7865         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7866         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7867         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7868         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7869         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7870         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7871         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7872         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7873         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7874         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7875         call transpose2(AEA(1,1,2),auxmat(1,1))
7876         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7877         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7878         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7879         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7880         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7881         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7882         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7883         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7884         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7885         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7886         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7887 C Calculate the Cartesian derivatives of the vectors.
7888         do iii=1,2
7889           do kkk=1,5
7890             do lll=1,3
7891               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7892               call matvec2(auxmat(1,1),b1(1,i),
7893      &          AEAb1derx(1,lll,kkk,iii,1,1))
7894               call matvec2(auxmat(1,1),Ub2(1,i),
7895      &          AEAb2derx(1,lll,kkk,iii,1,1))
7896               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7897      &          AEAb1derx(1,lll,kkk,iii,2,1))
7898               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7899      &          AEAb2derx(1,lll,kkk,iii,2,1))
7900               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7901               call matvec2(auxmat(1,1),b1(1,j),
7902      &          AEAb1derx(1,lll,kkk,iii,1,2))
7903               call matvec2(auxmat(1,1),Ub2(1,j),
7904      &          AEAb2derx(1,lll,kkk,iii,1,2))
7905               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7906      &          AEAb1derx(1,lll,kkk,iii,2,2))
7907               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7908      &          AEAb2derx(1,lll,kkk,iii,2,2))
7909             enddo
7910           enddo
7911         enddo
7912         ENDIF
7913 C End vectors
7914       else
7915 C Antiparallel orientation of the two CA-CA-CA frames.
7916         if (i.gt.1) then
7917           iti=itortyp(itype(i))
7918         else
7919           iti=ntortyp
7920         endif
7921         itk1=itortyp(itype(k+1))
7922         itl=itortyp(itype(l))
7923         itj=itortyp(itype(j))
7924         if (j.lt.nres-1) then
7925           itj1=itortyp(itype(j+1))
7926         else
7927           itj1=ntortyp
7928         endif
7929 C A2 kernel(j-1)T A1T
7930         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7931      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7932      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7933 C Following matrices are needed only for 6-th order cumulants
7934         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7935      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7936         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7937      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7938      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7939         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7940      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7941      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7942      &   ADtEAderx(1,1,1,1,1,1))
7943         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7944      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7945      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7946      &   ADtEA1derx(1,1,1,1,1,1))
7947         ENDIF
7948 C End 6-th order cumulants
7949         call transpose2(EUgder(1,1,k),auxmat(1,1))
7950         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7951         call transpose2(EUg(1,1,k),auxmat(1,1))
7952         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7953         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7954         do iii=1,2
7955           do kkk=1,5
7956             do lll=1,3
7957               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7958      &          EAEAderx(1,1,lll,kkk,iii,1))
7959             enddo
7960           enddo
7961         enddo
7962 C A2T kernel(i+1)T A1
7963         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7964      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7965      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7966 C Following matrices are needed only for 6-th order cumulants
7967         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7968      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7969         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7970      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7971      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7972         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7973      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7974      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7975      &   ADtEAderx(1,1,1,1,1,2))
7976         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7977      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7978      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7979      &   ADtEA1derx(1,1,1,1,1,2))
7980         ENDIF
7981 C End 6-th order cumulants
7982         call transpose2(EUgder(1,1,j),auxmat(1,1))
7983         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7984         call transpose2(EUg(1,1,j),auxmat(1,1))
7985         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7986         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7987         do iii=1,2
7988           do kkk=1,5
7989             do lll=1,3
7990               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7991      &          EAEAderx(1,1,lll,kkk,iii,2))
7992             enddo
7993           enddo
7994         enddo
7995 C AEAb1 and AEAb2
7996 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7997 C They are needed only when the fifth- or the sixth-order cumulants are
7998 C indluded.
7999         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8000      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8001         call transpose2(AEA(1,1,1),auxmat(1,1))
8002         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8003         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8004         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8005         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8006         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8007         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8008         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8009         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8010         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8011         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8012         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8013         call transpose2(AEA(1,1,2),auxmat(1,1))
8014         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8015         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8016         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8017         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8018         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8019         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8020         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8021         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8022         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8023         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8024         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8025 C Calculate the Cartesian derivatives of the vectors.
8026         do iii=1,2
8027           do kkk=1,5
8028             do lll=1,3
8029               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8030               call matvec2(auxmat(1,1),b1(1,i),
8031      &          AEAb1derx(1,lll,kkk,iii,1,1))
8032               call matvec2(auxmat(1,1),Ub2(1,i),
8033      &          AEAb2derx(1,lll,kkk,iii,1,1))
8034               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8035      &          AEAb1derx(1,lll,kkk,iii,2,1))
8036               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8037      &          AEAb2derx(1,lll,kkk,iii,2,1))
8038               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8039               call matvec2(auxmat(1,1),b1(1,l),
8040      &          AEAb1derx(1,lll,kkk,iii,1,2))
8041               call matvec2(auxmat(1,1),Ub2(1,l),
8042      &          AEAb2derx(1,lll,kkk,iii,1,2))
8043               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8044      &          AEAb1derx(1,lll,kkk,iii,2,2))
8045               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8046      &          AEAb2derx(1,lll,kkk,iii,2,2))
8047             enddo
8048           enddo
8049         enddo
8050         ENDIF
8051 C End vectors
8052       endif
8053       return
8054       end
8055 C---------------------------------------------------------------------------
8056       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8057      &  KK,KKderg,AKA,AKAderg,AKAderx)
8058       implicit none
8059       integer nderg
8060       logical transp
8061       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8062      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8063      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8064       integer iii,kkk,lll
8065       integer jjj,mmm
8066       logical lprn
8067       common /kutas/ lprn
8068       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8069       do iii=1,nderg
8070         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8071      &    AKAderg(1,1,iii))
8072       enddo
8073 cd      if (lprn) write (2,*) 'In kernel'
8074       do kkk=1,5
8075 cd        if (lprn) write (2,*) 'kkk=',kkk
8076         do lll=1,3
8077           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8078      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8079 cd          if (lprn) then
8080 cd            write (2,*) 'lll=',lll
8081 cd            write (2,*) 'iii=1'
8082 cd            do jjj=1,2
8083 cd              write (2,'(3(2f10.5),5x)')
8084 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8085 cd            enddo
8086 cd          endif
8087           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8088      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8089 cd          if (lprn) then
8090 cd            write (2,*) 'lll=',lll
8091 cd            write (2,*) 'iii=2'
8092 cd            do jjj=1,2
8093 cd              write (2,'(3(2f10.5),5x)')
8094 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8095 cd            enddo
8096 cd          endif
8097         enddo
8098       enddo
8099       return
8100       end
8101 C---------------------------------------------------------------------------
8102       double precision function eello4(i,j,k,l,jj,kk)
8103       implicit real*8 (a-h,o-z)
8104       include 'DIMENSIONS'
8105       include 'COMMON.IOUNITS'
8106       include 'COMMON.CHAIN'
8107       include 'COMMON.DERIV'
8108       include 'COMMON.INTERACT'
8109       include 'COMMON.CONTACTS'
8110       include 'COMMON.TORSION'
8111       include 'COMMON.VAR'
8112       include 'COMMON.GEO'
8113       double precision pizda(2,2),ggg1(3),ggg2(3)
8114 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8115 cd        eello4=0.0d0
8116 cd        return
8117 cd      endif
8118 cd      print *,'eello4:',i,j,k,l,jj,kk
8119 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8120 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8121 cold      eij=facont_hb(jj,i)
8122 cold      ekl=facont_hb(kk,k)
8123 cold      ekont=eij*ekl
8124       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8125 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8126       gcorr_loc(k-1)=gcorr_loc(k-1)
8127      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8128       if (l.eq.j+1) then
8129         gcorr_loc(l-1)=gcorr_loc(l-1)
8130      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8131       else
8132         gcorr_loc(j-1)=gcorr_loc(j-1)
8133      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8134       endif
8135       do iii=1,2
8136         do kkk=1,5
8137           do lll=1,3
8138             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8139      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8140 cd            derx(lll,kkk,iii)=0.0d0
8141           enddo
8142         enddo
8143       enddo
8144 cd      gcorr_loc(l-1)=0.0d0
8145 cd      gcorr_loc(j-1)=0.0d0
8146 cd      gcorr_loc(k-1)=0.0d0
8147 cd      eel4=1.0d0
8148 cd      write (iout,*)'Contacts have occurred for peptide groups',
8149 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8150 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8151       if (j.lt.nres-1) then
8152         j1=j+1
8153         j2=j-1
8154       else
8155         j1=j-1
8156         j2=j-2
8157       endif
8158       if (l.lt.nres-1) then
8159         l1=l+1
8160         l2=l-1
8161       else
8162         l1=l-1
8163         l2=l-2
8164       endif
8165       do ll=1,3
8166 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8167 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8168         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8169         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8170 cgrad        ghalf=0.5d0*ggg1(ll)
8171         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8172         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8173         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8174         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8175         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8176         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8177 cgrad        ghalf=0.5d0*ggg2(ll)
8178         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8179         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8180         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8181         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8182         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8183         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8184       enddo
8185 cgrad      do m=i+1,j-1
8186 cgrad        do ll=1,3
8187 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8188 cgrad        enddo
8189 cgrad      enddo
8190 cgrad      do m=k+1,l-1
8191 cgrad        do ll=1,3
8192 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8193 cgrad        enddo
8194 cgrad      enddo
8195 cgrad      do m=i+2,j2
8196 cgrad        do ll=1,3
8197 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8198 cgrad        enddo
8199 cgrad      enddo
8200 cgrad      do m=k+2,l2
8201 cgrad        do ll=1,3
8202 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8203 cgrad        enddo
8204 cgrad      enddo
8205 cd      do iii=1,nres-3
8206 cd        write (2,*) iii,gcorr_loc(iii)
8207 cd      enddo
8208       eello4=ekont*eel4
8209 cd      write (2,*) 'ekont',ekont
8210 cd      write (iout,*) 'eello4',ekont*eel4
8211       return
8212       end
8213 C---------------------------------------------------------------------------
8214       double precision function eello5(i,j,k,l,jj,kk)
8215       implicit real*8 (a-h,o-z)
8216       include 'DIMENSIONS'
8217       include 'COMMON.IOUNITS'
8218       include 'COMMON.CHAIN'
8219       include 'COMMON.DERIV'
8220       include 'COMMON.INTERACT'
8221       include 'COMMON.CONTACTS'
8222       include 'COMMON.TORSION'
8223       include 'COMMON.VAR'
8224       include 'COMMON.GEO'
8225       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8226       double precision ggg1(3),ggg2(3)
8227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8228 C                                                                              C
8229 C                            Parallel chains                                   C
8230 C                                                                              C
8231 C          o             o                   o             o                   C
8232 C         /l\           / \             \   / \           / \   /              C
8233 C        /   \         /   \             \ /   \         /   \ /               C
8234 C       j| o |l1       | o |              o| o |         | o |o                C
8235 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8236 C      \i/   \         /   \ /             /   \         /   \                 C
8237 C       o    k1             o                                                  C
8238 C         (I)          (II)                (III)          (IV)                 C
8239 C                                                                              C
8240 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8241 C                                                                              C
8242 C                            Antiparallel chains                               C
8243 C                                                                              C
8244 C          o             o                   o             o                   C
8245 C         /j\           / \             \   / \           / \   /              C
8246 C        /   \         /   \             \ /   \         /   \ /               C
8247 C      j1| o |l        | o |              o| o |         | o |o                C
8248 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8249 C      \i/   \         /   \ /             /   \         /   \                 C
8250 C       o     k1            o                                                  C
8251 C         (I)          (II)                (III)          (IV)                 C
8252 C                                                                              C
8253 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8254 C                                                                              C
8255 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8256 C                                                                              C
8257 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8258 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8259 cd        eello5=0.0d0
8260 cd        return
8261 cd      endif
8262 cd      write (iout,*)
8263 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8264 cd     &   ' and',k,l
8265       itk=itortyp(itype(k))
8266       itl=itortyp(itype(l))
8267       itj=itortyp(itype(j))
8268       eello5_1=0.0d0
8269       eello5_2=0.0d0
8270       eello5_3=0.0d0
8271       eello5_4=0.0d0
8272 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8273 cd     &   eel5_3_num,eel5_4_num)
8274       do iii=1,2
8275         do kkk=1,5
8276           do lll=1,3
8277             derx(lll,kkk,iii)=0.0d0
8278           enddo
8279         enddo
8280       enddo
8281 cd      eij=facont_hb(jj,i)
8282 cd      ekl=facont_hb(kk,k)
8283 cd      ekont=eij*ekl
8284 cd      write (iout,*)'Contacts have occurred for peptide groups',
8285 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8286 cd      goto 1111
8287 C Contribution from the graph I.
8288 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8289 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8290       call transpose2(EUg(1,1,k),auxmat(1,1))
8291       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8292       vv(1)=pizda(1,1)-pizda(2,2)
8293       vv(2)=pizda(1,2)+pizda(2,1)
8294       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8295      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8296 C Explicit gradient in virtual-dihedral angles.
8297       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8298      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8299      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8300       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8301       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8302       vv(1)=pizda(1,1)-pizda(2,2)
8303       vv(2)=pizda(1,2)+pizda(2,1)
8304       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8305      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8306      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8307       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8308       vv(1)=pizda(1,1)-pizda(2,2)
8309       vv(2)=pizda(1,2)+pizda(2,1)
8310       if (l.eq.j+1) then
8311         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8312      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8313      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8314       else
8315         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8316      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8317      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8318       endif
8319 C Cartesian gradient
8320       do iii=1,2
8321         do kkk=1,5
8322           do lll=1,3
8323             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8324      &        pizda(1,1))
8325             vv(1)=pizda(1,1)-pizda(2,2)
8326             vv(2)=pizda(1,2)+pizda(2,1)
8327             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8328      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8329      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8330           enddo
8331         enddo
8332       enddo
8333 c      goto 1112
8334 c1111  continue
8335 C Contribution from graph II
8336       call transpose2(EE(1,1,itk),auxmat(1,1))
8337       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8338       vv(1)=pizda(1,1)+pizda(2,2)
8339       vv(2)=pizda(2,1)-pizda(1,2)
8340       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8341      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8342 C Explicit gradient in virtual-dihedral angles.
8343       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8344      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8345       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8346       vv(1)=pizda(1,1)+pizda(2,2)
8347       vv(2)=pizda(2,1)-pizda(1,2)
8348       if (l.eq.j+1) then
8349         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8350      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8351      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8352       else
8353         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8354      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8355      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8356       endif
8357 C Cartesian gradient
8358       do iii=1,2
8359         do kkk=1,5
8360           do lll=1,3
8361             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8362      &        pizda(1,1))
8363             vv(1)=pizda(1,1)+pizda(2,2)
8364             vv(2)=pizda(2,1)-pizda(1,2)
8365             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8366      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8367      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8368           enddo
8369         enddo
8370       enddo
8371 cd      goto 1112
8372 cd1111  continue
8373       if (l.eq.j+1) then
8374 cd        goto 1110
8375 C Parallel orientation
8376 C Contribution from graph III
8377         call transpose2(EUg(1,1,l),auxmat(1,1))
8378         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8379         vv(1)=pizda(1,1)-pizda(2,2)
8380         vv(2)=pizda(1,2)+pizda(2,1)
8381         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8382      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8383 C Explicit gradient in virtual-dihedral angles.
8384         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8385      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8386      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8387         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8388         vv(1)=pizda(1,1)-pizda(2,2)
8389         vv(2)=pizda(1,2)+pizda(2,1)
8390         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8391      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8392      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8393         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8394         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8395         vv(1)=pizda(1,1)-pizda(2,2)
8396         vv(2)=pizda(1,2)+pizda(2,1)
8397         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8398      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8399      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8400 C Cartesian gradient
8401         do iii=1,2
8402           do kkk=1,5
8403             do lll=1,3
8404               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8405      &          pizda(1,1))
8406               vv(1)=pizda(1,1)-pizda(2,2)
8407               vv(2)=pizda(1,2)+pizda(2,1)
8408               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8409      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8410      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8411             enddo
8412           enddo
8413         enddo
8414 cd        goto 1112
8415 C Contribution from graph IV
8416 cd1110    continue
8417         call transpose2(EE(1,1,itl),auxmat(1,1))
8418         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8419         vv(1)=pizda(1,1)+pizda(2,2)
8420         vv(2)=pizda(2,1)-pizda(1,2)
8421         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8422      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8423 C Explicit gradient in virtual-dihedral angles.
8424         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8425      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8426         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8427         vv(1)=pizda(1,1)+pizda(2,2)
8428         vv(2)=pizda(2,1)-pizda(1,2)
8429         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8430      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8431      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8432 C Cartesian gradient
8433         do iii=1,2
8434           do kkk=1,5
8435             do lll=1,3
8436               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8437      &          pizda(1,1))
8438               vv(1)=pizda(1,1)+pizda(2,2)
8439               vv(2)=pizda(2,1)-pizda(1,2)
8440               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8441      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8442      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8443             enddo
8444           enddo
8445         enddo
8446       else
8447 C Antiparallel orientation
8448 C Contribution from graph III
8449 c        goto 1110
8450         call transpose2(EUg(1,1,j),auxmat(1,1))
8451         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8452         vv(1)=pizda(1,1)-pizda(2,2)
8453         vv(2)=pizda(1,2)+pizda(2,1)
8454         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8455      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8456 C Explicit gradient in virtual-dihedral angles.
8457         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8458      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8459      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8460         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8461         vv(1)=pizda(1,1)-pizda(2,2)
8462         vv(2)=pizda(1,2)+pizda(2,1)
8463         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8464      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8465      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8466         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8467         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8468         vv(1)=pizda(1,1)-pizda(2,2)
8469         vv(2)=pizda(1,2)+pizda(2,1)
8470         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8471      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8472      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8473 C Cartesian gradient
8474         do iii=1,2
8475           do kkk=1,5
8476             do lll=1,3
8477               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8478      &          pizda(1,1))
8479               vv(1)=pizda(1,1)-pizda(2,2)
8480               vv(2)=pizda(1,2)+pizda(2,1)
8481               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8482      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8483      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8484             enddo
8485           enddo
8486         enddo
8487 cd        goto 1112
8488 C Contribution from graph IV
8489 1110    continue
8490         call transpose2(EE(1,1,itj),auxmat(1,1))
8491         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8492         vv(1)=pizda(1,1)+pizda(2,2)
8493         vv(2)=pizda(2,1)-pizda(1,2)
8494         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8495      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8496 C Explicit gradient in virtual-dihedral angles.
8497         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8498      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8499         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8500         vv(1)=pizda(1,1)+pizda(2,2)
8501         vv(2)=pizda(2,1)-pizda(1,2)
8502         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8503      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8504      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8505 C Cartesian gradient
8506         do iii=1,2
8507           do kkk=1,5
8508             do lll=1,3
8509               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8510      &          pizda(1,1))
8511               vv(1)=pizda(1,1)+pizda(2,2)
8512               vv(2)=pizda(2,1)-pizda(1,2)
8513               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8514      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8515      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8516             enddo
8517           enddo
8518         enddo
8519       endif
8520 1112  continue
8521       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8522 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8523 cd        write (2,*) 'ijkl',i,j,k,l
8524 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8525 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8526 cd      endif
8527 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8528 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8529 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8530 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8531       if (j.lt.nres-1) then
8532         j1=j+1
8533         j2=j-1
8534       else
8535         j1=j-1
8536         j2=j-2
8537       endif
8538       if (l.lt.nres-1) then
8539         l1=l+1
8540         l2=l-1
8541       else
8542         l1=l-1
8543         l2=l-2
8544       endif
8545 cd      eij=1.0d0
8546 cd      ekl=1.0d0
8547 cd      ekont=1.0d0
8548 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8549 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8550 C        summed up outside the subrouine as for the other subroutines
8551 C        handling long-range interactions. The old code is commented out
8552 C        with "cgrad" to keep track of changes.
8553       do ll=1,3
8554 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8555 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8556         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8557         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8558 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8559 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8560 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8561 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8562 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8563 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8564 c     &   gradcorr5ij,
8565 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8566 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8567 cgrad        ghalf=0.5d0*ggg1(ll)
8568 cd        ghalf=0.0d0
8569         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8570         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8571         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8572         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8573         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8574         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8575 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8576 cgrad        ghalf=0.5d0*ggg2(ll)
8577 cd        ghalf=0.0d0
8578         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8579         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8580         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8581         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8582         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8583         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8584       enddo
8585 cd      goto 1112
8586 cgrad      do m=i+1,j-1
8587 cgrad        do ll=1,3
8588 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8589 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8590 cgrad        enddo
8591 cgrad      enddo
8592 cgrad      do m=k+1,l-1
8593 cgrad        do ll=1,3
8594 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8595 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8596 cgrad        enddo
8597 cgrad      enddo
8598 c1112  continue
8599 cgrad      do m=i+2,j2
8600 cgrad        do ll=1,3
8601 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8602 cgrad        enddo
8603 cgrad      enddo
8604 cgrad      do m=k+2,l2
8605 cgrad        do ll=1,3
8606 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8607 cgrad        enddo
8608 cgrad      enddo
8609 cd      do iii=1,nres-3
8610 cd        write (2,*) iii,g_corr5_loc(iii)
8611 cd      enddo
8612       eello5=ekont*eel5
8613 cd      write (2,*) 'ekont',ekont
8614 cd      write (iout,*) 'eello5',ekont*eel5
8615       return
8616       end
8617 c--------------------------------------------------------------------------
8618       double precision function eello6(i,j,k,l,jj,kk)
8619       implicit real*8 (a-h,o-z)
8620       include 'DIMENSIONS'
8621       include 'COMMON.IOUNITS'
8622       include 'COMMON.CHAIN'
8623       include 'COMMON.DERIV'
8624       include 'COMMON.INTERACT'
8625       include 'COMMON.CONTACTS'
8626       include 'COMMON.TORSION'
8627       include 'COMMON.VAR'
8628       include 'COMMON.GEO'
8629       include 'COMMON.FFIELD'
8630       double precision ggg1(3),ggg2(3)
8631 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8632 cd        eello6=0.0d0
8633 cd        return
8634 cd      endif
8635 cd      write (iout,*)
8636 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8637 cd     &   ' and',k,l
8638       eello6_1=0.0d0
8639       eello6_2=0.0d0
8640       eello6_3=0.0d0
8641       eello6_4=0.0d0
8642       eello6_5=0.0d0
8643       eello6_6=0.0d0
8644 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8645 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8646       do iii=1,2
8647         do kkk=1,5
8648           do lll=1,3
8649             derx(lll,kkk,iii)=0.0d0
8650           enddo
8651         enddo
8652       enddo
8653 cd      eij=facont_hb(jj,i)
8654 cd      ekl=facont_hb(kk,k)
8655 cd      ekont=eij*ekl
8656 cd      eij=1.0d0
8657 cd      ekl=1.0d0
8658 cd      ekont=1.0d0
8659       if (l.eq.j+1) then
8660         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8661         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8662         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8663         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8664         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8665         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8666       else
8667         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8668         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8669         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8670         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8671         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8672           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8673         else
8674           eello6_5=0.0d0
8675         endif
8676         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8677       endif
8678 C If turn contributions are considered, they will be handled separately.
8679       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8680 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8681 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8682 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8683 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8684 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8685 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8686 cd      goto 1112
8687       if (j.lt.nres-1) then
8688         j1=j+1
8689         j2=j-1
8690       else
8691         j1=j-1
8692         j2=j-2
8693       endif
8694       if (l.lt.nres-1) then
8695         l1=l+1
8696         l2=l-1
8697       else
8698         l1=l-1
8699         l2=l-2
8700       endif
8701       do ll=1,3
8702 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8703 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8704 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8705 cgrad        ghalf=0.5d0*ggg1(ll)
8706 cd        ghalf=0.0d0
8707         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8708         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8709         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8710         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8711         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8712         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8713         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8714         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8715 cgrad        ghalf=0.5d0*ggg2(ll)
8716 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8717 cd        ghalf=0.0d0
8718         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8719         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8720         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8721         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8722         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8723         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8724       enddo
8725 cd      goto 1112
8726 cgrad      do m=i+1,j-1
8727 cgrad        do ll=1,3
8728 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8729 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8730 cgrad        enddo
8731 cgrad      enddo
8732 cgrad      do m=k+1,l-1
8733 cgrad        do ll=1,3
8734 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8735 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8736 cgrad        enddo
8737 cgrad      enddo
8738 cgrad1112  continue
8739 cgrad      do m=i+2,j2
8740 cgrad        do ll=1,3
8741 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8742 cgrad        enddo
8743 cgrad      enddo
8744 cgrad      do m=k+2,l2
8745 cgrad        do ll=1,3
8746 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8747 cgrad        enddo
8748 cgrad      enddo
8749 cd      do iii=1,nres-3
8750 cd        write (2,*) iii,g_corr6_loc(iii)
8751 cd      enddo
8752       eello6=ekont*eel6
8753 cd      write (2,*) 'ekont',ekont
8754 cd      write (iout,*) 'eello6',ekont*eel6
8755       return
8756       end
8757 c--------------------------------------------------------------------------
8758       double precision function eello6_graph1(i,j,k,l,imat,swap)
8759       implicit real*8 (a-h,o-z)
8760       include 'DIMENSIONS'
8761       include 'COMMON.IOUNITS'
8762       include 'COMMON.CHAIN'
8763       include 'COMMON.DERIV'
8764       include 'COMMON.INTERACT'
8765       include 'COMMON.CONTACTS'
8766       include 'COMMON.TORSION'
8767       include 'COMMON.VAR'
8768       include 'COMMON.GEO'
8769       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8770       logical swap
8771       logical lprn
8772       common /kutas/ lprn
8773 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8774 C                                                                              C
8775 C      Parallel       Antiparallel                                             C
8776 C                                                                              C
8777 C          o             o                                                     C
8778 C         /l\           /j\                                                    C
8779 C        /   \         /   \                                                   C
8780 C       /| o |         | o |\                                                  C
8781 C     \ j|/k\|  /   \  |/k\|l /                                                C
8782 C      \ /   \ /     \ /   \ /                                                 C
8783 C       o     o       o     o                                                  C
8784 C       i             i                                                        C
8785 C                                                                              C
8786 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8787       itk=itortyp(itype(k))
8788       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8789       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8790       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8791       call transpose2(EUgC(1,1,k),auxmat(1,1))
8792       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8793       vv1(1)=pizda1(1,1)-pizda1(2,2)
8794       vv1(2)=pizda1(1,2)+pizda1(2,1)
8795       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8796       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8797       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8798       s5=scalar2(vv(1),Dtobr2(1,i))
8799 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8800       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8801       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8802      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8803      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8804      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8805      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8806      & +scalar2(vv(1),Dtobr2der(1,i)))
8807       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8808       vv1(1)=pizda1(1,1)-pizda1(2,2)
8809       vv1(2)=pizda1(1,2)+pizda1(2,1)
8810       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8811       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8812       if (l.eq.j+1) then
8813         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8814      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8815      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8816      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8817      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8818       else
8819         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8820      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8821      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8822      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8823      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8824       endif
8825       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8826       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8827       vv1(1)=pizda1(1,1)-pizda1(2,2)
8828       vv1(2)=pizda1(1,2)+pizda1(2,1)
8829       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8830      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8831      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8832      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8833       do iii=1,2
8834         if (swap) then
8835           ind=3-iii
8836         else
8837           ind=iii
8838         endif
8839         do kkk=1,5
8840           do lll=1,3
8841             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8842             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8843             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8844             call transpose2(EUgC(1,1,k),auxmat(1,1))
8845             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8846      &        pizda1(1,1))
8847             vv1(1)=pizda1(1,1)-pizda1(2,2)
8848             vv1(2)=pizda1(1,2)+pizda1(2,1)
8849             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8850             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8851      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8852             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8853      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8854             s5=scalar2(vv(1),Dtobr2(1,i))
8855             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8856           enddo
8857         enddo
8858       enddo
8859       return
8860       end
8861 c----------------------------------------------------------------------------
8862       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8863       implicit real*8 (a-h,o-z)
8864       include 'DIMENSIONS'
8865       include 'COMMON.IOUNITS'
8866       include 'COMMON.CHAIN'
8867       include 'COMMON.DERIV'
8868       include 'COMMON.INTERACT'
8869       include 'COMMON.CONTACTS'
8870       include 'COMMON.TORSION'
8871       include 'COMMON.VAR'
8872       include 'COMMON.GEO'
8873       logical swap
8874       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8875      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8876       logical lprn
8877       common /kutas/ lprn
8878 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8879 C                                                                              C
8880 C      Parallel       Antiparallel                                             C
8881 C                                                                              C
8882 C          o             o                                                     C
8883 C     \   /l\           /j\   /                                                C
8884 C      \ /   \         /   \ /                                                 C
8885 C       o| o |         | o |o                                                  C
8886 C     \ j|/k\|      \  |/k\|l                                                  C
8887 C      \ /   \       \ /   \                                                   C
8888 C       o             o                                                        C
8889 C       i             i                                                        C
8890 C                                                                              C
8891 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8892 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8893 C AL 7/4/01 s1 would occur in the sixth-order moment,
8894 C           but not in a cluster cumulant
8895 #ifdef MOMENT
8896       s1=dip(1,jj,i)*dip(1,kk,k)
8897 #endif
8898       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8899       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8900       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8901       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8902       call transpose2(EUg(1,1,k),auxmat(1,1))
8903       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8904       vv(1)=pizda(1,1)-pizda(2,2)
8905       vv(2)=pizda(1,2)+pizda(2,1)
8906       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8907 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8908 #ifdef MOMENT
8909       eello6_graph2=-(s1+s2+s3+s4)
8910 #else
8911       eello6_graph2=-(s2+s3+s4)
8912 #endif
8913 c      eello6_graph2=-s3
8914 C Derivatives in gamma(i-1)
8915       if (i.gt.1) then
8916 #ifdef MOMENT
8917         s1=dipderg(1,jj,i)*dip(1,kk,k)
8918 #endif
8919         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8920         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8921         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8922         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8923 #ifdef MOMENT
8924         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8925 #else
8926         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8927 #endif
8928 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8929       endif
8930 C Derivatives in gamma(k-1)
8931 #ifdef MOMENT
8932       s1=dip(1,jj,i)*dipderg(1,kk,k)
8933 #endif
8934       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8935       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8936       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8937       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8938       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8939       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8940       vv(1)=pizda(1,1)-pizda(2,2)
8941       vv(2)=pizda(1,2)+pizda(2,1)
8942       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8943 #ifdef MOMENT
8944       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8945 #else
8946       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8947 #endif
8948 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8949 C Derivatives in gamma(j-1) or gamma(l-1)
8950       if (j.gt.1) then
8951 #ifdef MOMENT
8952         s1=dipderg(3,jj,i)*dip(1,kk,k)
8953 #endif
8954         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8955         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8956         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8957         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8958         vv(1)=pizda(1,1)-pizda(2,2)
8959         vv(2)=pizda(1,2)+pizda(2,1)
8960         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8961 #ifdef MOMENT
8962         if (swap) then
8963           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8964         else
8965           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8966         endif
8967 #endif
8968         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8969 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8970       endif
8971 C Derivatives in gamma(l-1) or gamma(j-1)
8972       if (l.gt.1) then
8973 #ifdef MOMENT
8974         s1=dip(1,jj,i)*dipderg(3,kk,k)
8975 #endif
8976         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8977         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8978         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8979         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8980         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8981         vv(1)=pizda(1,1)-pizda(2,2)
8982         vv(2)=pizda(1,2)+pizda(2,1)
8983         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8984 #ifdef MOMENT
8985         if (swap) then
8986           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8987         else
8988           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8989         endif
8990 #endif
8991         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8992 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8993       endif
8994 C Cartesian derivatives.
8995       if (lprn) then
8996         write (2,*) 'In eello6_graph2'
8997         do iii=1,2
8998           write (2,*) 'iii=',iii
8999           do kkk=1,5
9000             write (2,*) 'kkk=',kkk
9001             do jjj=1,2
9002               write (2,'(3(2f10.5),5x)')
9003      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9004             enddo
9005           enddo
9006         enddo
9007       endif
9008       do iii=1,2
9009         do kkk=1,5
9010           do lll=1,3
9011 #ifdef MOMENT
9012             if (iii.eq.1) then
9013               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9014             else
9015               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9016             endif
9017 #endif
9018             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9019      &        auxvec(1))
9020             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9021             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9022      &        auxvec(1))
9023             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9024             call transpose2(EUg(1,1,k),auxmat(1,1))
9025             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9026      &        pizda(1,1))
9027             vv(1)=pizda(1,1)-pizda(2,2)
9028             vv(2)=pizda(1,2)+pizda(2,1)
9029             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9030 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9031 #ifdef MOMENT
9032             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9033 #else
9034             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9035 #endif
9036             if (swap) then
9037               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9038             else
9039               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9040             endif
9041           enddo
9042         enddo
9043       enddo
9044       return
9045       end
9046 c----------------------------------------------------------------------------
9047       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9048       implicit real*8 (a-h,o-z)
9049       include 'DIMENSIONS'
9050       include 'COMMON.IOUNITS'
9051       include 'COMMON.CHAIN'
9052       include 'COMMON.DERIV'
9053       include 'COMMON.INTERACT'
9054       include 'COMMON.CONTACTS'
9055       include 'COMMON.TORSION'
9056       include 'COMMON.VAR'
9057       include 'COMMON.GEO'
9058       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9059       logical swap
9060 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9061 C                                                                              C
9062 C      Parallel       Antiparallel                                             C
9063 C                                                                              C
9064 C          o             o                                                     C
9065 C         /l\   /   \   /j\                                                    C
9066 C        /   \ /     \ /   \                                                   C
9067 C       /| o |o       o| o |\                                                  C
9068 C       j|/k\|  /      |/k\|l /                                                C
9069 C        /   \ /       /   \ /                                                 C
9070 C       /     o       /     o                                                  C
9071 C       i             i                                                        C
9072 C                                                                              C
9073 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9074 C
9075 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9076 C           energy moment and not to the cluster cumulant.
9077       iti=itortyp(itype(i))
9078       if (j.lt.nres-1) then
9079         itj1=itortyp(itype(j+1))
9080       else
9081         itj1=ntortyp
9082       endif
9083       itk=itortyp(itype(k))
9084       itk1=itortyp(itype(k+1))
9085       if (l.lt.nres-1) then
9086         itl1=itortyp(itype(l+1))
9087       else
9088         itl1=ntortyp
9089       endif
9090 #ifdef MOMENT
9091       s1=dip(4,jj,i)*dip(4,kk,k)
9092 #endif
9093       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9094       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9095       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9096       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9097       call transpose2(EE(1,1,itk),auxmat(1,1))
9098       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9099       vv(1)=pizda(1,1)+pizda(2,2)
9100       vv(2)=pizda(2,1)-pizda(1,2)
9101       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9102 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9103 cd     & "sum",-(s2+s3+s4)
9104 #ifdef MOMENT
9105       eello6_graph3=-(s1+s2+s3+s4)
9106 #else
9107       eello6_graph3=-(s2+s3+s4)
9108 #endif
9109 c      eello6_graph3=-s4
9110 C Derivatives in gamma(k-1)
9111       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9112       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9113       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9114       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9115 C Derivatives in gamma(l-1)
9116       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9117       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9118       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9119       vv(1)=pizda(1,1)+pizda(2,2)
9120       vv(2)=pizda(2,1)-pizda(1,2)
9121       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9122       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9123 C Cartesian derivatives.
9124       do iii=1,2
9125         do kkk=1,5
9126           do lll=1,3
9127 #ifdef MOMENT
9128             if (iii.eq.1) then
9129               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9130             else
9131               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9132             endif
9133 #endif
9134             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9135      &        auxvec(1))
9136             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9137             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9138      &        auxvec(1))
9139             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9140             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9141      &        pizda(1,1))
9142             vv(1)=pizda(1,1)+pizda(2,2)
9143             vv(2)=pizda(2,1)-pizda(1,2)
9144             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9145 #ifdef MOMENT
9146             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9147 #else
9148             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9149 #endif
9150             if (swap) then
9151               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9152             else
9153               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9154             endif
9155 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9156           enddo
9157         enddo
9158       enddo
9159       return
9160       end
9161 c----------------------------------------------------------------------------
9162       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9163       implicit real*8 (a-h,o-z)
9164       include 'DIMENSIONS'
9165       include 'COMMON.IOUNITS'
9166       include 'COMMON.CHAIN'
9167       include 'COMMON.DERIV'
9168       include 'COMMON.INTERACT'
9169       include 'COMMON.CONTACTS'
9170       include 'COMMON.TORSION'
9171       include 'COMMON.VAR'
9172       include 'COMMON.GEO'
9173       include 'COMMON.FFIELD'
9174       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9175      & auxvec1(2),auxmat1(2,2)
9176       logical swap
9177 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9178 C                                                                              C
9179 C      Parallel       Antiparallel                                             C
9180 C                                                                              C
9181 C          o             o                                                     C
9182 C         /l\   /   \   /j\                                                    C
9183 C        /   \ /     \ /   \                                                   C
9184 C       /| o |o       o| o |\                                                  C
9185 C     \ j|/k\|      \  |/k\|l                                                  C
9186 C      \ /   \       \ /   \                                                   C
9187 C       o     \       o     \                                                  C
9188 C       i             i                                                        C
9189 C                                                                              C
9190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9191 C
9192 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9193 C           energy moment and not to the cluster cumulant.
9194 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9195       iti=itortyp(itype(i))
9196       itj=itortyp(itype(j))
9197       if (j.lt.nres-1) then
9198         itj1=itortyp(itype(j+1))
9199       else
9200         itj1=ntortyp
9201       endif
9202       itk=itortyp(itype(k))
9203       if (k.lt.nres-1) then
9204         itk1=itortyp(itype(k+1))
9205       else
9206         itk1=ntortyp
9207       endif
9208       itl=itortyp(itype(l))
9209       if (l.lt.nres-1) then
9210         itl1=itortyp(itype(l+1))
9211       else
9212         itl1=ntortyp
9213       endif
9214 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9215 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9216 cd     & ' itl',itl,' itl1',itl1
9217 #ifdef MOMENT
9218       if (imat.eq.1) then
9219         s1=dip(3,jj,i)*dip(3,kk,k)
9220       else
9221         s1=dip(2,jj,j)*dip(2,kk,l)
9222       endif
9223 #endif
9224       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9225       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9226       if (j.eq.l+1) then
9227         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9228         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9229       else
9230         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9231         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9232       endif
9233       call transpose2(EUg(1,1,k),auxmat(1,1))
9234       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9235       vv(1)=pizda(1,1)-pizda(2,2)
9236       vv(2)=pizda(2,1)+pizda(1,2)
9237       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9238 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9239 #ifdef MOMENT
9240       eello6_graph4=-(s1+s2+s3+s4)
9241 #else
9242       eello6_graph4=-(s2+s3+s4)
9243 #endif
9244 C Derivatives in gamma(i-1)
9245       if (i.gt.1) then
9246 #ifdef MOMENT
9247         if (imat.eq.1) then
9248           s1=dipderg(2,jj,i)*dip(3,kk,k)
9249         else
9250           s1=dipderg(4,jj,j)*dip(2,kk,l)
9251         endif
9252 #endif
9253         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9254         if (j.eq.l+1) then
9255           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9256           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9257         else
9258           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9259           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9260         endif
9261         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9262         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9263 cd          write (2,*) 'turn6 derivatives'
9264 #ifdef MOMENT
9265           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9266 #else
9267           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9268 #endif
9269         else
9270 #ifdef MOMENT
9271           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9272 #else
9273           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9274 #endif
9275         endif
9276       endif
9277 C Derivatives in gamma(k-1)
9278 #ifdef MOMENT
9279       if (imat.eq.1) then
9280         s1=dip(3,jj,i)*dipderg(2,kk,k)
9281       else
9282         s1=dip(2,jj,j)*dipderg(4,kk,l)
9283       endif
9284 #endif
9285       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9286       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9287       if (j.eq.l+1) then
9288         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9289         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9290       else
9291         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9292         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9293       endif
9294       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9295       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9296       vv(1)=pizda(1,1)-pizda(2,2)
9297       vv(2)=pizda(2,1)+pizda(1,2)
9298       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9299       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9300 #ifdef MOMENT
9301         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9302 #else
9303         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9304 #endif
9305       else
9306 #ifdef MOMENT
9307         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9308 #else
9309         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9310 #endif
9311       endif
9312 C Derivatives in gamma(j-1) or gamma(l-1)
9313       if (l.eq.j+1 .and. l.gt.1) then
9314         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9315         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9316         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9317         vv(1)=pizda(1,1)-pizda(2,2)
9318         vv(2)=pizda(2,1)+pizda(1,2)
9319         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9320         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9321       else if (j.gt.1) then
9322         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9323         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9324         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9325         vv(1)=pizda(1,1)-pizda(2,2)
9326         vv(2)=pizda(2,1)+pizda(1,2)
9327         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9328         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9329           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9330         else
9331           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9332         endif
9333       endif
9334 C Cartesian derivatives.
9335       do iii=1,2
9336         do kkk=1,5
9337           do lll=1,3
9338 #ifdef MOMENT
9339             if (iii.eq.1) then
9340               if (imat.eq.1) then
9341                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9342               else
9343                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9344               endif
9345             else
9346               if (imat.eq.1) then
9347                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9348               else
9349                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9350               endif
9351             endif
9352 #endif
9353             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9354      &        auxvec(1))
9355             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9356             if (j.eq.l+1) then
9357               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9358      &          b1(1,j+1),auxvec(1))
9359               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9360             else
9361               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9362      &          b1(1,l+1),auxvec(1))
9363               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9364             endif
9365             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9366      &        pizda(1,1))
9367             vv(1)=pizda(1,1)-pizda(2,2)
9368             vv(2)=pizda(2,1)+pizda(1,2)
9369             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9370             if (swap) then
9371               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9372 #ifdef MOMENT
9373                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9374      &             -(s1+s2+s4)
9375 #else
9376                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9377      &             -(s2+s4)
9378 #endif
9379                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9380               else
9381 #ifdef MOMENT
9382                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9383 #else
9384                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9385 #endif
9386                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9387               endif
9388             else
9389 #ifdef MOMENT
9390               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9391 #else
9392               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9393 #endif
9394               if (l.eq.j+1) then
9395                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9396               else
9397                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9398               endif
9399             endif
9400           enddo
9401         enddo
9402       enddo
9403       return
9404       end
9405 c----------------------------------------------------------------------------
9406       double precision function eello_turn6(i,jj,kk)
9407       implicit real*8 (a-h,o-z)
9408       include 'DIMENSIONS'
9409       include 'COMMON.IOUNITS'
9410       include 'COMMON.CHAIN'
9411       include 'COMMON.DERIV'
9412       include 'COMMON.INTERACT'
9413       include 'COMMON.CONTACTS'
9414       include 'COMMON.TORSION'
9415       include 'COMMON.VAR'
9416       include 'COMMON.GEO'
9417       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9418      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9419      &  ggg1(3),ggg2(3)
9420       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9421      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9422 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9423 C           the respective energy moment and not to the cluster cumulant.
9424       s1=0.0d0
9425       s8=0.0d0
9426       s13=0.0d0
9427 c
9428       eello_turn6=0.0d0
9429       j=i+4
9430       k=i+1
9431       l=i+3
9432       iti=itortyp(itype(i))
9433       itk=itortyp(itype(k))
9434       itk1=itortyp(itype(k+1))
9435       itl=itortyp(itype(l))
9436       itj=itortyp(itype(j))
9437 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9438 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9439 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9440 cd        eello6=0.0d0
9441 cd        return
9442 cd      endif
9443 cd      write (iout,*)
9444 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9445 cd     &   ' and',k,l
9446 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9447       do iii=1,2
9448         do kkk=1,5
9449           do lll=1,3
9450             derx_turn(lll,kkk,iii)=0.0d0
9451           enddo
9452         enddo
9453       enddo
9454 cd      eij=1.0d0
9455 cd      ekl=1.0d0
9456 cd      ekont=1.0d0
9457       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9458 cd      eello6_5=0.0d0
9459 cd      write (2,*) 'eello6_5',eello6_5
9460 #ifdef MOMENT
9461       call transpose2(AEA(1,1,1),auxmat(1,1))
9462       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9463       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9464       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9465 #endif
9466       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9467       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9468       s2 = scalar2(b1(1,k),vtemp1(1))
9469 #ifdef MOMENT
9470       call transpose2(AEA(1,1,2),atemp(1,1))
9471       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9472       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9473       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9474 #endif
9475       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9476       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9477       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9478 #ifdef MOMENT
9479       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9480       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9481       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9482       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9483       ss13 = scalar2(b1(1,k),vtemp4(1))
9484       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9485 #endif
9486 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9487 c      s1=0.0d0
9488 c      s2=0.0d0
9489 c      s8=0.0d0
9490 c      s12=0.0d0
9491 c      s13=0.0d0
9492       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9493 C Derivatives in gamma(i+2)
9494       s1d =0.0d0
9495       s8d =0.0d0
9496 #ifdef MOMENT
9497       call transpose2(AEA(1,1,1),auxmatd(1,1))
9498       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9499       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9500       call transpose2(AEAderg(1,1,2),atempd(1,1))
9501       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9502       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9503 #endif
9504       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9505       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9506       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9507 c      s1d=0.0d0
9508 c      s2d=0.0d0
9509 c      s8d=0.0d0
9510 c      s12d=0.0d0
9511 c      s13d=0.0d0
9512       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9513 C Derivatives in gamma(i+3)
9514 #ifdef MOMENT
9515       call transpose2(AEA(1,1,1),auxmatd(1,1))
9516       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9517       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9518       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9519 #endif
9520       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9521       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9522       s2d = scalar2(b1(1,k),vtemp1d(1))
9523 #ifdef MOMENT
9524       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9525       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9526 #endif
9527       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9528 #ifdef MOMENT
9529       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9530       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9531       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9532 #endif
9533 c      s1d=0.0d0
9534 c      s2d=0.0d0
9535 c      s8d=0.0d0
9536 c      s12d=0.0d0
9537 c      s13d=0.0d0
9538 #ifdef MOMENT
9539       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9540      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9541 #else
9542       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9543      &               -0.5d0*ekont*(s2d+s12d)
9544 #endif
9545 C Derivatives in gamma(i+4)
9546       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9547       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9548       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9549 #ifdef MOMENT
9550       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9551       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9552       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9553 #endif
9554 c      s1d=0.0d0
9555 c      s2d=0.0d0
9556 c      s8d=0.0d0
9557 C      s12d=0.0d0
9558 c      s13d=0.0d0
9559 #ifdef MOMENT
9560       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9561 #else
9562       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9563 #endif
9564 C Derivatives in gamma(i+5)
9565 #ifdef MOMENT
9566       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9567       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9568       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9569 #endif
9570       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9571       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9572       s2d = scalar2(b1(1,k),vtemp1d(1))
9573 #ifdef MOMENT
9574       call transpose2(AEA(1,1,2),atempd(1,1))
9575       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9576       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9577 #endif
9578       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9579       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9580 #ifdef MOMENT
9581       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9582       ss13d = scalar2(b1(1,k),vtemp4d(1))
9583       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9584 #endif
9585 c      s1d=0.0d0
9586 c      s2d=0.0d0
9587 c      s8d=0.0d0
9588 c      s12d=0.0d0
9589 c      s13d=0.0d0
9590 #ifdef MOMENT
9591       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9592      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9593 #else
9594       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9595      &               -0.5d0*ekont*(s2d+s12d)
9596 #endif
9597 C Cartesian derivatives
9598       do iii=1,2
9599         do kkk=1,5
9600           do lll=1,3
9601 #ifdef MOMENT
9602             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9603             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9604             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9605 #endif
9606             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9607             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9608      &          vtemp1d(1))
9609             s2d = scalar2(b1(1,k),vtemp1d(1))
9610 #ifdef MOMENT
9611             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9612             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9613             s8d = -(atempd(1,1)+atempd(2,2))*
9614      &           scalar2(cc(1,1,itl),vtemp2(1))
9615 #endif
9616             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9617      &           auxmatd(1,1))
9618             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9619             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9620 c      s1d=0.0d0
9621 c      s2d=0.0d0
9622 c      s8d=0.0d0
9623 c      s12d=0.0d0
9624 c      s13d=0.0d0
9625 #ifdef MOMENT
9626             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9627      &        - 0.5d0*(s1d+s2d)
9628 #else
9629             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9630      &        - 0.5d0*s2d
9631 #endif
9632 #ifdef MOMENT
9633             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9634      &        - 0.5d0*(s8d+s12d)
9635 #else
9636             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9637      &        - 0.5d0*s12d
9638 #endif
9639           enddo
9640         enddo
9641       enddo
9642 #ifdef MOMENT
9643       do kkk=1,5
9644         do lll=1,3
9645           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9646      &      achuj_tempd(1,1))
9647           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9648           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9649           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9650           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9651           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9652      &      vtemp4d(1))
9653           ss13d = scalar2(b1(1,k),vtemp4d(1))
9654           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9655           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9656         enddo
9657       enddo
9658 #endif
9659 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9660 cd     &  16*eel_turn6_num
9661 cd      goto 1112
9662       if (j.lt.nres-1) then
9663         j1=j+1
9664         j2=j-1
9665       else
9666         j1=j-1
9667         j2=j-2
9668       endif
9669       if (l.lt.nres-1) then
9670         l1=l+1
9671         l2=l-1
9672       else
9673         l1=l-1
9674         l2=l-2
9675       endif
9676       do ll=1,3
9677 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9678 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9679 cgrad        ghalf=0.5d0*ggg1(ll)
9680 cd        ghalf=0.0d0
9681         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9682         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9683         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9684      &    +ekont*derx_turn(ll,2,1)
9685         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9686         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9687      &    +ekont*derx_turn(ll,4,1)
9688         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9689         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9690         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9691 cgrad        ghalf=0.5d0*ggg2(ll)
9692 cd        ghalf=0.0d0
9693         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9694      &    +ekont*derx_turn(ll,2,2)
9695         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9696         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9697      &    +ekont*derx_turn(ll,4,2)
9698         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9699         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9700         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9701       enddo
9702 cd      goto 1112
9703 cgrad      do m=i+1,j-1
9704 cgrad        do ll=1,3
9705 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9706 cgrad        enddo
9707 cgrad      enddo
9708 cgrad      do m=k+1,l-1
9709 cgrad        do ll=1,3
9710 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9711 cgrad        enddo
9712 cgrad      enddo
9713 cgrad1112  continue
9714 cgrad      do m=i+2,j2
9715 cgrad        do ll=1,3
9716 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9717 cgrad        enddo
9718 cgrad      enddo
9719 cgrad      do m=k+2,l2
9720 cgrad        do ll=1,3
9721 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9722 cgrad        enddo
9723 cgrad      enddo
9724 cd      do iii=1,nres-3
9725 cd        write (2,*) iii,g_corr6_loc(iii)
9726 cd      enddo
9727       eello_turn6=ekont*eel_turn6
9728 cd      write (2,*) 'ekont',ekont
9729 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9730       return
9731       end
9732
9733 C-----------------------------------------------------------------------------
9734       double precision function scalar(u,v)
9735 !DIR$ INLINEALWAYS scalar
9736 #ifndef OSF
9737 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9738 #endif
9739       implicit none
9740       double precision u(3),v(3)
9741 cd      double precision sc
9742 cd      integer i
9743 cd      sc=0.0d0
9744 cd      do i=1,3
9745 cd        sc=sc+u(i)*v(i)
9746 cd      enddo
9747 cd      scalar=sc
9748
9749       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9750       return
9751       end
9752 crc-------------------------------------------------
9753       SUBROUTINE MATVEC2(A1,V1,V2)
9754 !DIR$ INLINEALWAYS MATVEC2
9755 #ifndef OSF
9756 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9757 #endif
9758       implicit real*8 (a-h,o-z)
9759       include 'DIMENSIONS'
9760       DIMENSION A1(2,2),V1(2),V2(2)
9761 c      DO 1 I=1,2
9762 c        VI=0.0
9763 c        DO 3 K=1,2
9764 c    3     VI=VI+A1(I,K)*V1(K)
9765 c        Vaux(I)=VI
9766 c    1 CONTINUE
9767
9768       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9769       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9770
9771       v2(1)=vaux1
9772       v2(2)=vaux2
9773       END
9774 C---------------------------------------
9775       SUBROUTINE MATMAT2(A1,A2,A3)
9776 #ifndef OSF
9777 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9778 #endif
9779       implicit real*8 (a-h,o-z)
9780       include 'DIMENSIONS'
9781       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9782 c      DIMENSION AI3(2,2)
9783 c        DO  J=1,2
9784 c          A3IJ=0.0
9785 c          DO K=1,2
9786 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9787 c          enddo
9788 c          A3(I,J)=A3IJ
9789 c       enddo
9790 c      enddo
9791
9792       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9793       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9794       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9795       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9796
9797       A3(1,1)=AI3_11
9798       A3(2,1)=AI3_21
9799       A3(1,2)=AI3_12
9800       A3(2,2)=AI3_22
9801       END
9802
9803 c-------------------------------------------------------------------------
9804       double precision function scalar2(u,v)
9805 !DIR$ INLINEALWAYS scalar2
9806       implicit none
9807       double precision u(2),v(2)
9808       double precision sc
9809       integer i
9810       scalar2=u(1)*v(1)+u(2)*v(2)
9811       return
9812       end
9813
9814 C-----------------------------------------------------------------------------
9815
9816       subroutine transpose2(a,at)
9817 !DIR$ INLINEALWAYS transpose2
9818 #ifndef OSF
9819 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9820 #endif
9821       implicit none
9822       double precision a(2,2),at(2,2)
9823       at(1,1)=a(1,1)
9824       at(1,2)=a(2,1)
9825       at(2,1)=a(1,2)
9826       at(2,2)=a(2,2)
9827       return
9828       end
9829 c--------------------------------------------------------------------------
9830       subroutine transpose(n,a,at)
9831       implicit none
9832       integer n,i,j
9833       double precision a(n,n),at(n,n)
9834       do i=1,n
9835         do j=1,n
9836           at(j,i)=a(i,j)
9837         enddo
9838       enddo
9839       return
9840       end
9841 C---------------------------------------------------------------------------
9842       subroutine prodmat3(a1,a2,kk,transp,prod)
9843 !DIR$ INLINEALWAYS prodmat3
9844 #ifndef OSF
9845 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9846 #endif
9847       implicit none
9848       integer i,j
9849       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9850       logical transp
9851 crc      double precision auxmat(2,2),prod_(2,2)
9852
9853       if (transp) then
9854 crc        call transpose2(kk(1,1),auxmat(1,1))
9855 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9856 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9857
9858            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9859      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9860            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9861      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9862            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9863      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9864            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9865      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9866
9867       else
9868 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9869 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9870
9871            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9872      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9873            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9874      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9875            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9876      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9877            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9878      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9879
9880       endif
9881 c      call transpose2(a2(1,1),a2t(1,1))
9882
9883 crc      print *,transp
9884 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9885 crc      print *,((prod(i,j),i=1,2),j=1,2)
9886
9887       return
9888       end
9889