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 c      print *,"Processor",myrank," computed USCSC"
 126 #ifdef TIMING
 127       time01=MPI_Wtime()
 128 #endif
 129       call vec_and_deriv
 130 #ifdef TIMING
 131       time_vec=time_vec+MPI_Wtime()-time01
 132 #endif
 133 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 134       if (ipot.lt.6) then
 135 #ifdef SPLITELE
 136          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 137      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 138      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 139      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 140 #else
 141          if (welec.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 #endif
 146             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 147          else
 148             ees=0.0d0
 149             evdw1=0.0d0
 150             eel_loc=0.0d0
 151             eello_turn3=0.0d0
 152             eello_turn4=0.0d0
 153          endif
 154       else
 155         write (iout,*) "Soft-spheer ELEC potential"
 156 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 157 c     &   eello_turn4)
 158       endif
 159 c      print *,"Processor",myrank," computed UELEC"
 160 C
 161 C Calculate excluded-volume interaction energy between peptide groups
 162 C and side chains.
 163 C
 164       if (ipot.lt.6) then
 165        if(wscp.gt.0d0) then
 166         call escp(evdw2,evdw2_14)
 167        else
 168         evdw2=0
 169         evdw2_14=0
 170        endif
 171       else
 172 c        write (iout,*) "Soft-sphere SCP potential"
 173         call escp_soft_sphere(evdw2,evdw2_14)
 174       endif
 175 c
 176 c Calculate the bond-stretching energy
 177 c
 178       call ebond(estr)
 179 C
 180 C Calculate the disulfide-bridge and other energy and the contributions
 181 C from other distance constraints.
 182 cd    print *,'Calling EHPB'
 183       call edis(ehpb)
 184 cd    print *,'EHPB exitted succesfully.'
 185 C
 186 C Calculate the virtual-bond-angle energy.
 187 C
 188       if (wang.gt.0d0) then
 189         call ebend(ebe)
 190       else
 191         ebe=0
 192       endif
 193 c      print *,"Processor",myrank," computed UB"
 194 C
 195 C Calculate the SC local energy.
 196 C
 197       call esc(escloc)
 198 c      print *,"Processor",myrank," computed USC"
 199 C
 200 C Calculate the virtual-bond torsional energy.
 201 C
 202 cd    print *,'nterm=',nterm
 203       if (wtor.gt.0) then
 204        call etor(etors,edihcnstr)
 205       else
 206        etors=0
 207        edihcnstr=0
 208       endif
 209 c      print *,"Processor",myrank," computed Utor"
 210 C
 211 C 6/23/01 Calculate double-torsional energy
 212 C
 213       if (wtor_d.gt.0) then
 214        call etor_d(etors_d)
 215       else
 216        etors_d=0
 217       endif
 218 c      print *,"Processor",myrank," computed Utord"
 219 C
 220 C 21/5/07 Calculate local sicdechain correlation energy
 221 C
 222       if (wsccor.gt.0.0d0) then
 223         call eback_sc_corr(esccor)
 224       else
 225         esccor=0.0d0
 226       endif
 227 c      print *,"Processor",myrank," computed Usccorr"
 228 C
 229 C 12/1/95 Multi-body terms
 230 C
 231       n_corr=0
 232       n_corr1=0
 233       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 234      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 235          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 236 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 237 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 238       else
 239          ecorr=0.0d0
 240          ecorr5=0.0d0
 241          ecorr6=0.0d0
 242          eturn6=0.0d0
 243       endif
 244       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 245          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 246 cd         write (iout,*) "multibody_hb ecorr",ecorr
 247       endif
 248 c      print *,"Processor",myrank," computed Ucorr"
 249 C
 250 C If performing constraint dynamics, call the constraint energy
 251 C  after the equilibration time
 252       if(usampl.and.totT.gt.eq_time) then
 253          call EconstrQ
 254          call Econstr_back
 255       else
 256          Uconst=0.0d0
 257          Uconst_back=0.0d0
 258       endif
 259 #ifdef TIMING
 260       time_enecalc=time_enecalc+MPI_Wtime()-time00
 261 #endif
 262 c      print *,"Processor",myrank," computed Uconstr"
 263 #ifdef TIMING
 264       time00=MPI_Wtime()
 265 #endif
 266 c
 267 C Sum the energies
 268 C
 269       energia(1)=evdw
 270 #ifdef SCP14
 271       energia(2)=evdw2-evdw2_14
 272       energia(18)=evdw2_14
 273 #else
 274       energia(2)=evdw2
 275       energia(18)=0.0d0
 276 #endif
 277 #ifdef SPLITELE
 278       energia(3)=ees
 279       energia(16)=evdw1
 280 #else
 281       energia(3)=ees+evdw1
 282       energia(16)=0.0d0
 283 #endif
 284       energia(4)=ecorr
 285       energia(5)=ecorr5
 286       energia(6)=ecorr6
 287       energia(7)=eel_loc
 288       energia(8)=eello_turn3
 289       energia(9)=eello_turn4
 290       energia(10)=eturn6
 291       energia(11)=ebe
 292       energia(12)=escloc
 293       energia(13)=etors
 294       energia(14)=etors_d
 295       energia(15)=ehpb
 296       energia(19)=edihcnstr
 297       energia(17)=estr
 298       energia(20)=Uconst+Uconst_back
 299       energia(21)=esccor
 300 c    Here are the energies showed per procesor if the are more processors
 301 c    per molecule then we sum it up in sum_energy subroutine
 302 c      print *," Processor",myrank," calls SUM_ENERGY"
 303       call sum_energy(energia,.true.)
 304 c      print *," Processor",myrank," left SUM_ENERGY"
 305 #ifdef TIMING
 306       time_sumene=time_sumene+MPI_Wtime()-time00
 307 #endif
 308       return
 309       end
 310 c-------------------------------------------------------------------------------
 311       subroutine sum_energy(energia,reduce)
 312       implicit real*8 (a-h,o-z)
 313       include 'DIMENSIONS'
 314 #ifndef ISNAN
 315       external proc_proc
 316 #ifdef WINPGI
 317 cMS$ATTRIBUTES C ::  proc_proc
 318 #endif
 319 #endif
 320 #ifdef MPI
 321       include "mpif.h"
 322 #endif
 323       include 'COMMON.SETUP'
 324       include 'COMMON.IOUNITS'
 325       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 326       include 'COMMON.FFIELD'
 327       include 'COMMON.DERIV'
 328       include 'COMMON.INTERACT'
 329       include 'COMMON.SBRIDGE'
 330       include 'COMMON.CHAIN'
 331       include 'COMMON.VAR'
 332       include 'COMMON.CONTROL'
 333       include 'COMMON.TIME1'
 334       logical reduce
 335 #ifdef MPI
 336       if (nfgtasks.gt.1 .and. reduce) then
 337 #ifdef DEBUG
 338         write (iout,*) "energies before REDUCE"
 339         call enerprint(energia)
 340         call flush(iout)
 341 #endif
 342         do i=0,n_ene
 343           enebuff(i)=energia(i)
 344         enddo
 345         time00=MPI_Wtime()
 346         call MPI_Barrier(FG_COMM,IERR)
 347         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 348         time00=MPI_Wtime()
 349         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 350      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 351 #ifdef DEBUG
 352         write (iout,*) "energies after REDUCE"
 353         call enerprint(energia)
 354         call flush(iout)
 355 #endif
 356         time_Reduce=time_Reduce+MPI_Wtime()-time00
 357       endif
 358       if (fg_rank.eq.0) then
 359 #endif
 360       evdw=energia(1)
 361 #ifdef SCP14
 362       evdw2=energia(2)+energia(18)
 363       evdw2_14=energia(18)
 364 #else
 365       evdw2=energia(2)
 366 #endif
 367 #ifdef SPLITELE
 368       ees=energia(3)
 369       evdw1=energia(16)
 370 #else
 371       ees=energia(3)
 372       evdw1=0.0d0
 373 #endif
 374       ecorr=energia(4)
 375       ecorr5=energia(5)
 376       ecorr6=energia(6)
 377       eel_loc=energia(7)
 378       eello_turn3=energia(8)
 379       eello_turn4=energia(9)
 380       eturn6=energia(10)
 381       ebe=energia(11)
 382       escloc=energia(12)
 383       etors=energia(13)
 384       etors_d=energia(14)
 385       ehpb=energia(15)
 386       edihcnstr=energia(19)
 387       estr=energia(17)
 388       Uconst=energia(20)
 389       esccor=energia(21)
 390 #ifdef SPLITELE
 391       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 392      & +wang*ebe+wtor*etors+wscloc*escloc
 393      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 394      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 395      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 396      & +wbond*estr+Uconst+wsccor*esccor
 397 #else
 398       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 399      & +wang*ebe+wtor*etors+wscloc*escloc
 400      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 401      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 402      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 403      & +wbond*estr+Uconst+wsccor*esccor
 404 #endif
 405       energia(0)=etot
 406 c detecting NaNQ
 407 #ifdef ISNAN
 408 #ifdef AIX
 409       if (isnan(etot).ne.0) energia(0)=1.0d+99
 410 #else
 411       if (isnan(etot)) energia(0)=1.0d+99
 412 #endif
 413 #else
 414       i=0
 415 #ifdef WINPGI
 416       idumm=proc_proc(etot,i)
 417 #else
 418       call proc_proc(etot,i)
 419 #endif
 420       if(i.eq.1)energia(0)=1.0d+99
 421 #endif
 422 #ifdef MPI
 423       endif
 424 #endif
 425       return
 426       end
 427 c-------------------------------------------------------------------------------
 428       subroutine sum_gradient
 429       implicit real*8 (a-h,o-z)
 430       include 'DIMENSIONS'
 431 #ifndef ISNAN
 432       external proc_proc
 433 #ifdef WINPGI
 434 cMS$ATTRIBUTES C ::  proc_proc
 435 #endif
 436 #endif
 437 #ifdef MPI
 438       include 'mpif.h'
 439       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 440      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 441 #endif
 442       include 'COMMON.SETUP'
 443       include 'COMMON.IOUNITS'
 444       include 'COMMON.FFIELD'
 445       include 'COMMON.DERIV'
 446       include 'COMMON.INTERACT'
 447       include 'COMMON.SBRIDGE'
 448       include 'COMMON.CHAIN'
 449       include 'COMMON.VAR'
 450       include 'COMMON.CONTROL'
 451       include 'COMMON.TIME1'
 452       include 'COMMON.MAXGRAD'
 453       include 'COMMON.SCCOR'
 454 #ifdef TIMING
 455       time01=MPI_Wtime()
 456 #endif
 457 #ifdef DEBUG
 458       write (iout,*) "sum_gradient gvdwc, gvdwx"
 459       do i=1,nres
 460         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 461      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 462       enddo
 463       call flush(iout)
 464 #endif
 465 #ifdef MPI
 466 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 467         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 468      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 469 #endif
 470 C
 471 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 472 C            in virtual-bond-vector coordinates
 473 C
 474 #ifdef DEBUG
 475 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 476 c      do i=1,nres-1
 477 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 478 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 479 c      enddo
 480 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 483 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 484 c      enddo
 485       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 486       do i=1,nres
 487         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 488      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 489      &   g_corr5_loc(i)
 490       enddo
 491       call flush(iout)
 492 #endif
 493 #ifdef SPLITELE
 494       do i=1,nct
 495         do j=1,3
 496           gradbufc(j,i)=wsc*gvdwc(j,i)+
 497      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 498      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 499      &                wel_loc*gel_loc_long(j,i)+
 500      &                wcorr*gradcorr_long(j,i)+
 501      &                wcorr5*gradcorr5_long(j,i)+
 502      &                wcorr6*gradcorr6_long(j,i)+
 503      &                wturn6*gcorr6_turn_long(j,i)+
 504      &                wstrain*ghpbc(j,i)
 505         enddo
 506       enddo
 507 #else
 508       do i=1,nct
 509         do j=1,3
 510           gradbufc(j,i)=wsc*gvdwc(j,i)+
 511      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 512      &                welec*gelc_long(j,i)+
 513      &                wbond*gradb(j,i)+
 514      &                wel_loc*gel_loc_long(j,i)+
 515      &                wcorr*gradcorr_long(j,i)+
 516      &                wcorr5*gradcorr5_long(j,i)+
 517      &                wcorr6*gradcorr6_long(j,i)+
 518      &                wturn6*gcorr6_turn_long(j,i)+
 519      &                wstrain*ghpbc(j,i)
 520         enddo
 521       enddo
 522 #endif
 523 #ifdef MPI
 524       if (nfgtasks.gt.1) then
 525       time00=MPI_Wtime()
 526 #ifdef DEBUG
 527       write (iout,*) "gradbufc before allreduce"
 528       do i=1,nres
 529         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 530       enddo
 531       call flush(iout)
 532 #endif
 533       do i=1,nres
 534         do j=1,3
 535           gradbufc_sum(j,i)=gradbufc(j,i)
 536         enddo
 537       enddo
 538 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 539 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 540 c      time_reduce=time_reduce+MPI_Wtime()-time00
 541 #ifdef DEBUG
 542 c      write (iout,*) "gradbufc_sum after allreduce"
 543 c      do i=1,nres
 544 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 545 c      enddo
 546 c      call flush(iout)
 547 #endif
 548 #ifdef TIMING
 549 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 550 #endif
 551       do i=nnt,nres
 552         do k=1,3
 553           gradbufc(k,i)=0.0d0
 554         enddo
 555       enddo
 556 #ifdef DEBUG
 557       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 558       write (iout,*) (i," jgrad_start",jgrad_start(i),
 559      &                  " jgrad_end  ",jgrad_end(i),
 560      &                  i=igrad_start,igrad_end)
 561 #endif
 562 c
 563 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 564 c do not parallelize this part.
 565 c
 566 c      do i=igrad_start,igrad_end
 567 c        do j=jgrad_start(i),jgrad_end(i)
 568 c          do k=1,3
 569 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 570 c          enddo
 571 c        enddo
 572 c      enddo
 573       do j=1,3
 574         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 575       enddo
 576       do i=nres-2,nnt,-1
 577         do j=1,3
 578           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 579         enddo
 580       enddo
 581 #ifdef DEBUG
 582       write (iout,*) "gradbufc after summing"
 583       do i=1,nres
 584         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 585       enddo
 586       call flush(iout)
 587 #endif
 588       else
 589 #endif
 590 #ifdef DEBUG
 591       write (iout,*) "gradbufc"
 592       do i=1,nres
 593         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 594       enddo
 595       call flush(iout)
 596 #endif
 597       do i=1,nres
 598         do j=1,3
 599           gradbufc_sum(j,i)=gradbufc(j,i)
 600           gradbufc(j,i)=0.0d0
 601         enddo
 602       enddo
 603       do j=1,3
 604         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 605       enddo
 606       do i=nres-2,nnt,-1
 607         do j=1,3
 608           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 609         enddo
 610       enddo
 611 c      do i=nnt,nres-1
 612 c        do k=1,3
 613 c          gradbufc(k,i)=0.0d0
 614 c        enddo
 615 c        do j=i+1,nres
 616 c          do k=1,3
 617 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 618 c          enddo
 619 c        enddo
 620 c      enddo
 621 #ifdef DEBUG
 622       write (iout,*) "gradbufc after summing"
 623       do i=1,nres
 624         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 625       enddo
 626       call flush(iout)
 627 #endif
 628 #ifdef MPI
 629       endif
 630 #endif
 631       do k=1,3
 632         gradbufc(k,nres)=0.0d0
 633       enddo
 634       do i=1,nct
 635         do j=1,3
 636 #ifdef SPLITELE
 637           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 638      &                wel_loc*gel_loc(j,i)+
 639      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 640      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 641      &                wel_loc*gel_loc_long(j,i)+
 642      &                wcorr*gradcorr_long(j,i)+
 643      &                wcorr5*gradcorr5_long(j,i)+
 644      &                wcorr6*gradcorr6_long(j,i)+
 645      &                wturn6*gcorr6_turn_long(j,i))+
 646      &                wbond*gradb(j,i)+
 647      &                wcorr*gradcorr(j,i)+
 648      &                wturn3*gcorr3_turn(j,i)+
 649      &                wturn4*gcorr4_turn(j,i)+
 650      &                wcorr5*gradcorr5(j,i)+
 651      &                wcorr6*gradcorr6(j,i)+
 652      &                wturn6*gcorr6_turn(j,i)+
 653      &                wsccor*gsccorc(j,i)
 654      &               +wscloc*gscloc(j,i)
 655 #else
 656           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 657      &                wel_loc*gel_loc(j,i)+
 658      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 659      &                welec*gelc_long(j,i)
 660      &                wel_loc*gel_loc_long(j,i)+
 661      &                wcorr*gcorr_long(j,i)+
 662      &                wcorr5*gradcorr5_long(j,i)+
 663      &                wcorr6*gradcorr6_long(j,i)+
 664      &                wturn6*gcorr6_turn_long(j,i))+
 665      &                wbond*gradb(j,i)+
 666      &                wcorr*gradcorr(j,i)+
 667      &                wturn3*gcorr3_turn(j,i)+
 668      &                wturn4*gcorr4_turn(j,i)+
 669      &                wcorr5*gradcorr5(j,i)+
 670      &                wcorr6*gradcorr6(j,i)+
 671      &                wturn6*gcorr6_turn(j,i)+
 672      &                wsccor*gsccorc(j,i)
 673      &               +wscloc*gscloc(j,i)
 674 #endif
 675           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 676      &                  wbond*gradbx(j,i)+
 677      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 678      &                  wsccor*gsccorx(j,i)
 679      &                 +wscloc*gsclocx(j,i)
 680         enddo
 681       enddo
 682 #ifdef DEBUG
 683       write (iout,*) "gloc before adding corr"
 684       do i=1,4*nres
 685         write (iout,*) i,gloc(i,icg)
 686       enddo
 687 #endif
 688       do i=1,nres-3
 689         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 690      &   +wcorr5*g_corr5_loc(i)
 691      &   +wcorr6*g_corr6_loc(i)
 692      &   +wturn4*gel_loc_turn4(i)
 693      &   +wturn3*gel_loc_turn3(i)
 694      &   +wturn6*gel_loc_turn6(i)
 695      &   +wel_loc*gel_loc_loc(i)
 696       enddo
 697 #ifdef DEBUG
 698       write (iout,*) "gloc after adding corr"
 699       do i=1,4*nres
 700         write (iout,*) i,gloc(i,icg)
 701       enddo
 702 #endif
 703 #ifdef MPI
 704       if (nfgtasks.gt.1) then
 705         do j=1,3
 706           do i=1,nres
 707             gradbufc(j,i)=gradc(j,i,icg)
 708             gradbufx(j,i)=gradx(j,i,icg)
 709           enddo
 710         enddo
 711         do i=1,4*nres
 712           glocbuf(i)=gloc(i,icg)
 713         enddo
 714 c#define DEBUG
 715 #ifdef DEBUG
 716       write (iout,*) "gloc_sc before reduce"
 717       do i=1,nres
 718        do j=1,1
 719         write (iout,*) i,j,gloc_sc(j,i,icg)
 720        enddo
 721       enddo
 722 #endif
 723 c#undef DEBUG
 724         do i=1,nres
 725          do j=1,3
 726           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 727          enddo
 728         enddo
 729         time00=MPI_Wtime()
 730         call MPI_Barrier(FG_COMM,IERR)
 731         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 732         time00=MPI_Wtime()
 733         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 734      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 735         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 736      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 737         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         time_reduce=time_reduce+MPI_Wtime()-time00
 740         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         time_reduce=time_reduce+MPI_Wtime()-time00
 743 c#define DEBUG
 744 #ifdef DEBUG
 745       write (iout,*) "gloc_sc after reduce"
 746       do i=1,nres
 747        do j=1,1
 748         write (iout,*) i,j,gloc_sc(j,i,icg)
 749        enddo
 750       enddo
 751 #endif
 752 c#undef DEBUG
 753 #ifdef DEBUG
 754       write (iout,*) "gloc after reduce"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       endif
 760 #endif
 761       if (gnorm_check) then
 762 c
 763 c Compute the maximum elements of the gradient
 764 c
 765       gvdwc_max=0.0d0
 766       gvdwc_scp_max=0.0d0
 767       gelc_max=0.0d0
 768       gvdwpp_max=0.0d0
 769       gradb_max=0.0d0
 770       ghpbc_max=0.0d0
 771       gradcorr_max=0.0d0
 772       gel_loc_max=0.0d0
 773       gcorr3_turn_max=0.0d0
 774       gcorr4_turn_max=0.0d0
 775       gradcorr5_max=0.0d0
 776       gradcorr6_max=0.0d0
 777       gcorr6_turn_max=0.0d0
 778       gsccorc_max=0.0d0
 779       gscloc_max=0.0d0
 780       gvdwx_max=0.0d0
 781       gradx_scp_max=0.0d0
 782       ghpbx_max=0.0d0
 783       gradxorr_max=0.0d0
 784       gsccorx_max=0.0d0
 785       gsclocx_max=0.0d0
 786       do i=1,nct
 787         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 788         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 789         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 790         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 791      &   gvdwc_scp_max=gvdwc_scp_norm
 792         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 793         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 794         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 795         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 796         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 797         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 798         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 799         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 800         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 801         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 802         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 803         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 804         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 805      &    gcorr3_turn(1,i)))
 806         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 807      &    gcorr3_turn_max=gcorr3_turn_norm
 808         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 809      &    gcorr4_turn(1,i)))
 810         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 811      &    gcorr4_turn_max=gcorr4_turn_norm
 812         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 813         if (gradcorr5_norm.gt.gradcorr5_max)
 814      &    gradcorr5_max=gradcorr5_norm
 815         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 816         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 817         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 818      &    gcorr6_turn(1,i)))
 819         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 820      &    gcorr6_turn_max=gcorr6_turn_norm
 821         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 822         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 823         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 824         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 825         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 826         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 827         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 828         if (gradx_scp_norm.gt.gradx_scp_max)
 829      &    gradx_scp_max=gradx_scp_norm
 830         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 831         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 832         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 833         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 834         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 835         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 836         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 837         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 838       enddo
 839       if (gradout) then
 840 #ifdef AIX
 841         open(istat,file=statname,position="append")
 842 #else
 843         open(istat,file=statname,access="append")
 844 #endif
 845         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 846      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 847      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 848      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 849      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 850      &     gsccorx_max,gsclocx_max
 851         close(istat)
 852         if (gvdwc_max.gt.1.0d4) then
 853           write (iout,*) "gvdwc gvdwx gradb gradbx"
 854           do i=nnt,nct
 855             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 856      &        gradb(j,i),gradbx(j,i),j=1,3)
 857           enddo
 858           call pdbout(0.0d0,'cipiszcze',iout)
 859           call flush(iout)
 860         endif
 861       endif
 862       endif
 863 #ifdef DEBUG
 864       write (iout,*) "gradc gradx gloc"
 865       do i=1,nres
 866         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 867      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 868       enddo
 869 #endif
 870 #ifdef TIMING
 871       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 872 #endif
 873       return
 874       end
 875 c-------------------------------------------------------------------------------
 876       subroutine rescale_weights(t_bath)
 877       implicit real*8 (a-h,o-z)
 878       include 'DIMENSIONS'
 879       include 'COMMON.IOUNITS'
 880       include 'COMMON.FFIELD'
 881       include 'COMMON.SBRIDGE'
 882       double precision kfac /2.4d0/
 883       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 884 c      facT=temp0/t_bath
 885 c      facT=2*temp0/(t_bath+temp0)
 886       if (rescale_mode.eq.0) then
 887         facT=1.0d0
 888         facT2=1.0d0
 889         facT3=1.0d0
 890         facT4=1.0d0
 891         facT5=1.0d0
 892       else if (rescale_mode.eq.1) then
 893         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 894         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 895         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 896         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 897         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 898       else if (rescale_mode.eq.2) then
 899         x=t_bath/temp0
 900         x2=x*x
 901         x3=x2*x
 902         x4=x3*x
 903         x5=x4*x
 904         facT=licznik/dlog(dexp(x)+dexp(-x))
 905         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 906         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 907         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 908         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 909       else
 910         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 911         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 912 #ifdef MPI
 913        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 914 #endif
 915        stop 555
 916       endif
 917       welec=weights(3)*fact
 918       wcorr=weights(4)*fact3
 919       wcorr5=weights(5)*fact4
 920       wcorr6=weights(6)*fact5
 921       wel_loc=weights(7)*fact2
 922       wturn3=weights(8)*fact2
 923       wturn4=weights(9)*fact3
 924       wturn6=weights(10)*fact5
 925       wtor=weights(13)*fact
 926       wtor_d=weights(14)*fact2
 927       wsccor=weights(21)*fact
 928
 929       return
 930       end
 931 C------------------------------------------------------------------------
 932       subroutine enerprint(energia)
 933       implicit real*8 (a-h,o-z)
 934       include 'DIMENSIONS'
 935       include 'COMMON.IOUNITS'
 936       include 'COMMON.FFIELD'
 937       include 'COMMON.SBRIDGE'
 938       include 'COMMON.MD'
 939       double precision energia(0:n_ene)
 940       etot=energia(0)
 941       evdw=energia(1)
 942       evdw2=energia(2)
 943 #ifdef SCP14
 944       evdw2=energia(2)+energia(18)
 945 #else
 946       evdw2=energia(2)
 947 #endif
 948       ees=energia(3)
 949 #ifdef SPLITELE
 950       evdw1=energia(16)
 951 #endif
 952       ecorr=energia(4)
 953       ecorr5=energia(5)
 954       ecorr6=energia(6)
 955       eel_loc=energia(7)
 956       eello_turn3=energia(8)
 957       eello_turn4=energia(9)
 958       eello_turn6=energia(10)
 959       ebe=energia(11)
 960       escloc=energia(12)
 961       etors=energia(13)
 962       etors_d=energia(14)
 963       ehpb=energia(15)
 964       edihcnstr=energia(19)
 965       estr=energia(17)
 966       Uconst=energia(20)
 967       esccor=energia(21)
 968 #ifdef SPLITELE
 969       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 970      &  estr,wbond,ebe,wang,
 971      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 972      &  ecorr,wcorr,
 973      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 974      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 975      &  edihcnstr,ebr*nss,
 976      &  Uconst,etot
 977    10 format (/'Virtual-chain energies:'//
 978      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 979      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 980      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 981      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 982      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 983      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 984      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 985      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 986      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 987      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 988      & ' (SS bridges & dist. cnstr.)'/
 989      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 993      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 994      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 995      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 996      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 997      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 998      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 999      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1000      & 'ETOT=  ',1pE16.6,' (total)')
1001 #else
1002       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1003      &  estr,wbond,ebe,wang,
1004      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1005      &  ecorr,wcorr,
1006      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1007      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1008      &  ebr*nss,Uconst,etot
1009    10 format (/'Virtual-chain energies:'//
1010      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1011      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1012      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1013      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1014      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1015      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1016      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1017      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1018      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1019      & ' (SS bridges & dist. cnstr.)'/
1020      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1023      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1024      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1025      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1026      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1027      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1028      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1029      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1030      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1031      & 'ETOT=  ',1pE16.6,' (total)')
1032 #endif
1033       return
1034       end
1035 C-----------------------------------------------------------------------
1036       subroutine elj(evdw)
1037 C
1038 C This subroutine calculates the interaction energy of nonbonded side chains
1039 C assuming the LJ potential of interaction.
1040 C
1041       implicit real*8 (a-h,o-z)
1042       include 'DIMENSIONS'
1043       parameter (accur=1.0d-10)
1044       include 'COMMON.GEO'
1045       include 'COMMON.VAR'
1046       include 'COMMON.LOCAL'
1047       include 'COMMON.CHAIN'
1048       include 'COMMON.DERIV'
1049       include 'COMMON.INTERACT'
1050       include 'COMMON.TORSION'
1051       include 'COMMON.SBRIDGE'
1052       include 'COMMON.NAMES'
1053       include 'COMMON.IOUNITS'
1054       include 'COMMON.CONTACTS'
1055       dimension gg(3)
1056 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1057       evdw=0.0D0
1058       do i=iatsc_s,iatsc_e
1059         itypi=iabs(itype(i))
1060         if (itypi.eq.ntyp1) cycle
1061         itypi1=iabs(itype(i+1))
1062         xi=c(1,nres+i)
1063         yi=c(2,nres+i)
1064         zi=c(3,nres+i)
1065 C Change 12/1/95
1066         num_conti=0
1067 C
1068 C Calculate SC interaction energy.
1069 C
1070         do iint=1,nint_gr(i)
1071 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1072 cd   &                  'iend=',iend(i,iint)
1073           do j=istart(i,iint),iend(i,iint)
1074             itypj=iabs(itype(j))
1075             if (itypj.eq.ntyp1) cycle
1076             xj=c(1,nres+j)-xi
1077             yj=c(2,nres+j)-yi
1078             zj=c(3,nres+j)-zi
1079 C Change 12/1/95 to calculate four-body interactions
1080             rij=xj*xj+yj*yj+zj*zj
1081             rrij=1.0D0/rij
1082 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1083             eps0ij=eps(itypi,itypj)
1084             fac=rrij**expon2
1085             e1=fac*fac*aa(itypi,itypj)
1086             e2=fac*bb(itypi,itypj)
1087             evdwij=e1+e2
1088 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1089 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1090 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1091 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1092 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1093 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1094             evdw=evdw+evdwij
1095 C
1096 C Calculate the components of the gradient in DC and X
1097 C
1098             fac=-rrij*(e1+evdwij)
1099             gg(1)=xj*fac
1100             gg(2)=yj*fac
1101             gg(3)=zj*fac
1102             do k=1,3
1103               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1104               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1105               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1106               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1107             enddo
1108 cgrad            do k=i,j-1
1109 cgrad              do l=1,3
1110 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1111 cgrad              enddo
1112 cgrad            enddo
1113 C
1114 C 12/1/95, revised on 5/20/97
1115 C
1116 C Calculate the contact function. The ith column of the array JCONT will
1117 C contain the numbers of atoms that make contacts with the atom I (of numbers
1118 C greater than I). The arrays FACONT and GACONT will contain the values of
1119 C the contact function and its derivative.
1120 C
1121 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1122 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1123 C Uncomment next line, if the correlation interactions are contact function only
1124             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1125               rij=dsqrt(rij)
1126               sigij=sigma(itypi,itypj)
1127               r0ij=rs0(itypi,itypj)
1128 C
1129 C Check whether the SC's are not too far to make a contact.
1130 C
1131               rcut=1.5d0*r0ij
1132               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1133 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1134 C
1135               if (fcont.gt.0.0D0) then
1136 C If the SC-SC distance if close to sigma, apply spline.
1137 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1138 cAdam &             fcont1,fprimcont1)
1139 cAdam           fcont1=1.0d0-fcont1
1140 cAdam           if (fcont1.gt.0.0d0) then
1141 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1142 cAdam             fcont=fcont*fcont1
1143 cAdam           endif
1144 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1145 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1146 cga             do k=1,3
1147 cga               gg(k)=gg(k)*eps0ij
1148 cga             enddo
1149 cga             eps0ij=-evdwij*eps0ij
1150 C Uncomment for AL's type of SC correlation interactions.
1151 cadam           eps0ij=-evdwij
1152                 num_conti=num_conti+1
1153                 jcont(num_conti,i)=j
1154                 facont(num_conti,i)=fcont*eps0ij
1155                 fprimcont=eps0ij*fprimcont/rij
1156                 fcont=expon*fcont
1157 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1158 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1159 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1160 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1161                 gacont(1,num_conti,i)=-fprimcont*xj
1162                 gacont(2,num_conti,i)=-fprimcont*yj
1163                 gacont(3,num_conti,i)=-fprimcont*zj
1164 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1165 cd              write (iout,'(2i3,3f10.5)')
1166 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1167               endif
1168             endif
1169           enddo      ! j
1170         enddo        ! iint
1171 C Change 12/1/95
1172         num_cont(i)=num_conti
1173       enddo          ! i
1174       do i=1,nct
1175         do j=1,3
1176           gvdwc(j,i)=expon*gvdwc(j,i)
1177           gvdwx(j,i)=expon*gvdwx(j,i)
1178         enddo
1179       enddo
1180 C******************************************************************************
1181 C
1182 C                              N O T E !!!
1183 C
1184 C To save time, the factor of EXPON has been extracted from ALL components
1185 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1186 C use!
1187 C
1188 C******************************************************************************
1189       return
1190       end
1191 C-----------------------------------------------------------------------------
1192       subroutine eljk(evdw)
1193 C
1194 C This subroutine calculates the interaction energy of nonbonded side chains
1195 C assuming the LJK potential of interaction.
1196 C
1197       implicit real*8 (a-h,o-z)
1198       include 'DIMENSIONS'
1199       include 'COMMON.GEO'
1200       include 'COMMON.VAR'
1201       include 'COMMON.LOCAL'
1202       include 'COMMON.CHAIN'
1203       include 'COMMON.DERIV'
1204       include 'COMMON.INTERACT'
1205       include 'COMMON.IOUNITS'
1206       include 'COMMON.NAMES'
1207       dimension gg(3)
1208       logical scheck
1209 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1210       evdw=0.0D0
1211       do i=iatsc_s,iatsc_e
1212         itypi=iabs(itype(i))
1213         if (itypi.eq.ntyp1) cycle
1214         itypi1=iabs(itype(i+1))
1215         xi=c(1,nres+i)
1216         yi=c(2,nres+i)
1217         zi=c(3,nres+i)
1218 C
1219 C Calculate SC interaction energy.
1220 C
1221         do iint=1,nint_gr(i)
1222           do j=istart(i,iint),iend(i,iint)
1223             itypj=iabs(itype(j))
1224             if (itypj.eq.ntyp1) cycle
1225             xj=c(1,nres+j)-xi
1226             yj=c(2,nres+j)-yi
1227             zj=c(3,nres+j)-zi
1228             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1229             fac_augm=rrij**expon
1230             e_augm=augm(itypi,itypj)*fac_augm
1231             r_inv_ij=dsqrt(rrij)
1232             rij=1.0D0/r_inv_ij
1233             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1234             fac=r_shift_inv**expon
1235             e1=fac*fac*aa(itypi,itypj)
1236             e2=fac*bb(itypi,itypj)
1237             evdwij=e_augm+e1+e2
1238 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1239 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1240 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1241 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1242 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1243 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1244 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1245             evdw=evdw+evdwij
1246 C
1247 C Calculate the components of the gradient in DC and X
1248 C
1249             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1250             gg(1)=xj*fac
1251             gg(2)=yj*fac
1252             gg(3)=zj*fac
1253             do k=1,3
1254               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1255               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1256               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1257               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1258             enddo
1259 cgrad            do k=i,j-1
1260 cgrad              do l=1,3
1261 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1262 cgrad              enddo
1263 cgrad            enddo
1264           enddo      ! j
1265         enddo        ! iint
1266       enddo          ! i
1267       do i=1,nct
1268         do j=1,3
1269           gvdwc(j,i)=expon*gvdwc(j,i)
1270           gvdwx(j,i)=expon*gvdwx(j,i)
1271         enddo
1272       enddo
1273       return
1274       end
1275 C-----------------------------------------------------------------------------
1276       subroutine ebp(evdw)
1277 C
1278 C This subroutine calculates the interaction energy of nonbonded side chains
1279 C assuming the Berne-Pechukas potential of interaction.
1280 C
1281       implicit real*8 (a-h,o-z)
1282       include 'DIMENSIONS'
1283       include 'COMMON.GEO'
1284       include 'COMMON.VAR'
1285       include 'COMMON.LOCAL'
1286       include 'COMMON.CHAIN'
1287       include 'COMMON.DERIV'
1288       include 'COMMON.NAMES'
1289       include 'COMMON.INTERACT'
1290       include 'COMMON.IOUNITS'
1291       include 'COMMON.CALC'
1292       common /srutu/ icall
1293 c     double precision rrsave(maxdim)
1294       logical lprn
1295       evdw=0.0D0
1296 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1297       evdw=0.0D0
1298 c     if (icall.eq.0) then
1299 c       lprn=.true.
1300 c     else
1301         lprn=.false.
1302 c     endif
1303       ind=0
1304       do i=iatsc_s,iatsc_e
1305         itypi=iabs(itype(i))
1306         if (itypi.eq.ntyp1) cycle
1307         itypi1=iabs(itype(i+1))
1308         xi=c(1,nres+i)
1309         yi=c(2,nres+i)
1310         zi=c(3,nres+i)
1311         dxi=dc_norm(1,nres+i)
1312         dyi=dc_norm(2,nres+i)
1313         dzi=dc_norm(3,nres+i)
1314 c        dsci_inv=dsc_inv(itypi)
1315         dsci_inv=vbld_inv(i+nres)
1316 C
1317 C Calculate SC interaction energy.
1318 C
1319         do iint=1,nint_gr(i)
1320           do j=istart(i,iint),iend(i,iint)
1321             ind=ind+1
1322             itypj=iabs(itype(j))
1323             if (itypj.eq.ntyp1) cycle
1324 c            dscj_inv=dsc_inv(itypj)
1325             dscj_inv=vbld_inv(j+nres)
1326             chi1=chi(itypi,itypj)
1327             chi2=chi(itypj,itypi)
1328             chi12=chi1*chi2
1329             chip1=chip(itypi)
1330             chip2=chip(itypj)
1331             chip12=chip1*chip2
1332             alf1=alp(itypi)
1333             alf2=alp(itypj)
1334             alf12=0.5D0*(alf1+alf2)
1335 C For diagnostics only!!!
1336 c           chi1=0.0D0
1337 c           chi2=0.0D0
1338 c           chi12=0.0D0
1339 c           chip1=0.0D0
1340 c           chip2=0.0D0
1341 c           chip12=0.0D0
1342 c           alf1=0.0D0
1343 c           alf2=0.0D0
1344 c           alf12=0.0D0
1345             xj=c(1,nres+j)-xi
1346             yj=c(2,nres+j)-yi
1347             zj=c(3,nres+j)-zi
1348             dxj=dc_norm(1,nres+j)
1349             dyj=dc_norm(2,nres+j)
1350             dzj=dc_norm(3,nres+j)
1351             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1352 cd          if (icall.eq.0) then
1353 cd            rrsave(ind)=rrij
1354 cd          else
1355 cd            rrij=rrsave(ind)
1356 cd          endif
1357             rij=dsqrt(rrij)
1358 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1359             call sc_angular
1360 C Calculate whole angle-dependent part of epsilon and contributions
1361 C to its derivatives
1362             fac=(rrij*sigsq)**expon2
1363             e1=fac*fac*aa(itypi,itypj)
1364             e2=fac*bb(itypi,itypj)
1365             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1366             eps2der=evdwij*eps3rt
1367             eps3der=evdwij*eps2rt
1368             evdwij=evdwij*eps2rt*eps3rt
1369             evdw=evdw+evdwij
1370             if (lprn) then
1371             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1372             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1373 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1374 cd     &        restyp(itypi),i,restyp(itypj),j,
1375 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1376 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1377 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1378 cd     &        evdwij
1379             endif
1380 C Calculate gradient components.
1381             e1=e1*eps1*eps2rt**2*eps3rt**2
1382             fac=-expon*(e1+evdwij)
1383             sigder=fac/sigsq
1384             fac=rrij*fac
1385 C Calculate radial part of the gradient
1386             gg(1)=xj*fac
1387             gg(2)=yj*fac
1388             gg(3)=zj*fac
1389 C Calculate the angular part of the gradient and sum add the contributions
1390 C to the appropriate components of the Cartesian gradient.
1391             call sc_grad
1392           enddo      ! j
1393         enddo        ! iint
1394       enddo          ! i
1395 c     stop
1396       return
1397       end
1398 C-----------------------------------------------------------------------------
1399       subroutine egb(evdw)
1400 C
1401 C This subroutine calculates the interaction energy of nonbonded side chains
1402 C assuming the Gay-Berne potential of interaction.
1403 C
1404       implicit real*8 (a-h,o-z)
1405       include 'DIMENSIONS'
1406       include 'COMMON.GEO'
1407       include 'COMMON.VAR'
1408       include 'COMMON.LOCAL'
1409       include 'COMMON.CHAIN'
1410       include 'COMMON.DERIV'
1411       include 'COMMON.NAMES'
1412       include 'COMMON.INTERACT'
1413       include 'COMMON.IOUNITS'
1414       include 'COMMON.CALC'
1415       include 'COMMON.CONTROL'
1416       include 'COMMON.SPLITELE'
1417       logical lprn
1418       integer xshift,yshift,zshift
1419       evdw=0.0D0
1420 ccccc      energy_dec=.false.
1421 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1422       evdw=0.0D0
1423       lprn=.false.
1424 c     if (icall.eq.0) lprn=.false.
1425       ind=0
1426 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1427 C we have the original box)
1428 C      do xshift=-1,1
1429 C      do yshift=-1,1
1430 C      do zshift=-1,1
1431       do i=iatsc_s,iatsc_e
1432         itypi=iabs(itype(i))
1433         if (itypi.eq.ntyp1) cycle
1434         itypi1=iabs(itype(i+1))
1435         xi=c(1,nres+i)
1436         yi=c(2,nres+i)
1437         zi=c(3,nres+i)
1438 C Return atom into box, boxxsize is size of box in x dimension
1439 c  134   continue
1440 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1441 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1442 C Condition for being inside the proper box
1443 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1444 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1445 c        go to 134
1446 c        endif
1447 c  135   continue
1448 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1449 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1450 C Condition for being inside the proper box
1451 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1452 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1453 c        go to 135
1454 c        endif
1455 c  136   continue
1456 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1457 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1458 C Condition for being inside the proper box
1459 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1460 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1461 c        go to 136
1462 c        endif
1463           xi=mod(xi,boxxsize)
1464           if (xi.lt.0) xi=xi+boxxsize
1465           yi=mod(yi,boxysize)
1466           if (yi.lt.0) yi=yi+boxysize
1467           zi=mod(zi,boxzsize)
1468           if (zi.lt.0) zi=zi+boxzsize
1469 C          xi=xi+xshift*boxxsize
1470 C          yi=yi+yshift*boxysize
1471 C          zi=zi+zshift*boxzsize
1472
1473         dxi=dc_norm(1,nres+i)
1474         dyi=dc_norm(2,nres+i)
1475         dzi=dc_norm(3,nres+i)
1476 c        dsci_inv=dsc_inv(itypi)
1477         dsci_inv=vbld_inv(i+nres)
1478 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1479 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1480 C
1481 C Calculate SC interaction energy.
1482 C
1483         do iint=1,nint_gr(i)
1484           do j=istart(i,iint),iend(i,iint)
1485             ind=ind+1
1486             itypj=iabs(itype(j))
1487             if (itypj.eq.ntyp1) cycle
1488 c            dscj_inv=dsc_inv(itypj)
1489             dscj_inv=vbld_inv(j+nres)
1490 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1491 c     &       1.0d0/vbld(j+nres)
1492 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1493             sig0ij=sigma(itypi,itypj)
1494             chi1=chi(itypi,itypj)
1495             chi2=chi(itypj,itypi)
1496             chi12=chi1*chi2
1497             chip1=chip(itypi)
1498             chip2=chip(itypj)
1499             chip12=chip1*chip2
1500             alf1=alp(itypi)
1501             alf2=alp(itypj)
1502             alf12=0.5D0*(alf1+alf2)
1503 C For diagnostics only!!!
1504 c           chi1=0.0D0
1505 c           chi2=0.0D0
1506 c           chi12=0.0D0
1507 c           chip1=0.0D0
1508 c           chip2=0.0D0
1509 c           chip12=0.0D0
1510 c           alf1=0.0D0
1511 c           alf2=0.0D0
1512 c           alf12=0.0D0
1513             xj=c(1,nres+j)
1514             yj=c(2,nres+j)
1515             zj=c(3,nres+j)
1516 C Return atom J into box the original box
1517 c  137   continue
1518 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1519 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1520 C Condition for being inside the proper box
1521 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1522 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1523 c        go to 137
1524 c        endif
1525 c  138   continue
1526 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1527 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1528 C Condition for being inside the proper box
1529 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1530 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1531 c        go to 138
1532 c        endif
1533 c  139   continue
1534 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1535 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1536 C Condition for being inside the proper box
1537 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1538 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1539 c        go to 139
1540 c        endif
1541           xj=mod(xj,boxxsize)
1542           if (xj.lt.0) xj=xj+boxxsize
1543           yj=mod(yj,boxysize)
1544           if (yj.lt.0) yj=yj+boxysize
1545           zj=mod(zj,boxzsize)
1546           if (zj.lt.0) zj=zj+boxzsize
1547       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1548       xj_safe=xj
1549       yj_safe=yj
1550       zj_safe=zj
1551       subchap=0
1552       do xshift=-1,1
1553       do yshift=-1,1
1554       do zshift=-1,1
1555           xj=xj_safe+xshift*boxxsize
1556           yj=yj_safe+yshift*boxysize
1557           zj=zj_safe+zshift*boxzsize
1558           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1559           if(dist_temp.lt.dist_init) then
1560             dist_init=dist_temp
1561             xj_temp=xj
1562             yj_temp=yj
1563             zj_temp=zj
1564             subchap=1
1565           endif
1566        enddo
1567        enddo
1568        enddo
1569        if (subchap.eq.1) then
1570           xj=xj_temp-xi
1571           yj=yj_temp-yi
1572           zj=zj_temp-zi
1573        else
1574           xj=xj_safe-xi
1575           yj=yj_safe-yi
1576           zj=zj_safe-zi
1577        endif
1578             dxj=dc_norm(1,nres+j)
1579             dyj=dc_norm(2,nres+j)
1580             dzj=dc_norm(3,nres+j)
1581 C            xj=xj-xi
1582 C            yj=yj-yi
1583 C            zj=zj-zi
1584 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1585 c            write (iout,*) "j",j," dc_norm",
1586 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1587             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1588             rij=dsqrt(rrij)
1589             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1590             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1591
1592 c            write (iout,'(a7,4f8.3)')
1593 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1594             if (sss.gt.0.0d0) then
1595 C Calculate angle-dependent terms of energy and contributions to their
1596 C derivatives.
1597             call sc_angular
1598             sigsq=1.0D0/sigsq
1599             sig=sig0ij*dsqrt(sigsq)
1600             rij_shift=1.0D0/rij-sig+sig0ij
1601 c for diagnostics; uncomment
1602 c            rij_shift=1.2*sig0ij
1603 C I hate to put IF's in the loops, but here don't have another choice!!!!
1604             if (rij_shift.le.0.0D0) then
1605               evdw=1.0D20
1606 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1607 cd     &        restyp(itypi),i,restyp(itypj),j,
1608 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1609               return
1610             endif
1611             sigder=-sig*sigsq
1612 c---------------------------------------------------------------
1613             rij_shift=1.0D0/rij_shift
1614             fac=rij_shift**expon
1615             e1=fac*fac*aa(itypi,itypj)
1616             e2=fac*bb(itypi,itypj)
1617             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1618             eps2der=evdwij*eps3rt
1619             eps3der=evdwij*eps2rt
1620 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1621 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1622             evdwij=evdwij*eps2rt*eps3rt
1623             evdw=evdw+evdwij*sss
1624             if (lprn) then
1625             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1626             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1627             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1628      &        restyp(itypi),i,restyp(itypj),j,
1629      &        epsi,sigm,chi1,chi2,chip1,chip2,
1630      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1631      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1632      &        evdwij
1633             endif
1634
1635             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1636      &                        'evdw',i,j,evdwij
1637
1638 C Calculate gradient components.
1639             e1=e1*eps1*eps2rt**2*eps3rt**2
1640             fac=-expon*(e1+evdwij)*rij_shift
1641             sigder=fac*sigder
1642             fac=rij*fac
1643 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1644 c     &      evdwij,fac,sigma(itypi,itypj),expon
1645             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1646 c            fac=0.0d0
1647 C Calculate the radial part of the gradient
1648             gg(1)=xj*fac
1649             gg(2)=yj*fac
1650             gg(3)=zj*fac
1651 C Calculate angular part of the gradient.
1652             call sc_grad
1653             endif
1654           enddo      ! j
1655         enddo        ! iint
1656       enddo          ! i
1657 C      enddo          ! zshift
1658 C      enddo          ! yshift
1659 C      enddo          ! xshift
1660 c      write (iout,*) "Number of loop steps in EGB:",ind
1661 cccc      energy_dec=.false.
1662       return
1663       end
1664 C-----------------------------------------------------------------------------
1665       subroutine egbv(evdw)
1666 C
1667 C This subroutine calculates the interaction energy of nonbonded side chains
1668 C assuming the Gay-Berne-Vorobjev potential of interaction.
1669 C
1670       implicit real*8 (a-h,o-z)
1671       include 'DIMENSIONS'
1672       include 'COMMON.GEO'
1673       include 'COMMON.VAR'
1674       include 'COMMON.LOCAL'
1675       include 'COMMON.CHAIN'
1676       include 'COMMON.DERIV'
1677       include 'COMMON.NAMES'
1678       include 'COMMON.INTERACT'
1679       include 'COMMON.IOUNITS'
1680       include 'COMMON.CALC'
1681       common /srutu/ icall
1682       logical lprn
1683       evdw=0.0D0
1684 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1685       evdw=0.0D0
1686       lprn=.false.
1687 c     if (icall.eq.0) lprn=.true.
1688       ind=0
1689       do i=iatsc_s,iatsc_e
1690         itypi=iabs(itype(i))
1691         if (itypi.eq.ntyp1) cycle
1692         itypi1=iabs(itype(i+1))
1693         xi=c(1,nres+i)
1694         yi=c(2,nres+i)
1695         zi=c(3,nres+i)
1696         dxi=dc_norm(1,nres+i)
1697         dyi=dc_norm(2,nres+i)
1698         dzi=dc_norm(3,nres+i)
1699 c        dsci_inv=dsc_inv(itypi)
1700         dsci_inv=vbld_inv(i+nres)
1701 C
1702 C Calculate SC interaction energy.
1703 C
1704         do iint=1,nint_gr(i)
1705           do j=istart(i,iint),iend(i,iint)
1706             ind=ind+1
1707             itypj=iabs(itype(j))
1708             if (itypj.eq.ntyp1) cycle
1709 c            dscj_inv=dsc_inv(itypj)
1710             dscj_inv=vbld_inv(j+nres)
1711             sig0ij=sigma(itypi,itypj)
1712             r0ij=r0(itypi,itypj)
1713             chi1=chi(itypi,itypj)
1714             chi2=chi(itypj,itypi)
1715             chi12=chi1*chi2
1716             chip1=chip(itypi)
1717             chip2=chip(itypj)
1718             chip12=chip1*chip2
1719             alf1=alp(itypi)
1720             alf2=alp(itypj)
1721             alf12=0.5D0*(alf1+alf2)
1722 C For diagnostics only!!!
1723 c           chi1=0.0D0
1724 c           chi2=0.0D0
1725 c           chi12=0.0D0
1726 c           chip1=0.0D0
1727 c           chip2=0.0D0
1728 c           chip12=0.0D0
1729 c           alf1=0.0D0
1730 c           alf2=0.0D0
1731 c           alf12=0.0D0
1732             xj=c(1,nres+j)-xi
1733             yj=c(2,nres+j)-yi
1734             zj=c(3,nres+j)-zi
1735             dxj=dc_norm(1,nres+j)
1736             dyj=dc_norm(2,nres+j)
1737             dzj=dc_norm(3,nres+j)
1738             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1739             rij=dsqrt(rrij)
1740 C Calculate angle-dependent terms of energy and contributions to their
1741 C derivatives.
1742             call sc_angular
1743             sigsq=1.0D0/sigsq
1744             sig=sig0ij*dsqrt(sigsq)
1745             rij_shift=1.0D0/rij-sig+r0ij
1746 C I hate to put IF's in the loops, but here don't have another choice!!!!
1747             if (rij_shift.le.0.0D0) then
1748               evdw=1.0D20
1749               return
1750             endif
1751             sigder=-sig*sigsq
1752 c---------------------------------------------------------------
1753             rij_shift=1.0D0/rij_shift
1754             fac=rij_shift**expon
1755             e1=fac*fac*aa(itypi,itypj)
1756             e2=fac*bb(itypi,itypj)
1757             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1758             eps2der=evdwij*eps3rt
1759             eps3der=evdwij*eps2rt
1760             fac_augm=rrij**expon
1761             e_augm=augm(itypi,itypj)*fac_augm
1762             evdwij=evdwij*eps2rt*eps3rt
1763             evdw=evdw+evdwij+e_augm
1764             if (lprn) then
1765             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1766             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1767             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1768      &        restyp(itypi),i,restyp(itypj),j,
1769      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1770      &        chi1,chi2,chip1,chip2,
1771      &        eps1,eps2rt**2,eps3rt**2,
1772      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1773      &        evdwij+e_augm
1774             endif
1775 C Calculate gradient components.
1776             e1=e1*eps1*eps2rt**2*eps3rt**2
1777             fac=-expon*(e1+evdwij)*rij_shift
1778             sigder=fac*sigder
1779             fac=rij*fac-2*expon*rrij*e_augm
1780 C Calculate the radial part of the gradient
1781             gg(1)=xj*fac
1782             gg(2)=yj*fac
1783             gg(3)=zj*fac
1784 C Calculate angular part of the gradient.
1785             call sc_grad
1786           enddo      ! j
1787         enddo        ! iint
1788       enddo          ! i
1789       end
1790 C-----------------------------------------------------------------------------
1791       subroutine sc_angular
1792 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1793 C om12. Called by ebp, egb, and egbv.
1794       implicit none
1795       include 'COMMON.CALC'
1796       include 'COMMON.IOUNITS'
1797       erij(1)=xj*rij
1798       erij(2)=yj*rij
1799       erij(3)=zj*rij
1800       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1801       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1802       om12=dxi*dxj+dyi*dyj+dzi*dzj
1803       chiom12=chi12*om12
1804 C Calculate eps1(om12) and its derivative in om12
1805       faceps1=1.0D0-om12*chiom12
1806       faceps1_inv=1.0D0/faceps1
1807       eps1=dsqrt(faceps1_inv)
1808 C Following variable is eps1*deps1/dom12
1809       eps1_om12=faceps1_inv*chiom12
1810 c diagnostics only
1811 c      faceps1_inv=om12
1812 c      eps1=om12
1813 c      eps1_om12=1.0d0
1814 c      write (iout,*) "om12",om12," eps1",eps1
1815 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1816 C and om12.
1817       om1om2=om1*om2
1818       chiom1=chi1*om1
1819       chiom2=chi2*om2
1820       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1821       sigsq=1.0D0-facsig*faceps1_inv
1822       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1823       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1824       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1825 c diagnostics only
1826 c      sigsq=1.0d0
1827 c      sigsq_om1=0.0d0
1828 c      sigsq_om2=0.0d0
1829 c      sigsq_om12=0.0d0
1830 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1831 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1832 c     &    " eps1",eps1
1833 C Calculate eps2 and its derivatives in om1, om2, and om12.
1834       chipom1=chip1*om1
1835       chipom2=chip2*om2
1836       chipom12=chip12*om12
1837       facp=1.0D0-om12*chipom12
1838       facp_inv=1.0D0/facp
1839       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1840 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1841 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1842 C Following variable is the square root of eps2
1843       eps2rt=1.0D0-facp1*facp_inv
1844 C Following three variables are the derivatives of the square root of eps
1845 C in om1, om2, and om12.
1846       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1847       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1848       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1849 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1850       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1851 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1852 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1853 c     &  " eps2rt_om12",eps2rt_om12
1854 C Calculate whole angle-dependent part of epsilon and contributions
1855 C to its derivatives
1856       return
1857       end
1858 C----------------------------------------------------------------------------
1859       subroutine sc_grad
1860       implicit real*8 (a-h,o-z)
1861       include 'DIMENSIONS'
1862       include 'COMMON.CHAIN'
1863       include 'COMMON.DERIV'
1864       include 'COMMON.CALC'
1865       include 'COMMON.IOUNITS'
1866       double precision dcosom1(3),dcosom2(3)
1867 cc      print *,'sss=',sss
1868       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1869       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1870       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1871      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1872 c diagnostics only
1873 c      eom1=0.0d0
1874 c      eom2=0.0d0
1875 c      eom12=evdwij*eps1_om12
1876 c end diagnostics
1877 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1878 c     &  " sigder",sigder
1879 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1880 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1881       do k=1,3
1882         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1883         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1884       enddo
1885       do k=1,3
1886         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1887       enddo
1888 c      write (iout,*) "gg",(gg(k),k=1,3)
1889       do k=1,3
1890         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1891      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1892      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1893         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1894      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1895      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1896 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1897 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1898 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1899 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1900       enddo
1901 C
1902 C Calculate the components of the gradient in DC and X
1903 C
1904 cgrad      do k=i,j-1
1905 cgrad        do l=1,3
1906 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1907 cgrad        enddo
1908 cgrad      enddo
1909       do l=1,3
1910         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1911         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1912       enddo
1913       return
1914       end
1915 C-----------------------------------------------------------------------
1916       subroutine e_softsphere(evdw)
1917 C
1918 C This subroutine calculates the interaction energy of nonbonded side chains
1919 C assuming the LJ potential of interaction.
1920 C
1921       implicit real*8 (a-h,o-z)
1922       include 'DIMENSIONS'
1923       parameter (accur=1.0d-10)
1924       include 'COMMON.GEO'
1925       include 'COMMON.VAR'
1926       include 'COMMON.LOCAL'
1927       include 'COMMON.CHAIN'
1928       include 'COMMON.DERIV'
1929       include 'COMMON.INTERACT'
1930       include 'COMMON.TORSION'
1931       include 'COMMON.SBRIDGE'
1932       include 'COMMON.NAMES'
1933       include 'COMMON.IOUNITS'
1934       include 'COMMON.CONTACTS'
1935       dimension gg(3)
1936 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1937       evdw=0.0D0
1938       do i=iatsc_s,iatsc_e
1939         itypi=iabs(itype(i))
1940         if (itypi.eq.ntyp1) cycle
1941         itypi1=iabs(itype(i+1))
1942         xi=c(1,nres+i)
1943         yi=c(2,nres+i)
1944         zi=c(3,nres+i)
1945 C
1946 C Calculate SC interaction energy.
1947 C
1948         do iint=1,nint_gr(i)
1949 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1950 cd   &                  'iend=',iend(i,iint)
1951           do j=istart(i,iint),iend(i,iint)
1952             itypj=iabs(itype(j))
1953             if (itypj.eq.ntyp1) cycle
1954             xj=c(1,nres+j)-xi
1955             yj=c(2,nres+j)-yi
1956             zj=c(3,nres+j)-zi
1957             rij=xj*xj+yj*yj+zj*zj
1958 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1959             r0ij=r0(itypi,itypj)
1960             r0ijsq=r0ij*r0ij
1961 c            print *,i,j,r0ij,dsqrt(rij)
1962             if (rij.lt.r0ijsq) then
1963               evdwij=0.25d0*(rij-r0ijsq)**2
1964               fac=rij-r0ijsq
1965             else
1966               evdwij=0.0d0
1967               fac=0.0d0
1968             endif
1969             evdw=evdw+evdwij
1970 C
1971 C Calculate the components of the gradient in DC and X
1972 C
1973             gg(1)=xj*fac
1974             gg(2)=yj*fac
1975             gg(3)=zj*fac
1976             do k=1,3
1977               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1978               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1979               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1980               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1981             enddo
1982 cgrad            do k=i,j-1
1983 cgrad              do l=1,3
1984 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1985 cgrad              enddo
1986 cgrad            enddo
1987           enddo ! j
1988         enddo ! iint
1989       enddo ! i
1990       return
1991       end
1992 C--------------------------------------------------------------------------
1993       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1994      &              eello_turn4)
1995 C
1996 C Soft-sphere potential of p-p interaction
1997 C
1998       implicit real*8 (a-h,o-z)
1999       include 'DIMENSIONS'
2000       include 'COMMON.CONTROL'
2001       include 'COMMON.IOUNITS'
2002       include 'COMMON.GEO'
2003       include 'COMMON.VAR'
2004       include 'COMMON.LOCAL'
2005       include 'COMMON.CHAIN'
2006       include 'COMMON.DERIV'
2007       include 'COMMON.INTERACT'
2008       include 'COMMON.CONTACTS'
2009       include 'COMMON.TORSION'
2010       include 'COMMON.VECTORS'
2011       include 'COMMON.FFIELD'
2012       dimension ggg(3)
2013 cd      write(iout,*) 'In EELEC_soft_sphere'
2014       ees=0.0D0
2015       evdw1=0.0D0
2016       eel_loc=0.0d0
2017       eello_turn3=0.0d0
2018       eello_turn4=0.0d0
2019       ind=0
2020       do i=iatel_s,iatel_e
2021         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2022         dxi=dc(1,i)
2023         dyi=dc(2,i)
2024         dzi=dc(3,i)
2025         xmedi=c(1,i)+0.5d0*dxi
2026         ymedi=c(2,i)+0.5d0*dyi
2027         zmedi=c(3,i)+0.5d0*dzi
2028         num_conti=0
2029 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2030         do j=ielstart(i),ielend(i)
2031           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2032           ind=ind+1
2033           iteli=itel(i)
2034           itelj=itel(j)
2035           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2036           r0ij=rpp(iteli,itelj)
2037           r0ijsq=r0ij*r0ij
2038           dxj=dc(1,j)
2039           dyj=dc(2,j)
2040           dzj=dc(3,j)
2041           xj=c(1,j)+0.5D0*dxj-xmedi
2042           yj=c(2,j)+0.5D0*dyj-ymedi
2043           zj=c(3,j)+0.5D0*dzj-zmedi
2044           rij=xj*xj+yj*yj+zj*zj
2045           if (rij.lt.r0ijsq) then
2046             evdw1ij=0.25d0*(rij-r0ijsq)**2
2047             fac=rij-r0ijsq
2048           else
2049             evdw1ij=0.0d0
2050             fac=0.0d0
2051           endif
2052           evdw1=evdw1+evdw1ij
2053 C
2054 C Calculate contributions to the Cartesian gradient.
2055 C
2056           ggg(1)=fac*xj
2057           ggg(2)=fac*yj
2058           ggg(3)=fac*zj
2059           do k=1,3
2060             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2061             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2062           enddo
2063 *
2064 * Loop over residues i+1 thru j-1.
2065 *
2066 cgrad          do k=i+1,j-1
2067 cgrad            do l=1,3
2068 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2069 cgrad            enddo
2070 cgrad          enddo
2071         enddo ! j
2072       enddo   ! i
2073 cgrad      do i=nnt,nct-1
2074 cgrad        do k=1,3
2075 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2076 cgrad        enddo
2077 cgrad        do j=i+1,nct-1
2078 cgrad          do k=1,3
2079 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2080 cgrad          enddo
2081 cgrad        enddo
2082 cgrad      enddo
2083       return
2084       end
2085 c------------------------------------------------------------------------------
2086       subroutine vec_and_deriv
2087       implicit real*8 (a-h,o-z)
2088       include 'DIMENSIONS'
2089 #ifdef MPI
2090       include 'mpif.h'
2091 #endif
2092       include 'COMMON.IOUNITS'
2093       include 'COMMON.GEO'
2094       include 'COMMON.VAR'
2095       include 'COMMON.LOCAL'
2096       include 'COMMON.CHAIN'
2097       include 'COMMON.VECTORS'
2098       include 'COMMON.SETUP'
2099       include 'COMMON.TIME1'
2100       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2101 C Compute the local reference systems. For reference system (i), the
2102 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2103 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2104 #ifdef PARVEC
2105       do i=ivec_start,ivec_end
2106 #else
2107       do i=1,nres-1
2108 #endif
2109           if (i.eq.nres-1) then
2110 C Case of the last full residue
2111 C Compute the Z-axis
2112             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2113             costh=dcos(pi-theta(nres))
2114             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2115             do k=1,3
2116               uz(k,i)=fac*uz(k,i)
2117             enddo
2118 C Compute the derivatives of uz
2119             uzder(1,1,1)= 0.0d0
2120             uzder(2,1,1)=-dc_norm(3,i-1)
2121             uzder(3,1,1)= dc_norm(2,i-1)
2122             uzder(1,2,1)= dc_norm(3,i-1)
2123             uzder(2,2,1)= 0.0d0
2124             uzder(3,2,1)=-dc_norm(1,i-1)
2125             uzder(1,3,1)=-dc_norm(2,i-1)
2126             uzder(2,3,1)= dc_norm(1,i-1)
2127             uzder(3,3,1)= 0.0d0
2128             uzder(1,1,2)= 0.0d0
2129             uzder(2,1,2)= dc_norm(3,i)
2130             uzder(3,1,2)=-dc_norm(2,i)
2131             uzder(1,2,2)=-dc_norm(3,i)
2132             uzder(2,2,2)= 0.0d0
2133             uzder(3,2,2)= dc_norm(1,i)
2134             uzder(1,3,2)= dc_norm(2,i)
2135             uzder(2,3,2)=-dc_norm(1,i)
2136             uzder(3,3,2)= 0.0d0
2137 C Compute the Y-axis
2138             facy=fac
2139             do k=1,3
2140               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2141             enddo
2142 C Compute the derivatives of uy
2143             do j=1,3
2144               do k=1,3
2145                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2146      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2147                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2148               enddo
2149               uyder(j,j,1)=uyder(j,j,1)-costh
2150               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2151             enddo
2152             do j=1,2
2153               do k=1,3
2154                 do l=1,3
2155                   uygrad(l,k,j,i)=uyder(l,k,j)
2156                   uzgrad(l,k,j,i)=uzder(l,k,j)
2157                 enddo
2158               enddo
2159             enddo
2160             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2161             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2162             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2163             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2164           else
2165 C Other residues
2166 C Compute the Z-axis
2167             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2168             costh=dcos(pi-theta(i+2))
2169             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2170             do k=1,3
2171               uz(k,i)=fac*uz(k,i)
2172             enddo
2173 C Compute the derivatives of uz
2174             uzder(1,1,1)= 0.0d0
2175             uzder(2,1,1)=-dc_norm(3,i+1)
2176             uzder(3,1,1)= dc_norm(2,i+1)
2177             uzder(1,2,1)= dc_norm(3,i+1)
2178             uzder(2,2,1)= 0.0d0
2179             uzder(3,2,1)=-dc_norm(1,i+1)
2180             uzder(1,3,1)=-dc_norm(2,i+1)
2181             uzder(2,3,1)= dc_norm(1,i+1)
2182             uzder(3,3,1)= 0.0d0
2183             uzder(1,1,2)= 0.0d0
2184             uzder(2,1,2)= dc_norm(3,i)
2185             uzder(3,1,2)=-dc_norm(2,i)
2186             uzder(1,2,2)=-dc_norm(3,i)
2187             uzder(2,2,2)= 0.0d0
2188             uzder(3,2,2)= dc_norm(1,i)
2189             uzder(1,3,2)= dc_norm(2,i)
2190             uzder(2,3,2)=-dc_norm(1,i)
2191             uzder(3,3,2)= 0.0d0
2192 C Compute the Y-axis
2193             facy=fac
2194             do k=1,3
2195               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2196             enddo
2197 C Compute the derivatives of uy
2198             do j=1,3
2199               do k=1,3
2200                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2201      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2202                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2203               enddo
2204               uyder(j,j,1)=uyder(j,j,1)-costh
2205               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2206             enddo
2207             do j=1,2
2208               do k=1,3
2209                 do l=1,3
2210                   uygrad(l,k,j,i)=uyder(l,k,j)
2211                   uzgrad(l,k,j,i)=uzder(l,k,j)
2212                 enddo
2213               enddo
2214             enddo
2215             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2216             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2217             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2218             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2219           endif
2220       enddo
2221       do i=1,nres-1
2222         vbld_inv_temp(1)=vbld_inv(i+1)
2223         if (i.lt.nres-1) then
2224           vbld_inv_temp(2)=vbld_inv(i+2)
2225           else
2226           vbld_inv_temp(2)=vbld_inv(i)
2227           endif
2228         do j=1,2
2229           do k=1,3
2230             do l=1,3
2231               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2232               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2233             enddo
2234           enddo
2235         enddo
2236       enddo
2237 #if defined(PARVEC) && defined(MPI)
2238       if (nfgtasks1.gt.1) then
2239         time00=MPI_Wtime()
2240 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2241 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2242 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2243         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2244      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2245      &   FG_COMM1,IERR)
2246         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2247      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2248      &   FG_COMM1,IERR)
2249         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2250      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2251      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2252         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2253      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2254      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2255         time_gather=time_gather+MPI_Wtime()-time00
2256       endif
2257 c      if (fg_rank.eq.0) then
2258 c        write (iout,*) "Arrays UY and UZ"
2259 c        do i=1,nres-1
2260 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2261 c     &     (uz(k,i),k=1,3)
2262 c        enddo
2263 c      endif
2264 #endif
2265       return
2266       end
2267 C-----------------------------------------------------------------------------
2268       subroutine check_vecgrad
2269       implicit real*8 (a-h,o-z)
2270       include 'DIMENSIONS'
2271       include 'COMMON.IOUNITS'
2272       include 'COMMON.GEO'
2273       include 'COMMON.VAR'
2274       include 'COMMON.LOCAL'
2275       include 'COMMON.CHAIN'
2276       include 'COMMON.VECTORS'
2277       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2278       dimension uyt(3,maxres),uzt(3,maxres)
2279       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2280       double precision delta /1.0d-7/
2281       call vec_and_deriv
2282 cd      do i=1,nres
2283 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2284 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2285 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2286 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2287 cd     &     (dc_norm(if90,i),if90=1,3)
2288 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2289 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2290 cd          write(iout,'(a)')
2291 cd      enddo
2292       do i=1,nres
2293         do j=1,2
2294           do k=1,3
2295             do l=1,3
2296               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2297               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2298             enddo
2299           enddo
2300         enddo
2301       enddo
2302       call vec_and_deriv
2303       do i=1,nres
2304         do j=1,3
2305           uyt(j,i)=uy(j,i)
2306           uzt(j,i)=uz(j,i)
2307         enddo
2308       enddo
2309       do i=1,nres
2310 cd        write (iout,*) 'i=',i
2311         do k=1,3
2312           erij(k)=dc_norm(k,i)
2313         enddo
2314         do j=1,3
2315           do k=1,3
2316             dc_norm(k,i)=erij(k)
2317           enddo
2318           dc_norm(j,i)=dc_norm(j,i)+delta
2319 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2320 c          do k=1,3
2321 c            dc_norm(k,i)=dc_norm(k,i)/fac
2322 c          enddo
2323 c          write (iout,*) (dc_norm(k,i),k=1,3)
2324 c          write (iout,*) (erij(k),k=1,3)
2325           call vec_and_deriv
2326           do k=1,3
2327             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2328             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2329             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2330             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2331           enddo
2332 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2333 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2334 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2335         enddo
2336         do k=1,3
2337           dc_norm(k,i)=erij(k)
2338         enddo
2339 cd        do k=1,3
2340 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2341 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2342 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2343 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2344 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2345 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2346 cd          write (iout,'(a)')
2347 cd        enddo
2348       enddo
2349       return
2350       end
2351 C--------------------------------------------------------------------------
2352       subroutine set_matrices
2353       implicit real*8 (a-h,o-z)
2354       include 'DIMENSIONS'
2355 #ifdef MPI
2356       include "mpif.h"
2357       include "COMMON.SETUP"
2358       integer IERR
2359       integer status(MPI_STATUS_SIZE)
2360 #endif
2361       include 'COMMON.IOUNITS'
2362       include 'COMMON.GEO'
2363       include 'COMMON.VAR'
2364       include 'COMMON.LOCAL'
2365       include 'COMMON.CHAIN'
2366       include 'COMMON.DERIV'
2367       include 'COMMON.INTERACT'
2368       include 'COMMON.CONTACTS'
2369       include 'COMMON.TORSION'
2370       include 'COMMON.VECTORS'
2371       include 'COMMON.FFIELD'
2372       double precision auxvec(2),auxmat(2,2)
2373 C
2374 C Compute the virtual-bond-torsional-angle dependent quantities needed
2375 C to calculate the el-loc multibody terms of various order.
2376 C
2377 #ifdef PARMAT
2378       do i=ivec_start+2,ivec_end+2
2379 #else
2380       do i=3,nres+1
2381 #endif
2382         if (i .lt. nres+1) then
2383           sin1=dsin(phi(i))
2384           cos1=dcos(phi(i))
2385           sintab(i-2)=sin1
2386           costab(i-2)=cos1
2387           obrot(1,i-2)=cos1
2388           obrot(2,i-2)=sin1
2389           sin2=dsin(2*phi(i))
2390           cos2=dcos(2*phi(i))
2391           sintab2(i-2)=sin2
2392           costab2(i-2)=cos2
2393           obrot2(1,i-2)=cos2
2394           obrot2(2,i-2)=sin2
2395           Ug(1,1,i-2)=-cos1
2396           Ug(1,2,i-2)=-sin1
2397           Ug(2,1,i-2)=-sin1
2398           Ug(2,2,i-2)= cos1
2399           Ug2(1,1,i-2)=-cos2
2400           Ug2(1,2,i-2)=-sin2
2401           Ug2(2,1,i-2)=-sin2
2402           Ug2(2,2,i-2)= cos2
2403         else
2404           costab(i-2)=1.0d0
2405           sintab(i-2)=0.0d0
2406           obrot(1,i-2)=1.0d0
2407           obrot(2,i-2)=0.0d0
2408           obrot2(1,i-2)=0.0d0
2409           obrot2(2,i-2)=0.0d0
2410           Ug(1,1,i-2)=1.0d0
2411           Ug(1,2,i-2)=0.0d0
2412           Ug(2,1,i-2)=0.0d0
2413           Ug(2,2,i-2)=1.0d0
2414           Ug2(1,1,i-2)=0.0d0
2415           Ug2(1,2,i-2)=0.0d0
2416           Ug2(2,1,i-2)=0.0d0
2417           Ug2(2,2,i-2)=0.0d0
2418         endif
2419         if (i .gt. 3 .and. i .lt. nres+1) then
2420           obrot_der(1,i-2)=-sin1
2421           obrot_der(2,i-2)= cos1
2422           Ugder(1,1,i-2)= sin1
2423           Ugder(1,2,i-2)=-cos1
2424           Ugder(2,1,i-2)=-cos1
2425           Ugder(2,2,i-2)=-sin1
2426           dwacos2=cos2+cos2
2427           dwasin2=sin2+sin2
2428           obrot2_der(1,i-2)=-dwasin2
2429           obrot2_der(2,i-2)= dwacos2
2430           Ug2der(1,1,i-2)= dwasin2
2431           Ug2der(1,2,i-2)=-dwacos2
2432           Ug2der(2,1,i-2)=-dwacos2
2433           Ug2der(2,2,i-2)=-dwasin2
2434         else
2435           obrot_der(1,i-2)=0.0d0
2436           obrot_der(2,i-2)=0.0d0
2437           Ugder(1,1,i-2)=0.0d0
2438           Ugder(1,2,i-2)=0.0d0
2439           Ugder(2,1,i-2)=0.0d0
2440           Ugder(2,2,i-2)=0.0d0
2441           obrot2_der(1,i-2)=0.0d0
2442           obrot2_der(2,i-2)=0.0d0
2443           Ug2der(1,1,i-2)=0.0d0
2444           Ug2der(1,2,i-2)=0.0d0
2445           Ug2der(2,1,i-2)=0.0d0
2446           Ug2der(2,2,i-2)=0.0d0
2447         endif
2448 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2449         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2450           iti = itortyp(itype(i-2))
2451         else
2452           iti=ntortyp
2453         endif
2454 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2455         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2456           iti1 = itortyp(itype(i-1))
2457         else
2458           iti1=ntortyp
2459         endif
2460 cd        write (iout,*) '*******i',i,' iti1',iti
2461 cd        write (iout,*) 'b1',b1(:,iti)
2462 cd        write (iout,*) 'b2',b2(:,iti)
2463 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2464 c        if (i .gt. iatel_s+2) then
2465         if (i .gt. nnt+2) then
2466           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2467           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2468           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2469      &    then
2470           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2471           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2472           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2473           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2474           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2475           endif
2476         else
2477           do k=1,2
2478             Ub2(k,i-2)=0.0d0
2479             Ctobr(k,i-2)=0.0d0
2480             Dtobr2(k,i-2)=0.0d0
2481             do l=1,2
2482               EUg(l,k,i-2)=0.0d0
2483               CUg(l,k,i-2)=0.0d0
2484               DUg(l,k,i-2)=0.0d0
2485               DtUg2(l,k,i-2)=0.0d0
2486             enddo
2487           enddo
2488         endif
2489         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2490         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2491         do k=1,2
2492           muder(k,i-2)=Ub2der(k,i-2)
2493         enddo
2494 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2495         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2496           if (itype(i-1).le.ntyp) then
2497             iti1 = itortyp(itype(i-1))
2498           else
2499             iti1=ntortyp
2500           endif
2501         else
2502           iti1=ntortyp
2503         endif
2504         do k=1,2
2505           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2506         enddo
2507 cd        write (iout,*) 'mu ',mu(:,i-2)
2508 cd        write (iout,*) 'mu1',mu1(:,i-2)
2509 cd        write (iout,*) 'mu2',mu2(:,i-2)
2510         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2511      &  then
2512         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2513         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2514         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2515         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2516         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2517 C Vectors and matrices dependent on a single virtual-bond dihedral.
2518         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2519         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2520         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2521         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2522         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2523         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2524         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2525         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2526         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2527         endif
2528       enddo
2529 C Matrices dependent on two consecutive virtual-bond dihedrals.
2530 C The order of matrices is from left to right.
2531       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2532      &then
2533 c      do i=max0(ivec_start,2),ivec_end
2534       do i=2,nres-1
2535         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2536         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2537         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2538         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2539         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2540         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2541         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2542         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2543       enddo
2544       endif
2545 #if defined(MPI) && defined(PARMAT)
2546 #ifdef DEBUG
2547 c      if (fg_rank.eq.0) then
2548         write (iout,*) "Arrays UG and UGDER before GATHER"
2549         do i=1,nres-1
2550           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2551      &     ((ug(l,k,i),l=1,2),k=1,2),
2552      &     ((ugder(l,k,i),l=1,2),k=1,2)
2553         enddo
2554         write (iout,*) "Arrays UG2 and UG2DER"
2555         do i=1,nres-1
2556           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2557      &     ((ug2(l,k,i),l=1,2),k=1,2),
2558      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2559         enddo
2560         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2561         do i=1,nres-1
2562           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2563      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2564      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2565         enddo
2566         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2567         do i=1,nres-1
2568           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2569      &     costab(i),sintab(i),costab2(i),sintab2(i)
2570         enddo
2571         write (iout,*) "Array MUDER"
2572         do i=1,nres-1
2573           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2574         enddo
2575 c      endif
2576 #endif
2577       if (nfgtasks.gt.1) then
2578         time00=MPI_Wtime()
2579 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2580 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2581 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2582 #ifdef MATGATHER
2583         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2593      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2594      &   FG_COMM1,IERR)
2595         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2596      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2597      &   FG_COMM1,IERR)
2598         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2599      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2602      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2603      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2604         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2605      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2606      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2607         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2608      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2609      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2610         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2611      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2612      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2613         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2614      &  then
2615         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2622      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2623      &   FG_COMM1,IERR)
2624        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2625      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2626      &   FG_COMM1,IERR)
2627         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2628      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2629      &   FG_COMM1,IERR)
2630         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2631      &   ivec_count(fg_rank1),
2632      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2641      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2642      &   FG_COMM1,IERR)
2643         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2644      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2645      &   FG_COMM1,IERR)
2646         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2653      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2654      &   FG_COMM1,IERR)
2655         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2656      &   ivec_count(fg_rank1),
2657      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2658      &   FG_COMM1,IERR)
2659         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2660      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2661      &   FG_COMM1,IERR)
2662        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2663      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2664      &   FG_COMM1,IERR)
2665         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2666      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2667      &   FG_COMM1,IERR)
2668        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2669      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2670      &   FG_COMM1,IERR)
2671         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2672      &   ivec_count(fg_rank1),
2673      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2674      &   FG_COMM1,IERR)
2675         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2676      &   ivec_count(fg_rank1),
2677      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2678      &   FG_COMM1,IERR)
2679         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2680      &   ivec_count(fg_rank1),
2681      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2682      &   MPI_MAT2,FG_COMM1,IERR)
2683         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2684      &   ivec_count(fg_rank1),
2685      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2686      &   MPI_MAT2,FG_COMM1,IERR)
2687         endif
2688 #else
2689 c Passes matrix info through the ring
2690       isend=fg_rank1
2691       irecv=fg_rank1-1
2692       if (irecv.lt.0) irecv=nfgtasks1-1
2693       iprev=irecv
2694       inext=fg_rank1+1
2695       if (inext.ge.nfgtasks1) inext=0
2696       do i=1,nfgtasks1-1
2697 c        write (iout,*) "isend",isend," irecv",irecv
2698 c        call flush(iout)
2699         lensend=lentyp(isend)
2700         lenrecv=lentyp(irecv)
2701 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2702 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2703 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2704 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2705 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2706 c        write (iout,*) "Gather ROTAT1"
2707 c        call flush(iout)
2708 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2709 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2710 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2711 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2712 c        write (iout,*) "Gather ROTAT2"
2713 c        call flush(iout)
2714         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2715      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2716      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2717      &   iprev,4400+irecv,FG_COMM,status,IERR)
2718 c        write (iout,*) "Gather ROTAT_OLD"
2719 c        call flush(iout)
2720         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2721      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2722      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2723      &   iprev,5500+irecv,FG_COMM,status,IERR)
2724 c        write (iout,*) "Gather PRECOMP11"
2725 c        call flush(iout)
2726         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2727      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2728      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2729      &   iprev,6600+irecv,FG_COMM,status,IERR)
2730 c        write (iout,*) "Gather PRECOMP12"
2731 c        call flush(iout)
2732         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2733      &  then
2734         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2735      &   MPI_ROTAT2(lensend),inext,7700+isend,
2736      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2737      &   iprev,7700+irecv,FG_COMM,status,IERR)
2738 c        write (iout,*) "Gather PRECOMP21"
2739 c        call flush(iout)
2740         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2741      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2742      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2743      &   iprev,8800+irecv,FG_COMM,status,IERR)
2744 c        write (iout,*) "Gather PRECOMP22"
2745 c        call flush(iout)
2746         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2747      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2748      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2749      &   MPI_PRECOMP23(lenrecv),
2750      &   iprev,9900+irecv,FG_COMM,status,IERR)
2751 c        write (iout,*) "Gather PRECOMP23"
2752 c        call flush(iout)
2753         endif
2754         isend=irecv
2755         irecv=irecv-1
2756         if (irecv.lt.0) irecv=nfgtasks1-1
2757       enddo
2758 #endif
2759         time_gather=time_gather+MPI_Wtime()-time00
2760       endif
2761 #ifdef DEBUG
2762 c      if (fg_rank.eq.0) then
2763         write (iout,*) "Arrays UG and UGDER"
2764         do i=1,nres-1
2765           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2766      &     ((ug(l,k,i),l=1,2),k=1,2),
2767      &     ((ugder(l,k,i),l=1,2),k=1,2)
2768         enddo
2769         write (iout,*) "Arrays UG2 and UG2DER"
2770         do i=1,nres-1
2771           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2772      &     ((ug2(l,k,i),l=1,2),k=1,2),
2773      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2774         enddo
2775         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2776         do i=1,nres-1
2777           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2778      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2779      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2780         enddo
2781         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2782         do i=1,nres-1
2783           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2784      &     costab(i),sintab(i),costab2(i),sintab2(i)
2785         enddo
2786         write (iout,*) "Array MUDER"
2787         do i=1,nres-1
2788           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2789         enddo
2790 c      endif
2791 #endif
2792 #endif
2793 cd      do i=1,nres
2794 cd        iti = itortyp(itype(i))
2795 cd        write (iout,*) i
2796 cd        do j=1,2
2797 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2798 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2799 cd        enddo
2800 cd      enddo
2801       return
2802       end
2803 C--------------------------------------------------------------------------
2804       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2805 C
2806 C This subroutine calculates the average interaction energy and its gradient
2807 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2808 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2809 C The potential depends both on the distance of peptide-group centers and on
2810 C the orientation of the CA-CA virtual bonds.
2811 C
2812       implicit real*8 (a-h,o-z)
2813 #ifdef MPI
2814       include 'mpif.h'
2815 #endif
2816       include 'DIMENSIONS'
2817       include 'COMMON.CONTROL'
2818       include 'COMMON.SETUP'
2819       include 'COMMON.IOUNITS'
2820       include 'COMMON.GEO'
2821       include 'COMMON.VAR'
2822       include 'COMMON.LOCAL'
2823       include 'COMMON.CHAIN'
2824       include 'COMMON.DERIV'
2825       include 'COMMON.INTERACT'
2826       include 'COMMON.CONTACTS'
2827       include 'COMMON.TORSION'
2828       include 'COMMON.VECTORS'
2829       include 'COMMON.FFIELD'
2830       include 'COMMON.TIME1'
2831       include 'COMMON.SPLITELE'
2832       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2833      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2834       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2835      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2836       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2837      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2838      &    num_conti,j1,j2
2839 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2840 #ifdef MOMENT
2841       double precision scal_el /1.0d0/
2842 #else
2843       double precision scal_el /0.5d0/
2844 #endif
2845 C 12/13/98
2846 C 13-go grudnia roku pamietnego...
2847       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2848      &                   0.0d0,1.0d0,0.0d0,
2849      &                   0.0d0,0.0d0,1.0d0/
2850 cd      write(iout,*) 'In EELEC'
2851 cd      do i=1,nloctyp
2852 cd        write(iout,*) 'Type',i
2853 cd        write(iout,*) 'B1',B1(:,i)
2854 cd        write(iout,*) 'B2',B2(:,i)
2855 cd        write(iout,*) 'CC',CC(:,:,i)
2856 cd        write(iout,*) 'DD',DD(:,:,i)
2857 cd        write(iout,*) 'EE',EE(:,:,i)
2858 cd      enddo
2859 cd      call check_vecgrad
2860 cd      stop
2861       if (icheckgrad.eq.1) then
2862         do i=1,nres-1
2863           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2864           do k=1,3
2865             dc_norm(k,i)=dc(k,i)*fac
2866           enddo
2867 c          write (iout,*) 'i',i,' fac',fac
2868         enddo
2869       endif
2870       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2871      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2872      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2873 c        call vec_and_deriv
2874 #ifdef TIMING
2875         time01=MPI_Wtime()
2876 #endif
2877         call set_matrices
2878 #ifdef TIMING
2879         time_mat=time_mat+MPI_Wtime()-time01
2880 #endif
2881       endif
2882 cd      do i=1,nres-1
2883 cd        write (iout,*) 'i=',i
2884 cd        do k=1,3
2885 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2886 cd        enddo
2887 cd        do k=1,3
2888 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2889 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2890 cd        enddo
2891 cd      enddo
2892       t_eelecij=0.0d0
2893       ees=0.0D0
2894       evdw1=0.0D0
2895       eel_loc=0.0d0
2896       eello_turn3=0.0d0
2897       eello_turn4=0.0d0
2898       ind=0
2899       do i=1,nres
2900         num_cont_hb(i)=0
2901       enddo
2902 cd      print '(a)','Enter EELEC'
2903 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2904       do i=1,nres
2905         gel_loc_loc(i)=0.0d0
2906         gcorr_loc(i)=0.0d0
2907       enddo
2908 c
2909 c
2910 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2911 C
2912 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2913 C
2914 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2915       do i=iturn3_start,iturn3_end
2916         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2917      &  .or. itype(i+2).eq.ntyp1
2918      &  .or. itype(i+3).eq.ntyp1
2919      &  .or. itype(i-1).eq.ntyp1
2920      &  .or. itype(i+4).eq.ntyp1
2921      &  ) cycle
2922         dxi=dc(1,i)
2923         dyi=dc(2,i)
2924         dzi=dc(3,i)
2925         dx_normi=dc_norm(1,i)
2926         dy_normi=dc_norm(2,i)
2927         dz_normi=dc_norm(3,i)
2928         xmedi=c(1,i)+0.5d0*dxi
2929         ymedi=c(2,i)+0.5d0*dyi
2930         zmedi=c(3,i)+0.5d0*dzi
2931 C Return atom into box, boxxsize is size of box in x dimension
2932 c  184   continue
2933 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2934 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2935 C Condition for being inside the proper box
2936 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2937 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2938 c        go to 184
2939 c        endif
2940 c  185   continue
2941 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2942 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2943 cC Condition for being inside the proper box
2944 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2945 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2946 c        go to 185
2947 c        endif
2948 c  186   continue
2949 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2950 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2951 cC Condition for being inside the proper box
2952 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2953 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2954 c        go to 186
2955 c        endif
2956           xmedi=mod(xmedi,boxxsize)
2957           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2958           ymedi=mod(ymedi,boxysize)
2959           if (ymedi.lt.0) ymedi=ymedi+boxysize
2960           zmedi=mod(zmedi,boxzsize)
2961           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2962         num_conti=0
2963         call eelecij(i,i+2,ees,evdw1,eel_loc)
2964         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2965         num_cont_hb(i)=num_conti
2966       enddo
2967       do i=iturn4_start,iturn4_end
2968         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2969      &    .or. itype(i+3).eq.ntyp1
2970      &    .or. itype(i+4).eq.ntyp1
2971      &    .or. itype(i+5).eq.ntyp1
2972      &    .or. itype(i).eq.ntyp1
2973      &    .or. itype(i-1).eq.ntyp1
2974      &                             ) cycle
2975         dxi=dc(1,i)
2976         dyi=dc(2,i)
2977         dzi=dc(3,i)
2978         dx_normi=dc_norm(1,i)
2979         dy_normi=dc_norm(2,i)
2980         dz_normi=dc_norm(3,i)
2981         xmedi=c(1,i)+0.5d0*dxi
2982         ymedi=c(2,i)+0.5d0*dyi
2983         zmedi=c(3,i)+0.5d0*dzi
2984 C Return atom into box, boxxsize is size of box in x dimension
2985 c  194   continue
2986 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2987 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2988 C Condition for being inside the proper box
2989 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2990 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2991 c        go to 194
2992 c        endif
2993 c  195   continue
2994 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2995 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2996 C Condition for being inside the proper box
2997 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2998 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2999 c        go to 195
3000 c        endif
3001 c  196   continue
3002 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3003 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3004 C Condition for being inside the proper box
3005 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3006 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3007 c        go to 196
3008 c        endif
3009           xmedi=mod(xmedi,boxxsize)
3010           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3011           ymedi=mod(ymedi,boxysize)
3012           if (ymedi.lt.0) ymedi=ymedi+boxysize
3013           zmedi=mod(zmedi,boxzsize)
3014           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3015
3016         num_conti=num_cont_hb(i)
3017         call eelecij(i,i+3,ees,evdw1,eel_loc)
3018         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3019      &   call eturn4(i,eello_turn4)
3020         num_cont_hb(i)=num_conti
3021       enddo   ! i
3022 C Loop over all neighbouring boxes
3023 C      do xshift=-1,1
3024 C      do yshift=-1,1
3025 C      do zshift=-1,1
3026 c
3027 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3028 c
3029       do i=iatel_s,iatel_e
3030         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3031      &  .or. itype(i+2).eq.ntyp1
3032      &  .or. itype(i-1).eq.ntyp1
3033      &                ) cycle
3034         dxi=dc(1,i)
3035         dyi=dc(2,i)
3036         dzi=dc(3,i)
3037         dx_normi=dc_norm(1,i)
3038         dy_normi=dc_norm(2,i)
3039         dz_normi=dc_norm(3,i)
3040         xmedi=c(1,i)+0.5d0*dxi
3041         ymedi=c(2,i)+0.5d0*dyi
3042         zmedi=c(3,i)+0.5d0*dzi
3043           xmedi=mod(xmedi,boxxsize)
3044           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3045           ymedi=mod(ymedi,boxysize)
3046           if (ymedi.lt.0) ymedi=ymedi+boxysize
3047           zmedi=mod(zmedi,boxzsize)
3048           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3049 C          xmedi=xmedi+xshift*boxxsize
3050 C          ymedi=ymedi+yshift*boxysize
3051 C          zmedi=zmedi+zshift*boxzsize
3052
3053 C Return tom into box, boxxsize is size of box in x dimension
3054 c  164   continue
3055 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3056 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3057 C Condition for being inside the proper box
3058 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3059 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3060 c        go to 164
3061 c        endif
3062 c  165   continue
3063 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3064 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3065 C Condition for being inside the proper box
3066 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3067 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3068 c        go to 165
3069 c        endif
3070 c  166   continue
3071 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3072 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3073 cC Condition for being inside the proper box
3074 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3075 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3076 c        go to 166
3077 c        endif
3078
3079 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3080         num_conti=num_cont_hb(i)
3081         do j=ielstart(i),ielend(i)
3082 c          write (iout,*) i,j,itype(i),itype(j)
3083           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3084      & .or.itype(j+2).eq.ntyp1
3085      & .or.itype(j-1).eq.ntyp1
3086      &) cycle
3087           call eelecij(i,j,ees,evdw1,eel_loc)
3088         enddo ! j
3089         num_cont_hb(i)=num_conti
3090       enddo   ! i
3091 C     enddo   ! zshift
3092 C      enddo   ! yshift
3093 C      enddo   ! xshift
3094
3095 c      write (iout,*) "Number of loop steps in EELEC:",ind
3096 cd      do i=1,nres
3097 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3098 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3099 cd      enddo
3100 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3101 ccc      eel_loc=eel_loc+eello_turn3
3102 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3103       return
3104       end
3105 C-------------------------------------------------------------------------------
3106       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3107       implicit real*8 (a-h,o-z)
3108       include 'DIMENSIONS'
3109 #ifdef MPI
3110       include "mpif.h"
3111 #endif
3112       include 'COMMON.CONTROL'
3113       include 'COMMON.IOUNITS'
3114       include 'COMMON.GEO'
3115       include 'COMMON.VAR'
3116       include 'COMMON.LOCAL'
3117       include 'COMMON.CHAIN'
3118       include 'COMMON.DERIV'
3119       include 'COMMON.INTERACT'
3120       include 'COMMON.CONTACTS'
3121       include 'COMMON.TORSION'
3122       include 'COMMON.VECTORS'
3123       include 'COMMON.FFIELD'
3124       include 'COMMON.TIME1'
3125       include 'COMMON.SPLITELE'
3126       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3127      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3128       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3129      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3130       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3131      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3132      &    num_conti,j1,j2
3133 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3134 #ifdef MOMENT
3135       double precision scal_el /1.0d0/
3136 #else
3137       double precision scal_el /0.5d0/
3138 #endif
3139 C 12/13/98
3140 C 13-go grudnia roku pamietnego...
3141       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3142      &                   0.0d0,1.0d0,0.0d0,
3143      &                   0.0d0,0.0d0,1.0d0/
3144 c          time00=MPI_Wtime()
3145 cd      write (iout,*) "eelecij",i,j
3146 c          ind=ind+1
3147           iteli=itel(i)
3148           itelj=itel(j)
3149           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3150           aaa=app(iteli,itelj)
3151           bbb=bpp(iteli,itelj)
3152           ael6i=ael6(iteli,itelj)
3153           ael3i=ael3(iteli,itelj)
3154           dxj=dc(1,j)
3155           dyj=dc(2,j)
3156           dzj=dc(3,j)
3157           dx_normj=dc_norm(1,j)
3158           dy_normj=dc_norm(2,j)
3159           dz_normj=dc_norm(3,j)
3160 C          xj=c(1,j)+0.5D0*dxj-xmedi
3161 C          yj=c(2,j)+0.5D0*dyj-ymedi
3162 C          zj=c(3,j)+0.5D0*dzj-zmedi
3163           xj=c(1,j)+0.5D0*dxj
3164           yj=c(2,j)+0.5D0*dyj
3165           zj=c(3,j)+0.5D0*dzj
3166           xj=mod(xj,boxxsize)
3167           if (xj.lt.0) xj=xj+boxxsize
3168           yj=mod(yj,boxysize)
3169           if (yj.lt.0) yj=yj+boxysize
3170           zj=mod(zj,boxzsize)
3171           if (zj.lt.0) zj=zj+boxzsize
3172       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3173       xj_safe=xj
3174       yj_safe=yj
3175       zj_safe=zj
3176       isubchap=0
3177       do xshift=-1,1
3178       do yshift=-1,1
3179       do zshift=-1,1
3180           xj=xj_safe+xshift*boxxsize
3181           yj=yj_safe+yshift*boxysize
3182           zj=zj_safe+zshift*boxzsize
3183           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3184           if(dist_temp.lt.dist_init) then
3185             dist_init=dist_temp
3186             xj_temp=xj
3187             yj_temp=yj
3188             zj_temp=zj
3189             isubchap=1
3190           endif
3191        enddo
3192        enddo
3193        enddo
3194        if (isubchap.eq.1) then
3195           xj=xj_temp-xmedi
3196           yj=yj_temp-ymedi
3197           zj=zj_temp-zmedi
3198        else
3199           xj=xj_safe-xmedi
3200           yj=yj_safe-ymedi
3201           zj=zj_safe-zmedi
3202        endif
3203 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3204 c  174   continue
3205 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3206 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3207 C Condition for being inside the proper box
3208 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3209 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3210 c        go to 174
3211 c        endif
3212 c  175   continue
3213 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3214 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3215 C Condition for being inside the proper box
3216 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3217 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3218 c        go to 175
3219 c        endif
3220 c  176   continue
3221 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3222 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3223 C Condition for being inside the proper box
3224 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3225 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3226 c        go to 176
3227 c        endif
3228 C        endif !endPBC condintion
3229 C        xj=xj-xmedi
3230 C        yj=yj-ymedi
3231 C        zj=zj-zmedi
3232           rij=xj*xj+yj*yj+zj*zj
3233
3234             sss=sscale(sqrt(rij))
3235             sssgrad=sscagrad(sqrt(rij))
3236 c            if (sss.gt.0.0d0) then
3237           rrmij=1.0D0/rij
3238           rij=dsqrt(rij)
3239           rmij=1.0D0/rij
3240           r3ij=rrmij*rmij
3241           r6ij=r3ij*r3ij
3242           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3243           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3244           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3245           fac=cosa-3.0D0*cosb*cosg
3246           ev1=aaa*r6ij*r6ij
3247 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3248           if (j.eq.i+2) ev1=scal_el*ev1
3249           ev2=bbb*r6ij
3250           fac3=ael6i*r6ij
3251           fac4=ael3i*r3ij
3252           evdwij=(ev1+ev2)
3253           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3254           el2=fac4*fac
3255 C MARYSIA
3256           eesij=(el1+el2)
3257 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3258           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3259           ees=ees+eesij
3260           evdw1=evdw1+evdwij*sss
3261 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3262 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3263 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3264 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3265
3266           if (energy_dec) then
3267               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3268      &'evdw1',i,j,evdwij
3269      &,iteli,itelj,aaa,evdw1
3270               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3271           endif
3272
3273 C
3274 C Calculate contributions to the Cartesian gradient.
3275 C
3276 #ifdef SPLITELE
3277           facvdw=-6*rrmij*(ev1+evdwij)*sss
3278           facel=-3*rrmij*(el1+eesij)
3279           fac1=fac
3280           erij(1)=xj*rmij
3281           erij(2)=yj*rmij
3282           erij(3)=zj*rmij
3283 *
3284 * Radial derivatives. First process both termini of the fragment (i,j)
3285 *
3286           ggg(1)=facel*xj
3287           ggg(2)=facel*yj
3288           ggg(3)=facel*zj
3289 c          do k=1,3
3290 c            ghalf=0.5D0*ggg(k)
3291 c            gelc(k,i)=gelc(k,i)+ghalf
3292 c            gelc(k,j)=gelc(k,j)+ghalf
3293 c          enddo
3294 c 9/28/08 AL Gradient compotents will be summed only at the end
3295           do k=1,3
3296             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3297             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3298           enddo
3299 *
3300 * Loop over residues i+1 thru j-1.
3301 *
3302 cgrad          do k=i+1,j-1
3303 cgrad            do l=1,3
3304 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3305 cgrad            enddo
3306 cgrad          enddo
3307           if (sss.gt.0.0) then
3308           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3309           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3310           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3311           else
3312           ggg(1)=0.0
3313           ggg(2)=0.0
3314           ggg(3)=0.0
3315           endif
3316 c          do k=1,3
3317 c            ghalf=0.5D0*ggg(k)
3318 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3319 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3320 c          enddo
3321 c 9/28/08 AL Gradient compotents will be summed only at the end
3322           do k=1,3
3323             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3324             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3325           enddo
3326 *
3327 * Loop over residues i+1 thru j-1.
3328 *
3329 cgrad          do k=i+1,j-1
3330 cgrad            do l=1,3
3331 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3332 cgrad            enddo
3333 cgrad          enddo
3334 #else
3335 C MARYSIA
3336           facvdw=(ev1+evdwij)*sss
3337           facel=(el1+eesij)
3338           fac1=fac
3339           fac=-3*rrmij*(facvdw+facvdw+facel)
3340           erij(1)=xj*rmij
3341           erij(2)=yj*rmij
3342           erij(3)=zj*rmij
3343 *
3344 * Radial derivatives. First process both termini of the fragment (i,j)
3345 *
3346           ggg(1)=fac*xj
3347           ggg(2)=fac*yj
3348           ggg(3)=fac*zj
3349 c          do k=1,3
3350 c            ghalf=0.5D0*ggg(k)
3351 c            gelc(k,i)=gelc(k,i)+ghalf
3352 c            gelc(k,j)=gelc(k,j)+ghalf
3353 c          enddo
3354 c 9/28/08 AL Gradient compotents will be summed only at the end
3355           do k=1,3
3356             gelc_long(k,j)=gelc(k,j)+ggg(k)
3357             gelc_long(k,i)=gelc(k,i)-ggg(k)
3358           enddo
3359 *
3360 * Loop over residues i+1 thru j-1.
3361 *
3362 cgrad          do k=i+1,j-1
3363 cgrad            do l=1,3
3364 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3365 cgrad            enddo
3366 cgrad          enddo
3367 c 9/28/08 AL Gradient compotents will be summed only at the end
3368           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3369           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3370           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3371           do k=1,3
3372             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3373             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3374           enddo
3375 #endif
3376 *
3377 * Angular part
3378 *
3379           ecosa=2.0D0*fac3*fac1+fac4
3380           fac4=-3.0D0*fac4
3381           fac3=-6.0D0*fac3
3382           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3383           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3384           do k=1,3
3385             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3386             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3387           enddo
3388 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3389 cd   &          (dcosg(k),k=1,3)
3390           do k=1,3
3391             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3392           enddo
3393 c          do k=1,3
3394 c            ghalf=0.5D0*ggg(k)
3395 c            gelc(k,i)=gelc(k,i)+ghalf
3396 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3397 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3398 c            gelc(k,j)=gelc(k,j)+ghalf
3399 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3400 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3401 c          enddo
3402 cgrad          do k=i+1,j-1
3403 cgrad            do l=1,3
3404 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3405 cgrad            enddo
3406 cgrad          enddo
3407           do k=1,3
3408             gelc(k,i)=gelc(k,i)
3409      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3410      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3411             gelc(k,j)=gelc(k,j)
3412      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3413      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3414             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3415             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3416           enddo
3417 C MARYSIA
3418 c          endif !sscale
3419           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3420      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3421      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3422 C
3423 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3424 C   energy of a peptide unit is assumed in the form of a second-order
3425 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3426 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3427 C   are computed for EVERY pair of non-contiguous peptide groups.
3428 C
3429           if (j.lt.nres-1) then
3430             j1=j+1
3431             j2=j-1
3432           else
3433             j1=j-1
3434             j2=j-2
3435           endif
3436           kkk=0
3437           do k=1,2
3438             do l=1,2
3439               kkk=kkk+1
3440               muij(kkk)=mu(k,i)*mu(l,j)
3441             enddo
3442           enddo
3443 cd         write (iout,*) 'EELEC: i',i,' j',j
3444 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3445 cd          write(iout,*) 'muij',muij
3446           ury=scalar(uy(1,i),erij)
3447           urz=scalar(uz(1,i),erij)
3448           vry=scalar(uy(1,j),erij)
3449           vrz=scalar(uz(1,j),erij)
3450           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3451           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3452           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3453           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3454           fac=dsqrt(-ael6i)*r3ij
3455           a22=a22*fac
3456           a23=a23*fac
3457           a32=a32*fac
3458           a33=a33*fac
3459 cd          write (iout,'(4i5,4f10.5)')
3460 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3461 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3462 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3463 cd     &      uy(:,j),uz(:,j)
3464 cd          write (iout,'(4f10.5)')
3465 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3466 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3467 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3468 cd           write (iout,'(9f10.5/)')
3469 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3470 C Derivatives of the elements of A in virtual-bond vectors
3471           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3472           do k=1,3
3473             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3474             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3475             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3476             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3477             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3478             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3479             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3480             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3481             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3482             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3483             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3484             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3485           enddo
3486 C Compute radial contributions to the gradient
3487           facr=-3.0d0*rrmij
3488           a22der=a22*facr
3489           a23der=a23*facr
3490           a32der=a32*facr
3491           a33der=a33*facr
3492           agg(1,1)=a22der*xj
3493           agg(2,1)=a22der*yj
3494           agg(3,1)=a22der*zj
3495           agg(1,2)=a23der*xj
3496           agg(2,2)=a23der*yj
3497           agg(3,2)=a23der*zj
3498           agg(1,3)=a32der*xj
3499           agg(2,3)=a32der*yj
3500           agg(3,3)=a32der*zj
3501           agg(1,4)=a33der*xj
3502           agg(2,4)=a33der*yj
3503           agg(3,4)=a33der*zj
3504 C Add the contributions coming from er
3505           fac3=-3.0d0*fac
3506           do k=1,3
3507             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3508             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3509             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3510             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3511           enddo
3512           do k=1,3
3513 C Derivatives in DC(i)
3514 cgrad            ghalf1=0.5d0*agg(k,1)
3515 cgrad            ghalf2=0.5d0*agg(k,2)
3516 cgrad            ghalf3=0.5d0*agg(k,3)
3517 cgrad            ghalf4=0.5d0*agg(k,4)
3518             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3519      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3520             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3521      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3522             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3523      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3524             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3525      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3526 C Derivatives in DC(i+1)
3527             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3528      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3529             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3530      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3531             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3532      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3533             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3534      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3535 C Derivatives in DC(j)
3536             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3537      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3538             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3539      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3540             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3541      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3542             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3543      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3544 C Derivatives in DC(j+1) or DC(nres-1)
3545             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3546      &      -3.0d0*vryg(k,3)*ury)
3547             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3548      &      -3.0d0*vrzg(k,3)*ury)
3549             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3550      &      -3.0d0*vryg(k,3)*urz)
3551             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3552      &      -3.0d0*vrzg(k,3)*urz)
3553 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3554 cgrad              do l=1,4
3555 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3556 cgrad              enddo
3557 cgrad            endif
3558           enddo
3559           acipa(1,1)=a22
3560           acipa(1,2)=a23
3561           acipa(2,1)=a32
3562           acipa(2,2)=a33
3563           a22=-a22
3564           a23=-a23
3565           do l=1,2
3566             do k=1,3
3567               agg(k,l)=-agg(k,l)
3568               aggi(k,l)=-aggi(k,l)
3569               aggi1(k,l)=-aggi1(k,l)
3570               aggj(k,l)=-aggj(k,l)
3571               aggj1(k,l)=-aggj1(k,l)
3572             enddo
3573           enddo
3574           if (j.lt.nres-1) then
3575             a22=-a22
3576             a32=-a32
3577             do l=1,3,2
3578               do k=1,3
3579                 agg(k,l)=-agg(k,l)
3580                 aggi(k,l)=-aggi(k,l)
3581                 aggi1(k,l)=-aggi1(k,l)
3582                 aggj(k,l)=-aggj(k,l)
3583                 aggj1(k,l)=-aggj1(k,l)
3584               enddo
3585             enddo
3586           else
3587             a22=-a22
3588             a23=-a23
3589             a32=-a32
3590             a33=-a33
3591             do l=1,4
3592               do k=1,3
3593                 agg(k,l)=-agg(k,l)
3594                 aggi(k,l)=-aggi(k,l)
3595                 aggi1(k,l)=-aggi1(k,l)
3596                 aggj(k,l)=-aggj(k,l)
3597                 aggj1(k,l)=-aggj1(k,l)
3598               enddo
3599             enddo
3600           endif
3601           ENDIF ! WCORR
3602           IF (wel_loc.gt.0.0d0) THEN
3603 C Contribution to the local-electrostatic energy coming from the i-j pair
3604           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3605      &     +a33*muij(4)
3606 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3607 c     &                     ' eel_loc_ij',eel_loc_ij
3608
3609           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3610      &            'eelloc',i,j,eel_loc_ij
3611 c           if (eel_loc_ij.ne.0)
3612 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3613 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3614
3615           eel_loc=eel_loc+eel_loc_ij
3616 C Partial derivatives in virtual-bond dihedral angles gamma
3617           if (i.gt.1)
3618      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3619      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3620      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3621           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3622      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3623      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3624 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3625           do l=1,3
3626             ggg(l)=agg(l,1)*muij(1)+
3627      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3628             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3629             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3630 cgrad            ghalf=0.5d0*ggg(l)
3631 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3632 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3633           enddo
3634 cgrad          do k=i+1,j2
3635 cgrad            do l=1,3
3636 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3637 cgrad            enddo
3638 cgrad          enddo
3639 C Remaining derivatives of eello
3640           do l=1,3
3641             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3642      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3643             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3644      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3645             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3646      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3647             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3648      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3649           enddo
3650           ENDIF
3651 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3652 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3653           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3654      &       .and. num_conti.le.maxconts) then
3655 c            write (iout,*) i,j," entered corr"
3656 C
3657 C Calculate the contact function. The ith column of the array JCONT will
3658 C contain the numbers of atoms that make contacts with the atom I (of numbers
3659 C greater than I). The arrays FACONT and GACONT will contain the values of
3660 C the contact function and its derivative.
3661 c           r0ij=1.02D0*rpp(iteli,itelj)
3662 c           r0ij=1.11D0*rpp(iteli,itelj)
3663             r0ij=2.20D0*rpp(iteli,itelj)
3664 c           r0ij=1.55D0*rpp(iteli,itelj)
3665             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3666             if (fcont.gt.0.0D0) then
3667               num_conti=num_conti+1
3668               if (num_conti.gt.maxconts) then
3669                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3670      &                         ' will skip next contacts for this conf.'
3671               else
3672                 jcont_hb(num_conti,i)=j
3673 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3674 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3675                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3676      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3677 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3678 C  terms.
3679                 d_cont(num_conti,i)=rij
3680 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3681 C     --- Electrostatic-interaction matrix ---
3682                 a_chuj(1,1,num_conti,i)=a22
3683                 a_chuj(1,2,num_conti,i)=a23
3684                 a_chuj(2,1,num_conti,i)=a32
3685                 a_chuj(2,2,num_conti,i)=a33
3686 C     --- Gradient of rij
3687                 do kkk=1,3
3688                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3689                 enddo
3690                 kkll=0
3691                 do k=1,2
3692                   do l=1,2
3693                     kkll=kkll+1
3694                     do m=1,3
3695                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3696                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3697                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3698                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3699                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3700                     enddo
3701                   enddo
3702                 enddo
3703                 ENDIF
3704                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3705 C Calculate contact energies
3706                 cosa4=4.0D0*cosa
3707                 wij=cosa-3.0D0*cosb*cosg
3708                 cosbg1=cosb+cosg
3709                 cosbg2=cosb-cosg
3710 c               fac3=dsqrt(-ael6i)/r0ij**3
3711                 fac3=dsqrt(-ael6i)*r3ij
3712 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3713                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3714                 if (ees0tmp.gt.0) then
3715                   ees0pij=dsqrt(ees0tmp)
3716                 else
3717                   ees0pij=0
3718                 endif
3719 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3720                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3721                 if (ees0tmp.gt.0) then
3722                   ees0mij=dsqrt(ees0tmp)
3723                 else
3724                   ees0mij=0
3725                 endif
3726 c               ees0mij=0.0D0
3727                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3728                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3729 C Diagnostics. Comment out or remove after debugging!
3730 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3731 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3732 c               ees0m(num_conti,i)=0.0D0
3733 C End diagnostics.
3734 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3735 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3736 C Angular derivatives of the contact function
3737                 ees0pij1=fac3/ees0pij
3738                 ees0mij1=fac3/ees0mij
3739                 fac3p=-3.0D0*fac3*rrmij
3740                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3741                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3742 c               ees0mij1=0.0D0
3743                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3744                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3745                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3746                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3747                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3748                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3749                 ecosap=ecosa1+ecosa2
3750                 ecosbp=ecosb1+ecosb2
3751                 ecosgp=ecosg1+ecosg2
3752                 ecosam=ecosa1-ecosa2
3753                 ecosbm=ecosb1-ecosb2
3754                 ecosgm=ecosg1-ecosg2
3755 C Diagnostics
3756 c               ecosap=ecosa1
3757 c               ecosbp=ecosb1
3758 c               ecosgp=ecosg1
3759 c               ecosam=0.0D0
3760 c               ecosbm=0.0D0
3761 c               ecosgm=0.0D0
3762 C End diagnostics
3763                 facont_hb(num_conti,i)=fcont
3764                 fprimcont=fprimcont/rij
3765 cd              facont_hb(num_conti,i)=1.0D0
3766 C Following line is for diagnostics.
3767 cd              fprimcont=0.0D0
3768                 do k=1,3
3769                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3770                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3771                 enddo
3772                 do k=1,3
3773                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3774                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3775                 enddo
3776                 gggp(1)=gggp(1)+ees0pijp*xj
3777                 gggp(2)=gggp(2)+ees0pijp*yj
3778                 gggp(3)=gggp(3)+ees0pijp*zj
3779                 gggm(1)=gggm(1)+ees0mijp*xj
3780                 gggm(2)=gggm(2)+ees0mijp*yj
3781                 gggm(3)=gggm(3)+ees0mijp*zj
3782 C Derivatives due to the contact function
3783                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3784                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3785                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3786                 do k=1,3
3787 c
3788 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3789 c          following the change of gradient-summation algorithm.
3790 c
3791 cgrad                  ghalfp=0.5D0*gggp(k)
3792 cgrad                  ghalfm=0.5D0*gggm(k)
3793                   gacontp_hb1(k,num_conti,i)=!ghalfp
3794      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3795      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3796                   gacontp_hb2(k,num_conti,i)=!ghalfp
3797      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3798      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3799                   gacontp_hb3(k,num_conti,i)=gggp(k)
3800                   gacontm_hb1(k,num_conti,i)=!ghalfm
3801      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3802      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3803                   gacontm_hb2(k,num_conti,i)=!ghalfm
3804      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3805      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3806                   gacontm_hb3(k,num_conti,i)=gggm(k)
3807                 enddo
3808 C Diagnostics. Comment out or remove after debugging!
3809 cdiag           do k=1,3
3810 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3811 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3812 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3813 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3814 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3815 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3816 cdiag           enddo
3817               ENDIF ! wcorr
3818               endif  ! num_conti.le.maxconts
3819             endif  ! fcont.gt.0
3820           endif    ! j.gt.i+1
3821           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3822             do k=1,4
3823               do l=1,3
3824                 ghalf=0.5d0*agg(l,k)
3825                 aggi(l,k)=aggi(l,k)+ghalf
3826                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3827                 aggj(l,k)=aggj(l,k)+ghalf
3828               enddo
3829             enddo
3830             if (j.eq.nres-1 .and. i.lt.j-2) then
3831               do k=1,4
3832                 do l=1,3
3833                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3834                 enddo
3835               enddo
3836             endif
3837           endif
3838 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3839       return
3840       end
3841 C-----------------------------------------------------------------------------
3842       subroutine eturn3(i,eello_turn3)
3843 C Third- and fourth-order contributions from turns
3844       implicit real*8 (a-h,o-z)
3845       include 'DIMENSIONS'
3846       include 'COMMON.IOUNITS'
3847       include 'COMMON.GEO'
3848       include 'COMMON.VAR'
3849       include 'COMMON.LOCAL'
3850       include 'COMMON.CHAIN'
3851       include 'COMMON.DERIV'
3852       include 'COMMON.INTERACT'
3853       include 'COMMON.CONTACTS'
3854       include 'COMMON.TORSION'
3855       include 'COMMON.VECTORS'
3856       include 'COMMON.FFIELD'
3857       include 'COMMON.CONTROL'
3858       dimension ggg(3)
3859       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3860      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3861      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3862       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3863      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3864       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3865      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3866      &    num_conti,j1,j2
3867       j=i+2
3868 c      write (iout,*) "eturn3",i,j,j1,j2
3869       a_temp(1,1)=a22
3870       a_temp(1,2)=a23
3871       a_temp(2,1)=a32
3872       a_temp(2,2)=a33
3873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3874 C
3875 C               Third-order contributions
3876 C
3877 C                 (i+2)o----(i+3)
3878 C                      | |
3879 C                      | |
3880 C                 (i+1)o----i
3881 C
3882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3883 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3884         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3885         call transpose2(auxmat(1,1),auxmat1(1,1))
3886         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3887         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3888         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3889      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3890 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3891 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3892 cd     &    ' eello_turn3_num',4*eello_turn3_num
3893 C Derivatives in gamma(i)
3894         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3895         call transpose2(auxmat2(1,1),auxmat3(1,1))
3896         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3897         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3898 C Derivatives in gamma(i+1)
3899         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3900         call transpose2(auxmat2(1,1),auxmat3(1,1))
3901         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3902         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3903      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3904 C Cartesian derivatives
3905         do l=1,3
3906 c            ghalf1=0.5d0*agg(l,1)
3907 c            ghalf2=0.5d0*agg(l,2)
3908 c            ghalf3=0.5d0*agg(l,3)
3909 c            ghalf4=0.5d0*agg(l,4)
3910           a_temp(1,1)=aggi(l,1)!+ghalf1
3911           a_temp(1,2)=aggi(l,2)!+ghalf2
3912           a_temp(2,1)=aggi(l,3)!+ghalf3
3913           a_temp(2,2)=aggi(l,4)!+ghalf4
3914           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3915           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3916      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3917           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3918           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3919           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3920           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3921           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3922           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3923      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3924           a_temp(1,1)=aggj(l,1)!+ghalf1
3925           a_temp(1,2)=aggj(l,2)!+ghalf2
3926           a_temp(2,1)=aggj(l,3)!+ghalf3
3927           a_temp(2,2)=aggj(l,4)!+ghalf4
3928           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3929           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3930      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3931           a_temp(1,1)=aggj1(l,1)
3932           a_temp(1,2)=aggj1(l,2)
3933           a_temp(2,1)=aggj1(l,3)
3934           a_temp(2,2)=aggj1(l,4)
3935           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3936           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3937      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3938         enddo
3939       return
3940       end
3941 C-------------------------------------------------------------------------------
3942       subroutine eturn4(i,eello_turn4)
3943 C Third- and fourth-order contributions from turns
3944       implicit real*8 (a-h,o-z)
3945       include 'DIMENSIONS'
3946       include 'COMMON.IOUNITS'
3947       include 'COMMON.GEO'
3948       include 'COMMON.VAR'
3949       include 'COMMON.LOCAL'
3950       include 'COMMON.CHAIN'
3951       include 'COMMON.DERIV'
3952       include 'COMMON.INTERACT'
3953       include 'COMMON.CONTACTS'
3954       include 'COMMON.TORSION'
3955       include 'COMMON.VECTORS'
3956       include 'COMMON.FFIELD'
3957       include 'COMMON.CONTROL'
3958       dimension ggg(3)
3959       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3960      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3961      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3962       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3963      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3964       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3965      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3966      &    num_conti,j1,j2
3967       j=i+3
3968 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3969 C
3970 C               Fourth-order contributions
3971 C
3972 C                 (i+3)o----(i+4)
3973 C                     /  |
3974 C               (i+2)o   |
3975 C                     \  |
3976 C                 (i+1)o----i
3977 C
3978 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3979 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3980 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3981         a_temp(1,1)=a22
3982         a_temp(1,2)=a23
3983         a_temp(2,1)=a32
3984         a_temp(2,2)=a33
3985         iti1=itortyp(itype(i+1))
3986         iti2=itortyp(itype(i+2))
3987         iti3=itortyp(itype(i+3))
3988 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3989         call transpose2(EUg(1,1,i+1),e1t(1,1))
3990         call transpose2(Eug(1,1,i+2),e2t(1,1))
3991         call transpose2(Eug(1,1,i+3),e3t(1,1))
3992         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3993         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3994         s1=scalar2(b1(1,iti2),auxvec(1))
3995         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3996         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3997         s2=scalar2(b1(1,iti1),auxvec(1))
3998         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3999         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4000         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4001         eello_turn4=eello_turn4-(s1+s2+s3)
4002 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4003         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4004      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4005 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4006 cd     &    ' eello_turn4_num',8*eello_turn4_num
4007 C Derivatives in gamma(i)
4008         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4009         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4010         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4011         s1=scalar2(b1(1,iti2),auxvec(1))
4012         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4013         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4014         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4015 C Derivatives in gamma(i+1)
4016         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4017         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4018         s2=scalar2(b1(1,iti1),auxvec(1))
4019         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4020         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4021         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4022         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4023 C Derivatives in gamma(i+2)
4024         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4025         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4026         s1=scalar2(b1(1,iti2),auxvec(1))
4027         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4028         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4029         s2=scalar2(b1(1,iti1),auxvec(1))
4030         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4031         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4032         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4033         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4034 C Cartesian derivatives
4035 C Derivatives of this turn contributions in DC(i+2)
4036         if (j.lt.nres-1) then
4037           do l=1,3
4038             a_temp(1,1)=agg(l,1)
4039             a_temp(1,2)=agg(l,2)
4040             a_temp(2,1)=agg(l,3)
4041             a_temp(2,2)=agg(l,4)
4042             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4043             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4044             s1=scalar2(b1(1,iti2),auxvec(1))
4045             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4046             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4047             s2=scalar2(b1(1,iti1),auxvec(1))
4048             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4049             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4050             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4051             ggg(l)=-(s1+s2+s3)
4052             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4053           enddo
4054         endif
4055 C Remaining derivatives of this turn contribution
4056         do l=1,3
4057           a_temp(1,1)=aggi(l,1)
4058           a_temp(1,2)=aggi(l,2)
4059           a_temp(2,1)=aggi(l,3)
4060           a_temp(2,2)=aggi(l,4)
4061           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4062           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4063           s1=scalar2(b1(1,iti2),auxvec(1))
4064           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4065           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4066           s2=scalar2(b1(1,iti1),auxvec(1))
4067           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4068           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4069           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4070           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4071           a_temp(1,1)=aggi1(l,1)
4072           a_temp(1,2)=aggi1(l,2)
4073           a_temp(2,1)=aggi1(l,3)
4074           a_temp(2,2)=aggi1(l,4)
4075           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4076           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4077           s1=scalar2(b1(1,iti2),auxvec(1))
4078           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4079           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4080           s2=scalar2(b1(1,iti1),auxvec(1))
4081           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4082           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4083           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4084           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4085           a_temp(1,1)=aggj(l,1)
4086           a_temp(1,2)=aggj(l,2)
4087           a_temp(2,1)=aggj(l,3)
4088           a_temp(2,2)=aggj(l,4)
4089           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4090           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4091           s1=scalar2(b1(1,iti2),auxvec(1))
4092           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4093           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4094           s2=scalar2(b1(1,iti1),auxvec(1))
4095           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4096           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4097           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4098           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4099           a_temp(1,1)=aggj1(l,1)
4100           a_temp(1,2)=aggj1(l,2)
4101           a_temp(2,1)=aggj1(l,3)
4102           a_temp(2,2)=aggj1(l,4)
4103           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4104           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4105           s1=scalar2(b1(1,iti2),auxvec(1))
4106           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4107           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4108           s2=scalar2(b1(1,iti1),auxvec(1))
4109           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4110           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4111           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4112 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4113           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4114         enddo
4115       return
4116       end
4117 C-----------------------------------------------------------------------------
4118       subroutine vecpr(u,v,w)
4119       implicit real*8(a-h,o-z)
4120       dimension u(3),v(3),w(3)
4121       w(1)=u(2)*v(3)-u(3)*v(2)
4122       w(2)=-u(1)*v(3)+u(3)*v(1)
4123       w(3)=u(1)*v(2)-u(2)*v(1)
4124       return
4125       end
4126 C-----------------------------------------------------------------------------
4127       subroutine unormderiv(u,ugrad,unorm,ungrad)
4128 C This subroutine computes the derivatives of a normalized vector u, given
4129 C the derivatives computed without normalization conditions, ugrad. Returns
4130 C ungrad.
4131       implicit none
4132       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4133       double precision vec(3)
4134       double precision scalar
4135       integer i,j
4136 c      write (2,*) 'ugrad',ugrad
4137 c      write (2,*) 'u',u
4138       do i=1,3
4139         vec(i)=scalar(ugrad(1,i),u(1))
4140       enddo
4141 c      write (2,*) 'vec',vec
4142       do i=1,3
4143         do j=1,3
4144           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4145         enddo
4146       enddo
4147 c      write (2,*) 'ungrad',ungrad
4148       return
4149       end
4150 C-----------------------------------------------------------------------------
4151       subroutine escp_soft_sphere(evdw2,evdw2_14)
4152 C
4153 C This subroutine calculates the excluded-volume interaction energy between
4154 C peptide-group centers and side chains and its gradient in virtual-bond and
4155 C side-chain vectors.
4156 C
4157       implicit real*8 (a-h,o-z)
4158       include 'DIMENSIONS'
4159       include 'COMMON.GEO'
4160       include 'COMMON.VAR'
4161       include 'COMMON.LOCAL'
4162       include 'COMMON.CHAIN'
4163       include 'COMMON.DERIV'
4164       include 'COMMON.INTERACT'
4165       include 'COMMON.FFIELD'
4166       include 'COMMON.IOUNITS'
4167       include 'COMMON.CONTROL'
4168       dimension ggg(3)
4169       evdw2=0.0D0
4170       evdw2_14=0.0d0
4171       r0_scp=4.5d0
4172 cd    print '(a)','Enter ESCP'
4173 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4174 C      do xshift=-1,1
4175 C      do yshift=-1,1
4176 C      do zshift=-1,1
4177       do i=iatscp_s,iatscp_e
4178         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4179         iteli=itel(i)
4180         xi=0.5D0*(c(1,i)+c(1,i+1))
4181         yi=0.5D0*(c(2,i)+c(2,i+1))
4182         zi=0.5D0*(c(3,i)+c(3,i+1))
4183 C Return atom into box, boxxsize is size of box in x dimension
4184 c  134   continue
4185 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4186 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4187 C Condition for being inside the proper box
4188 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4189 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4190 c        go to 134
4191 c        endif
4192 c  135   continue
4193 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4194 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4195 C Condition for being inside the proper box
4196 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4197 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4198 c        go to 135
4199 c c       endif
4200 c  136   continue
4201 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4202 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4203 cC Condition for being inside the proper box
4204 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4205 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4206 c        go to 136
4207 c        endif
4208           xi=mod(xi,boxxsize)
4209           if (xi.lt.0) xi=xi+boxxsize
4210           yi=mod(yi,boxysize)
4211           if (yi.lt.0) yi=yi+boxysize
4212           zi=mod(zi,boxzsize)
4213           if (zi.lt.0) zi=zi+boxzsize
4214 C          xi=xi+xshift*boxxsize
4215 C          yi=yi+yshift*boxysize
4216 C          zi=zi+zshift*boxzsize
4217         do iint=1,nscp_gr(i)
4218
4219         do j=iscpstart(i,iint),iscpend(i,iint)
4220           if (itype(j).eq.ntyp1) cycle
4221           itypj=iabs(itype(j))
4222 C Uncomment following three lines for SC-p interactions
4223 c         xj=c(1,nres+j)-xi
4224 c         yj=c(2,nres+j)-yi
4225 c         zj=c(3,nres+j)-zi
4226 C Uncomment following three lines for Ca-p interactions
4227           xj=c(1,j)
4228           yj=c(2,j)
4229           zj=c(3,j)
4230 c  174   continue
4231 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4232 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4233 C Condition for being inside the proper box
4234 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4235 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4236 c        go to 174
4237 c        endif
4238 c  175   continue
4239 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4240 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4241 cC Condition for being inside the proper box
4242 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4243 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4244 c        go to 175
4245 c        endif
4246 c  176   continue
4247 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4248 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4249 C Condition for being inside the proper box
4250 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4251 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4252 c        go to 176
4253           xj=mod(xj,boxxsize)
4254           if (xj.lt.0) xj=xj+boxxsize
4255           yj=mod(yj,boxysize)
4256           if (yj.lt.0) yj=yj+boxysize
4257           zj=mod(zj,boxzsize)
4258           if (zj.lt.0) zj=zj+boxzsize
4259       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4260       xj_safe=xj
4261       yj_safe=yj
4262       zj_safe=zj
4263       subchap=0
4264       do xshift=-1,1
4265       do yshift=-1,1
4266       do zshift=-1,1
4267           xj=xj_safe+xshift*boxxsize
4268           yj=yj_safe+yshift*boxysize
4269           zj=zj_safe+zshift*boxzsize
4270           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4271           if(dist_temp.lt.dist_init) then
4272             dist_init=dist_temp
4273             xj_temp=xj
4274             yj_temp=yj
4275             zj_temp=zj
4276             subchap=1
4277           endif
4278        enddo
4279        enddo
4280        enddo
4281        if (subchap.eq.1) then
4282           xj=xj_temp-xi
4283           yj=yj_temp-yi
4284           zj=zj_temp-zi
4285        else
4286           xj=xj_safe-xi
4287           yj=yj_safe-yi
4288           zj=zj_safe-zi
4289        endif
4290 c c       endif
4291 C          xj=xj-xi
4292 C          yj=yj-yi
4293 C          zj=zj-zi
4294           rij=xj*xj+yj*yj+zj*zj
4295
4296           r0ij=r0_scp
4297           r0ijsq=r0ij*r0ij
4298           if (rij.lt.r0ijsq) then
4299             evdwij=0.25d0*(rij-r0ijsq)**2
4300             fac=rij-r0ijsq
4301           else
4302             evdwij=0.0d0
4303             fac=0.0d0
4304           endif
4305           evdw2=evdw2+evdwij
4306 C
4307 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4308 C
4309           ggg(1)=xj*fac
4310           ggg(2)=yj*fac
4311           ggg(3)=zj*fac
4312 cgrad          if (j.lt.i) then
4313 cd          write (iout,*) 'j<i'
4314 C Uncomment following three lines for SC-p interactions
4315 c           do k=1,3
4316 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4317 c           enddo
4318 cgrad          else
4319 cd          write (iout,*) 'j>i'
4320 cgrad            do k=1,3
4321 cgrad              ggg(k)=-ggg(k)
4322 C Uncomment following line for SC-p interactions
4323 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4324 cgrad            enddo
4325 cgrad          endif
4326 cgrad          do k=1,3
4327 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4328 cgrad          enddo
4329 cgrad          kstart=min0(i+1,j)
4330 cgrad          kend=max0(i-1,j-1)
4331 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4332 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4333 cgrad          do k=kstart,kend
4334 cgrad            do l=1,3
4335 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4336 cgrad            enddo
4337 cgrad          enddo
4338           do k=1,3
4339             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4340             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4341           enddo
4342         enddo
4343
4344         enddo ! iint
4345       enddo ! i
4346 C      enddo !zshift
4347 C      enddo !yshift
4348 C      enddo !xshift
4349       return
4350       end
4351 C-----------------------------------------------------------------------------
4352       subroutine escp(evdw2,evdw2_14)
4353 C
4354 C This subroutine calculates the excluded-volume interaction energy between
4355 C peptide-group centers and side chains and its gradient in virtual-bond and
4356 C side-chain vectors.
4357 C
4358       implicit real*8 (a-h,o-z)
4359       include 'DIMENSIONS'
4360       include 'COMMON.GEO'
4361       include 'COMMON.VAR'
4362       include 'COMMON.LOCAL'
4363       include 'COMMON.CHAIN'
4364       include 'COMMON.DERIV'
4365       include 'COMMON.INTERACT'
4366       include 'COMMON.FFIELD'
4367       include 'COMMON.IOUNITS'
4368       include 'COMMON.CONTROL'
4369       include 'COMMON.SPLITELE'
4370       dimension ggg(3)
4371       evdw2=0.0D0
4372       evdw2_14=0.0d0
4373 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4374 cd    print '(a)','Enter ESCP'
4375 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4376 C      do xshift=-1,1
4377 C      do yshift=-1,1
4378 C      do zshift=-1,1
4379       do i=iatscp_s,iatscp_e
4380         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4381         iteli=itel(i)
4382         xi=0.5D0*(c(1,i)+c(1,i+1))
4383         yi=0.5D0*(c(2,i)+c(2,i+1))
4384         zi=0.5D0*(c(3,i)+c(3,i+1))
4385           xi=mod(xi,boxxsize)
4386           if (xi.lt.0) xi=xi+boxxsize
4387           yi=mod(yi,boxysize)
4388           if (yi.lt.0) yi=yi+boxysize
4389           zi=mod(zi,boxzsize)
4390           if (zi.lt.0) zi=zi+boxzsize
4391 c          xi=xi+xshift*boxxsize
4392 c          yi=yi+yshift*boxysize
4393 c          zi=zi+zshift*boxzsize
4394 c        print *,xi,yi,zi,'polozenie i'
4395 C Return atom into box, boxxsize is size of box in x dimension
4396 c  134   continue
4397 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4398 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4399 C Condition for being inside the proper box
4400 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4401 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4402 c        go to 134
4403 c        endif
4404 c  135   continue
4405 c          print *,xi,boxxsize,"pierwszy"
4406
4407 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4408 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4409 C Condition for being inside the proper box
4410 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4411 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4412 c        go to 135
4413 c        endif
4414 c  136   continue
4415 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4416 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4417 C Condition for being inside the proper box
4418 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4419 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4420 c        go to 136
4421 c        endif
4422         do iint=1,nscp_gr(i)
4423
4424         do j=iscpstart(i,iint),iscpend(i,iint)
4425           itypj=iabs(itype(j))
4426           if (itypj.eq.ntyp1) cycle
4427 C Uncomment following three lines for SC-p interactions
4428 c         xj=c(1,nres+j)-xi
4429 c         yj=c(2,nres+j)-yi
4430 c         zj=c(3,nres+j)-zi
4431 C Uncomment following three lines for Ca-p interactions
4432           xj=c(1,j)
4433           yj=c(2,j)
4434           zj=c(3,j)
4435           xj=mod(xj,boxxsize)
4436           if (xj.lt.0) xj=xj+boxxsize
4437           yj=mod(yj,boxysize)
4438           if (yj.lt.0) yj=yj+boxysize
4439           zj=mod(zj,boxzsize)
4440           if (zj.lt.0) zj=zj+boxzsize
4441 c  174   continue
4442 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4443 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4444 C Condition for being inside the proper box
4445 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4446 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4447 c        go to 174
4448 c        endif
4449 c  175   continue
4450 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4451 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4452 cC Condition for being inside the proper box
4453 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4454 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4455 c        go to 175
4456 c        endif
4457 c  176   continue
4458 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4459 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4460 C Condition for being inside the proper box
4461 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4462 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4463 c        go to 176
4464 c        endif
4465 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4466       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4467       xj_safe=xj
4468       yj_safe=yj
4469       zj_safe=zj
4470       subchap=0
4471       do xshift=-1,1
4472       do yshift=-1,1
4473       do zshift=-1,1
4474           xj=xj_safe+xshift*boxxsize
4475           yj=yj_safe+yshift*boxysize
4476           zj=zj_safe+zshift*boxzsize
4477           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4478           if(dist_temp.lt.dist_init) then
4479             dist_init=dist_temp
4480             xj_temp=xj
4481             yj_temp=yj
4482             zj_temp=zj
4483             subchap=1
4484           endif
4485        enddo
4486        enddo
4487        enddo
4488        if (subchap.eq.1) then
4489           xj=xj_temp-xi
4490           yj=yj_temp-yi
4491           zj=zj_temp-zi
4492        else
4493           xj=xj_safe-xi
4494           yj=yj_safe-yi
4495           zj=zj_safe-zi
4496        endif
4497 c          print *,xj,yj,zj,'polozenie j'
4498           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4499 c          print *,rrij
4500           sss=sscale(1.0d0/(dsqrt(rrij)))
4501 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4502 c          if (sss.eq.0) print *,'czasem jest OK'
4503           if (sss.le.0.0d0) cycle
4504           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4505           fac=rrij**expon2
4506           e1=fac*fac*aad(itypj,iteli)
4507           e2=fac*bad(itypj,iteli)
4508           if (iabs(j-i) .le. 2) then
4509             e1=scal14*e1
4510             e2=scal14*e2
4511             evdw2_14=evdw2_14+(e1+e2)*sss
4512           endif
4513           evdwij=e1+e2
4514           evdw2=evdw2+evdwij*sss
4515           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4516      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4517      &       bad(itypj,iteli)
4518 C
4519 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4520 C
4521           fac=-(evdwij+e1)*rrij*sss
4522           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4523           ggg(1)=xj*fac
4524           ggg(2)=yj*fac
4525           ggg(3)=zj*fac
4526 cgrad          if (j.lt.i) then
4527 cd          write (iout,*) 'j<i'
4528 C Uncomment following three lines for SC-p interactions
4529 c           do k=1,3
4530 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4531 c           enddo
4532 cgrad          else
4533 cd          write (iout,*) 'j>i'
4534 cgrad            do k=1,3
4535 cgrad              ggg(k)=-ggg(k)
4536 C Uncomment following line for SC-p interactions
4537 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4538 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4539 cgrad            enddo
4540 cgrad          endif
4541 cgrad          do k=1,3
4542 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4543 cgrad          enddo
4544 cgrad          kstart=min0(i+1,j)
4545 cgrad          kend=max0(i-1,j-1)
4546 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4547 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4548 cgrad          do k=kstart,kend
4549 cgrad            do l=1,3
4550 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4551 cgrad            enddo
4552 cgrad          enddo
4553           do k=1,3
4554             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4555             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4556           enddo
4557 c        endif !endif for sscale cutoff
4558         enddo ! j
4559
4560         enddo ! iint
4561       enddo ! i
4562 c      enddo !zshift
4563 c      enddo !yshift
4564 c      enddo !xshift
4565       do i=1,nct
4566         do j=1,3
4567           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4568           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4569           gradx_scp(j,i)=expon*gradx_scp(j,i)
4570         enddo
4571       enddo
4572 C******************************************************************************
4573 C
4574 C                              N O T E !!!
4575 C
4576 C To save time the factor EXPON has been extracted from ALL components
4577 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4578 C use!
4579 C
4580 C******************************************************************************
4581       return
4582       end
4583 C--------------------------------------------------------------------------
4584       subroutine edis(ehpb)
4585 C
4586 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4587 C
4588       implicit real*8 (a-h,o-z)
4589       include 'DIMENSIONS'
4590       include 'COMMON.SBRIDGE'
4591       include 'COMMON.CHAIN'
4592       include 'COMMON.DERIV'
4593       include 'COMMON.VAR'
4594       include 'COMMON.INTERACT'
4595       include 'COMMON.IOUNITS'
4596       dimension ggg(3)
4597       ehpb=0.0D0
4598 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4599 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4600       if (link_end.eq.0) return
4601       do i=link_start,link_end
4602 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4603 C CA-CA distance used in regularization of structure.
4604         ii=ihpb(i)
4605         jj=jhpb(i)
4606 C iii and jjj point to the residues for which the distance is assigned.
4607         if (ii.gt.nres) then
4608           iii=ii-nres
4609           jjj=jj-nres
4610         else
4611           iii=ii
4612           jjj=jj
4613         endif
4614 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4615 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4616 C    distance and angle dependent SS bond potential.
4617         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4618      & iabs(itype(jjj)).eq.1) then
4619           call ssbond_ene(iii,jjj,eij)
4620           ehpb=ehpb+2*eij
4621 cd          write (iout,*) "eij",eij
4622         else
4623 C Calculate the distance between the two points and its difference from the
4624 C target distance.
4625         dd=dist(ii,jj)
4626         rdis=dd-dhpb(i)
4627 C Get the force constant corresponding to this distance.
4628         waga=forcon(i)
4629 C Calculate the contribution to energy.
4630         ehpb=ehpb+waga*rdis*rdis
4631 C
4632 C Evaluate gradient.
4633 C
4634         fac=waga*rdis/dd
4635 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4636 cd   &   ' waga=',waga,' fac=',fac
4637         do j=1,3
4638           ggg(j)=fac*(c(j,jj)-c(j,ii))
4639         enddo
4640 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4641 C If this is a SC-SC distance, we need to calculate the contributions to the
4642 C Cartesian gradient in the SC vectors (ghpbx).
4643         if (iii.lt.ii) then
4644           do j=1,3
4645             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4646             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4647           enddo
4648         endif
4649 cgrad        do j=iii,jjj-1
4650 cgrad          do k=1,3
4651 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4652 cgrad          enddo
4653 cgrad        enddo
4654         do k=1,3
4655           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4656           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4657         enddo
4658         endif
4659       enddo
4660       ehpb=0.5D0*ehpb
4661       return
4662       end
4663 C--------------------------------------------------------------------------
4664       subroutine ssbond_ene(i,j,eij)
4665 C
4666 C Calculate the distance and angle dependent SS-bond potential energy
4667 C using a free-energy function derived based on RHF/6-31G** ab initio
4668 C calculations of diethyl disulfide.
4669 C
4670 C A. Liwo and U. Kozlowska, 11/24/03
4671 C
4672       implicit real*8 (a-h,o-z)
4673       include 'DIMENSIONS'
4674       include 'COMMON.SBRIDGE'
4675       include 'COMMON.CHAIN'
4676       include 'COMMON.DERIV'
4677       include 'COMMON.LOCAL'
4678       include 'COMMON.INTERACT'
4679       include 'COMMON.VAR'
4680       include 'COMMON.IOUNITS'
4681       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4682       itypi=iabs(itype(i))
4683       xi=c(1,nres+i)
4684       yi=c(2,nres+i)
4685       zi=c(3,nres+i)
4686       dxi=dc_norm(1,nres+i)
4687       dyi=dc_norm(2,nres+i)
4688       dzi=dc_norm(3,nres+i)
4689 c      dsci_inv=dsc_inv(itypi)
4690       dsci_inv=vbld_inv(nres+i)
4691       itypj=iabs(itype(j))
4692 c      dscj_inv=dsc_inv(itypj)
4693       dscj_inv=vbld_inv(nres+j)
4694       xj=c(1,nres+j)-xi
4695       yj=c(2,nres+j)-yi
4696       zj=c(3,nres+j)-zi
4697       dxj=dc_norm(1,nres+j)
4698       dyj=dc_norm(2,nres+j)
4699       dzj=dc_norm(3,nres+j)
4700       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4701       rij=dsqrt(rrij)
4702       erij(1)=xj*rij
4703       erij(2)=yj*rij
4704       erij(3)=zj*rij
4705       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4706       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4707       om12=dxi*dxj+dyi*dyj+dzi*dzj
4708       do k=1,3
4709         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4710         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4711       enddo
4712       rij=1.0d0/rij
4713       deltad=rij-d0cm
4714       deltat1=1.0d0-om1
4715       deltat2=1.0d0+om2
4716       deltat12=om2-om1+2.0d0
4717       cosphi=om12-om1*om2
4718       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4719      &  +akct*deltad*deltat12
4720      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4721 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4722 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4723 c     &  " deltat12",deltat12," eij",eij
4724       ed=2*akcm*deltad+akct*deltat12
4725       pom1=akct*deltad
4726       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4727       eom1=-2*akth*deltat1-pom1-om2*pom2
4728       eom2= 2*akth*deltat2+pom1-om1*pom2
4729       eom12=pom2
4730       do k=1,3
4731         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4732         ghpbx(k,i)=ghpbx(k,i)-ggk
4733      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4734      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4735         ghpbx(k,j)=ghpbx(k,j)+ggk
4736      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4737      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4738         ghpbc(k,i)=ghpbc(k,i)-ggk
4739         ghpbc(k,j)=ghpbc(k,j)+ggk
4740       enddo
4741 C
4742 C Calculate the components of the gradient in DC and X
4743 C
4744 cgrad      do k=i,j-1
4745 cgrad        do l=1,3
4746 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4747 cgrad        enddo
4748 cgrad      enddo
4749       return
4750       end
4751 C--------------------------------------------------------------------------
4752       subroutine ebond(estr)
4753 c
4754 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4755 c
4756       implicit real*8 (a-h,o-z)
4757       include 'DIMENSIONS'
4758       include 'COMMON.LOCAL'
4759       include 'COMMON.GEO'
4760       include 'COMMON.INTERACT'
4761       include 'COMMON.DERIV'
4762       include 'COMMON.VAR'
4763       include 'COMMON.CHAIN'
4764       include 'COMMON.IOUNITS'
4765       include 'COMMON.NAMES'
4766       include 'COMMON.FFIELD'
4767       include 'COMMON.CONTROL'
4768       include 'COMMON.SETUP'
4769       double precision u(3),ud(3)
4770       estr=0.0d0
4771       estr1=0.0d0
4772       do i=ibondp_start,ibondp_end
4773         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4774 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4775 c          do j=1,3
4776 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4777 c     &      *dc(j,i-1)/vbld(i)
4778 c          enddo
4779 c          if (energy_dec) write(iout,*)
4780 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4781 c        else
4782 C       Checking if it involves dummy (NH3+ or COO-) group
4783          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4784 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4785         diff = vbld(i)-vbldpDUM
4786          else
4787 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4788         diff = vbld(i)-vbldp0
4789          endif
4790         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4791      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4792         estr=estr+diff*diff
4793         do j=1,3
4794           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4795         enddo
4796 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4797 c        endif
4798       enddo
4799       estr=0.5d0*AKP*estr+estr1
4800 c
4801 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4802 c
4803       do i=ibond_start,ibond_end
4804         iti=iabs(itype(i))
4805         if (iti.ne.10 .and. iti.ne.ntyp1) then
4806           nbi=nbondterm(iti)
4807           if (nbi.eq.1) then
4808             diff=vbld(i+nres)-vbldsc0(1,iti)
4809             if (energy_dec) write (iout,*)
4810      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4811      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4812             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4813             do j=1,3
4814               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4815             enddo
4816           else
4817             do j=1,nbi
4818               diff=vbld(i+nres)-vbldsc0(j,iti)
4819               ud(j)=aksc(j,iti)*diff
4820               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4821             enddo
4822             uprod=u(1)
4823             do j=2,nbi
4824               uprod=uprod*u(j)
4825             enddo
4826             usum=0.0d0
4827             usumsqder=0.0d0
4828             do j=1,nbi
4829               uprod1=1.0d0
4830               uprod2=1.0d0
4831               do k=1,nbi
4832                 if (k.ne.j) then
4833                   uprod1=uprod1*u(k)
4834                   uprod2=uprod2*u(k)*u(k)
4835                 endif
4836               enddo
4837               usum=usum+uprod1
4838               usumsqder=usumsqder+ud(j)*uprod2
4839             enddo
4840             estr=estr+uprod/usum
4841             do j=1,3
4842              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4843             enddo
4844           endif
4845         endif
4846       enddo
4847       return
4848       end
4849 #ifdef CRYST_THETA
4850 C--------------------------------------------------------------------------
4851       subroutine ebend(etheta)
4852 C
4853 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4854 C angles gamma and its derivatives in consecutive thetas and gammas.
4855 C
4856       implicit real*8 (a-h,o-z)
4857       include 'DIMENSIONS'
4858       include 'COMMON.LOCAL'
4859       include 'COMMON.GEO'
4860       include 'COMMON.INTERACT'
4861       include 'COMMON.DERIV'
4862       include 'COMMON.VAR'
4863       include 'COMMON.CHAIN'
4864       include 'COMMON.IOUNITS'
4865       include 'COMMON.NAMES'
4866       include 'COMMON.FFIELD'
4867       include 'COMMON.CONTROL'
4868       common /calcthet/ term1,term2,termm,diffak,ratak,
4869      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4870      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4871       double precision y(2),z(2)
4872       delta=0.02d0*pi
4873 c      time11=dexp(-2*time)
4874 c      time12=1.0d0
4875       etheta=0.0D0
4876 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4877       do i=ithet_start,ithet_end
4878         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4879      &  .or.itype(i).eq.ntyp1) cycle
4880 C Zero the energy function and its derivative at 0 or pi.
4881         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4882         it=itype(i-1)
4883         ichir1=isign(1,itype(i-2))
4884         ichir2=isign(1,itype(i))
4885          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4886          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4887          if (itype(i-1).eq.10) then
4888           itype1=isign(10,itype(i-2))
4889           ichir11=isign(1,itype(i-2))
4890           ichir12=isign(1,itype(i-2))
4891           itype2=isign(10,itype(i))
4892           ichir21=isign(1,itype(i))
4893           ichir22=isign(1,itype(i))
4894          endif
4895
4896         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4897 #ifdef OSF
4898           phii=phi(i)
4899           if (phii.ne.phii) phii=150.0
4900 #else
4901           phii=phi(i)
4902 #endif
4903           y(1)=dcos(phii)
4904           y(2)=dsin(phii)
4905         else
4906           y(1)=0.0D0
4907           y(2)=0.0D0
4908         endif
4909         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4910 #ifdef OSF
4911           phii1=phi(i+1)
4912           if (phii1.ne.phii1) phii1=150.0
4913           phii1=pinorm(phii1)
4914           z(1)=cos(phii1)
4915 #else
4916           phii1=phi(i+1)
4917 #endif
4918           z(1)=dcos(phii1)
4919           z(2)=dsin(phii1)
4920         else
4921           z(1)=0.0D0
4922           z(2)=0.0D0
4923         endif
4924 C Calculate the "mean" value of theta from the part of the distribution
4925 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4926 C In following comments this theta will be referred to as t_c.
4927         thet_pred_mean=0.0d0
4928         do k=1,2
4929             athetk=athet(k,it,ichir1,ichir2)
4930             bthetk=bthet(k,it,ichir1,ichir2)
4931           if (it.eq.10) then
4932              athetk=athet(k,itype1,ichir11,ichir12)
4933              bthetk=bthet(k,itype2,ichir21,ichir22)
4934           endif
4935          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4936 c         write(iout,*) 'chuj tu', y(k),z(k)
4937         enddo
4938         dthett=thet_pred_mean*ssd
4939         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4940 C Derivatives of the "mean" values in gamma1 and gamma2.
4941         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4942      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4943          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4944      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4945          if (it.eq.10) then
4946       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4947      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4948         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4949      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4950          endif
4951         if (theta(i).gt.pi-delta) then
4952           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4953      &         E_tc0)
4954           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4955           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4956           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4957      &        E_theta)
4958           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4959      &        E_tc)
4960         else if (theta(i).lt.delta) then
4961           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4962           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4963           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4964      &        E_theta)
4965           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4966           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4967      &        E_tc)
4968         else
4969           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4970      &        E_theta,E_tc)
4971         endif
4972         etheta=etheta+ethetai
4973         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4974      &      'ebend',i,ethetai,theta(i),itype(i)
4975         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4976         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4977         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4978       enddo
4979 C Ufff.... We've done all this!!!
4980       return
4981       end
4982 C---------------------------------------------------------------------------
4983       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4984      &     E_tc)
4985       implicit real*8 (a-h,o-z)
4986       include 'DIMENSIONS'
4987       include 'COMMON.LOCAL'
4988       include 'COMMON.IOUNITS'
4989       common /calcthet/ term1,term2,termm,diffak,ratak,
4990      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4991      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4992 C Calculate the contributions to both Gaussian lobes.
4993 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4994 C The "polynomial part" of the "standard deviation" of this part of
4995 C the distributioni.
4996 ccc        write (iout,*) thetai,thet_pred_mean
4997         sig=polthet(3,it)
4998         do j=2,0,-1
4999           sig=sig*thet_pred_mean+polthet(j,it)
5000         enddo
5001 C Derivative of the "interior part" of the "standard deviation of the"
5002 C gamma-dependent Gaussian lobe in t_c.
5003         sigtc=3*polthet(3,it)
5004         do j=2,1,-1
5005           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5006         enddo
5007         sigtc=sig*sigtc
5008 C Set the parameters of both Gaussian lobes of the distribution.
5009 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5010         fac=sig*sig+sigc0(it)
5011         sigcsq=fac+fac
5012         sigc=1.0D0/sigcsq
5013 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5014         sigsqtc=-4.0D0*sigcsq*sigtc
5015 c       print *,i,sig,sigtc,sigsqtc
5016 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5017         sigtc=-sigtc/(fac*fac)
5018 C Following variable is sigma(t_c)**(-2)
5019         sigcsq=sigcsq*sigcsq
5020         sig0i=sig0(it)
5021         sig0inv=1.0D0/sig0i**2
5022         delthec=thetai-thet_pred_mean
5023         delthe0=thetai-theta0i
5024         term1=-0.5D0*sigcsq*delthec*delthec
5025         term2=-0.5D0*sig0inv*delthe0*delthe0
5026 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5027 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5028 C NaNs in taking the logarithm. We extract the largest exponent which is added
5029 C to the energy (this being the log of the distribution) at the end of energy
5030 C term evaluation for this virtual-bond angle.
5031         if (term1.gt.term2) then
5032           termm=term1
5033           term2=dexp(term2-termm)
5034           term1=1.0d0
5035         else
5036           termm=term2
5037           term1=dexp(term1-termm)
5038           term2=1.0d0
5039         endif
5040 C The ratio between the gamma-independent and gamma-dependent lobes of
5041 C the distribution is a Gaussian function of thet_pred_mean too.
5042         diffak=gthet(2,it)-thet_pred_mean
5043         ratak=diffak/gthet(3,it)**2
5044         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5045 C Let's differentiate it in thet_pred_mean NOW.
5046         aktc=ak*ratak
5047 C Now put together the distribution terms to make complete distribution.
5048         termexp=term1+ak*term2
5049         termpre=sigc+ak*sig0i
5050 C Contribution of the bending energy from this theta is just the -log of
5051 C the sum of the contributions from the two lobes and the pre-exponential
5052 C factor. Simple enough, isn't it?
5053         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5054 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5055 C NOW the derivatives!!!
5056 C 6/6/97 Take into account the deformation.
5057         E_theta=(delthec*sigcsq*term1
5058      &       +ak*delthe0*sig0inv*term2)/termexp
5059         E_tc=((sigtc+aktc*sig0i)/termpre
5060      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5061      &       aktc*term2)/termexp)
5062       return
5063       end
5064 c-----------------------------------------------------------------------------
5065       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5066       implicit real*8 (a-h,o-z)
5067       include 'DIMENSIONS'
5068       include 'COMMON.LOCAL'
5069       include 'COMMON.IOUNITS'
5070       common /calcthet/ term1,term2,termm,diffak,ratak,
5071      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5072      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5073       delthec=thetai-thet_pred_mean
5074       delthe0=thetai-theta0i
5075 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5076       t3 = thetai-thet_pred_mean
5077       t6 = t3**2
5078       t9 = term1
5079       t12 = t3*sigcsq
5080       t14 = t12+t6*sigsqtc
5081       t16 = 1.0d0
5082       t21 = thetai-theta0i
5083       t23 = t21**2
5084       t26 = term2
5085       t27 = t21*t26
5086       t32 = termexp
5087       t40 = t32**2
5088       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5089      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5090      & *(-t12*t9-ak*sig0inv*t27)
5091       return
5092       end
5093 #else
5094 C--------------------------------------------------------------------------
5095       subroutine ebend(etheta)
5096 C
5097 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5098 C angles gamma and its derivatives in consecutive thetas and gammas.
5099 C ab initio-derived potentials from
5100 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5101 C
5102       implicit real*8 (a-h,o-z)
5103       include 'DIMENSIONS'
5104       include 'COMMON.LOCAL'
5105       include 'COMMON.GEO'
5106       include 'COMMON.INTERACT'
5107       include 'COMMON.DERIV'
5108       include 'COMMON.VAR'
5109       include 'COMMON.CHAIN'
5110       include 'COMMON.IOUNITS'
5111       include 'COMMON.NAMES'
5112       include 'COMMON.FFIELD'
5113       include 'COMMON.CONTROL'
5114       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5115      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5116      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5117      & sinph1ph2(maxdouble,maxdouble)
5118       logical lprn /.false./, lprn1 /.false./
5119       etheta=0.0D0
5120       do i=ithet_start,ithet_end
5121 c        print *,i,itype(i-1),itype(i),itype(i-2)
5122         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5123      &  .or.itype(i).eq.ntyp1) cycle
5124 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5125
5126         if (iabs(itype(i+1)).eq.20) iblock=2
5127         if (iabs(itype(i+1)).ne.20) iblock=1
5128         dethetai=0.0d0
5129         dephii=0.0d0
5130         dephii1=0.0d0
5131         theti2=0.5d0*theta(i)
5132         ityp2=ithetyp((itype(i-1)))
5133         do k=1,nntheterm
5134           coskt(k)=dcos(k*theti2)
5135           sinkt(k)=dsin(k*theti2)
5136         enddo
5137         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5138 #ifdef OSF
5139           phii=phi(i)
5140           if (phii.ne.phii) phii=150.0
5141 #else
5142           phii=phi(i)
5143 #endif
5144           ityp1=ithetyp((itype(i-2)))
5145 C propagation of chirality for glycine type
5146           do k=1,nsingle
5147             cosph1(k)=dcos(k*phii)
5148             sinph1(k)=dsin(k*phii)
5149           enddo
5150         else
5151           phii=0.0d0
5152           ityp1=nthetyp+1
5153           do k=1,nsingle
5154             cosph1(k)=0.0d0
5155             sinph1(k)=0.0d0
5156           enddo
5157         endif
5158         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5159 #ifdef OSF
5160           phii1=phi(i+1)
5161           if (phii1.ne.phii1) phii1=150.0
5162           phii1=pinorm(phii1)
5163 #else
5164           phii1=phi(i+1)
5165 #endif
5166           ityp3=ithetyp((itype(i)))
5167           do k=1,nsingle
5168             cosph2(k)=dcos(k*phii1)
5169             sinph2(k)=dsin(k*phii1)
5170           enddo
5171         else
5172           phii1=0.0d0
5173           ityp3=nthetyp+1
5174           do k=1,nsingle
5175             cosph2(k)=0.0d0
5176             sinph2(k)=0.0d0
5177           enddo
5178         endif
5179         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5180         do k=1,ndouble
5181           do l=1,k-1
5182             ccl=cosph1(l)*cosph2(k-l)
5183             ssl=sinph1(l)*sinph2(k-l)
5184             scl=sinph1(l)*cosph2(k-l)
5185             csl=cosph1(l)*sinph2(k-l)
5186             cosph1ph2(l,k)=ccl-ssl
5187             cosph1ph2(k,l)=ccl+ssl
5188             sinph1ph2(l,k)=scl+csl
5189             sinph1ph2(k,l)=scl-csl
5190           enddo
5191         enddo
5192         if (lprn) then
5193         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5194      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5195         write (iout,*) "coskt and sinkt"
5196         do k=1,nntheterm
5197           write (iout,*) k,coskt(k),sinkt(k)
5198         enddo
5199         endif
5200         do k=1,ntheterm
5201           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5202           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5203      &      *coskt(k)
5204           if (lprn)
5205      &    write (iout,*) "k",k,"
5206      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5207      &     " ethetai",ethetai
5208         enddo
5209         if (lprn) then
5210         write (iout,*) "cosph and sinph"
5211         do k=1,nsingle
5212           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5213         enddo
5214         write (iout,*) "cosph1ph2 and sinph2ph2"
5215         do k=2,ndouble
5216           do l=1,k-1
5217             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5218      &         sinph1ph2(l,k),sinph1ph2(k,l)
5219           enddo
5220         enddo
5221         write(iout,*) "ethetai",ethetai
5222         endif
5223         do m=1,ntheterm2
5224           do k=1,nsingle
5225             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5226      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5227      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5228      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5229             ethetai=ethetai+sinkt(m)*aux
5230             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5231             dephii=dephii+k*sinkt(m)*(
5232      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5233      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5234             dephii1=dephii1+k*sinkt(m)*(
5235      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5236      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5237             if (lprn)
5238      &      write (iout,*) "m",m," k",k," bbthet",
5239      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5240      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5241      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5242      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5243           enddo
5244         enddo
5245         if (lprn)
5246      &  write(iout,*) "ethetai",ethetai
5247         do m=1,ntheterm3
5248           do k=2,ndouble
5249             do l=1,k-1
5250               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5251      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5252      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5253      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5254               ethetai=ethetai+sinkt(m)*aux
5255               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5256               dephii=dephii+l*sinkt(m)*(
5257      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5258      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5259      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5260      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5261               dephii1=dephii1+(k-l)*sinkt(m)*(
5262      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5263      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5264      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5265      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5266               if (lprn) then
5267               write (iout,*) "m",m," k",k," l",l," ffthet",
5268      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5269      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5270      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5271      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5272      &            " ethetai",ethetai
5273               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5274      &            cosph1ph2(k,l)*sinkt(m),
5275      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5276               endif
5277             enddo
5278           enddo
5279         enddo
5280 10      continue
5281 c        lprn1=.true.
5282         if (lprn1)
5283      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5284      &   i,theta(i)*rad2deg,phii*rad2deg,
5285      &   phii1*rad2deg,ethetai
5286 c        lprn1=.false.
5287         etheta=etheta+ethetai
5288         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5289         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5290         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5291       enddo
5292       return
5293       end
5294 #endif
5295 #ifdef CRYST_SC
5296 c-----------------------------------------------------------------------------
5297       subroutine esc(escloc)
5298 C Calculate the local energy of a side chain and its derivatives in the
5299 C corresponding virtual-bond valence angles THETA and the spherical angles
5300 C ALPHA and OMEGA.
5301       implicit real*8 (a-h,o-z)
5302       include 'DIMENSIONS'
5303       include 'COMMON.GEO'
5304       include 'COMMON.LOCAL'
5305       include 'COMMON.VAR'
5306       include 'COMMON.INTERACT'
5307       include 'COMMON.DERIV'
5308       include 'COMMON.CHAIN'
5309       include 'COMMON.IOUNITS'
5310       include 'COMMON.NAMES'
5311       include 'COMMON.FFIELD'
5312       include 'COMMON.CONTROL'
5313       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5314      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5315       common /sccalc/ time11,time12,time112,theti,it,nlobit
5316       delta=0.02d0*pi
5317       escloc=0.0D0
5318 c     write (iout,'(a)') 'ESC'
5319       do i=loc_start,loc_end
5320         it=itype(i)
5321         if (it.eq.ntyp1) cycle
5322         if (it.eq.10) goto 1
5323         nlobit=nlob(iabs(it))
5324 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5325 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5326         theti=theta(i+1)-pipol
5327         x(1)=dtan(theti)
5328         x(2)=alph(i)
5329         x(3)=omeg(i)
5330
5331         if (x(2).gt.pi-delta) then
5332           xtemp(1)=x(1)
5333           xtemp(2)=pi-delta
5334           xtemp(3)=x(3)
5335           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5336           xtemp(2)=pi
5337           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5338           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5339      &        escloci,dersc(2))
5340           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5341      &        ddersc0(1),dersc(1))
5342           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5343      &        ddersc0(3),dersc(3))
5344           xtemp(2)=pi-delta
5345           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5346           xtemp(2)=pi
5347           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5348           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5349      &            dersc0(2),esclocbi,dersc02)
5350           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5351      &            dersc12,dersc01)
5352           call splinthet(x(2),0.5d0*delta,ss,ssd)
5353           dersc0(1)=dersc01
5354           dersc0(2)=dersc02
5355           dersc0(3)=0.0d0
5356           do k=1,3
5357             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5358           enddo
5359           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5360 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5361 c    &             esclocbi,ss,ssd
5362           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5363 c         escloci=esclocbi
5364 c         write (iout,*) escloci
5365         else if (x(2).lt.delta) then
5366           xtemp(1)=x(1)
5367           xtemp(2)=delta
5368           xtemp(3)=x(3)
5369           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5370           xtemp(2)=0.0d0
5371           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5372           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5373      &        escloci,dersc(2))
5374           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5375      &        ddersc0(1),dersc(1))
5376           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5377      &        ddersc0(3),dersc(3))
5378           xtemp(2)=delta
5379           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5380           xtemp(2)=0.0d0
5381           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5382           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5383      &            dersc0(2),esclocbi,dersc02)
5384           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5385      &            dersc12,dersc01)
5386           dersc0(1)=dersc01
5387           dersc0(2)=dersc02
5388           dersc0(3)=0.0d0
5389           call splinthet(x(2),0.5d0*delta,ss,ssd)
5390           do k=1,3
5391             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5392           enddo
5393           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5394 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5395 c    &             esclocbi,ss,ssd
5396           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5397 c         write (iout,*) escloci
5398         else
5399           call enesc(x,escloci,dersc,ddummy,.false.)
5400         endif
5401
5402         escloc=escloc+escloci
5403         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5404      &     'escloc',i,escloci
5405 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5406
5407         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5408      &   wscloc*dersc(1)
5409         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5410         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5411     1   continue
5412       enddo
5413       return
5414       end
5415 C---------------------------------------------------------------------------
5416       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5417       implicit real*8 (a-h,o-z)
5418       include 'DIMENSIONS'
5419       include 'COMMON.GEO'
5420       include 'COMMON.LOCAL'
5421       include 'COMMON.IOUNITS'
5422       common /sccalc/ time11,time12,time112,theti,it,nlobit
5423       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5424       double precision contr(maxlob,-1:1)
5425       logical mixed
5426 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5427         escloc_i=0.0D0
5428         do j=1,3
5429           dersc(j)=0.0D0
5430           if (mixed) ddersc(j)=0.0d0
5431         enddo
5432         x3=x(3)
5433
5434 C Because of periodicity of the dependence of the SC energy in omega we have
5435 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5436 C To avoid underflows, first compute & store the exponents.
5437
5438         do iii=-1,1
5439
5440           x(3)=x3+iii*dwapi
5441
5442           do j=1,nlobit
5443             do k=1,3
5444               z(k)=x(k)-censc(k,j,it)
5445             enddo
5446             do k=1,3
5447               Axk=0.0D0
5448               do l=1,3
5449                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5450               enddo
5451               Ax(k,j,iii)=Axk
5452             enddo
5453             expfac=0.0D0
5454             do k=1,3
5455               expfac=expfac+Ax(k,j,iii)*z(k)
5456             enddo
5457             contr(j,iii)=expfac
5458           enddo ! j
5459
5460         enddo ! iii
5461
5462         x(3)=x3
5463 C As in the case of ebend, we want to avoid underflows in exponentiation and
5464 C subsequent NaNs and INFs in energy calculation.
5465 C Find the largest exponent
5466         emin=contr(1,-1)
5467         do iii=-1,1
5468           do j=1,nlobit
5469             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5470           enddo
5471         enddo
5472         emin=0.5D0*emin
5473 cd      print *,'it=',it,' emin=',emin
5474
5475 C Compute the contribution to SC energy and derivatives
5476         do iii=-1,1
5477
5478           do j=1,nlobit
5479 #ifdef OSF
5480             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5481             if(adexp.ne.adexp) adexp=1.0
5482             expfac=dexp(adexp)
5483 #else
5484             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5485 #endif
5486 cd          print *,'j=',j,' expfac=',expfac
5487             escloc_i=escloc_i+expfac
5488             do k=1,3
5489               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5490             enddo
5491             if (mixed) then
5492               do k=1,3,2
5493                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5494      &            +gaussc(k,2,j,it))*expfac
5495               enddo
5496             endif
5497           enddo
5498
5499         enddo ! iii
5500
5501         dersc(1)=dersc(1)/cos(theti)**2
5502         ddersc(1)=ddersc(1)/cos(theti)**2
5503         ddersc(3)=ddersc(3)
5504
5505         escloci=-(dlog(escloc_i)-emin)
5506         do j=1,3
5507           dersc(j)=dersc(j)/escloc_i
5508         enddo
5509         if (mixed) then
5510           do j=1,3,2
5511             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5512           enddo
5513         endif
5514       return
5515       end
5516 C------------------------------------------------------------------------------
5517       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5518       implicit real*8 (a-h,o-z)
5519       include 'DIMENSIONS'
5520       include 'COMMON.GEO'
5521       include 'COMMON.LOCAL'
5522       include 'COMMON.IOUNITS'
5523       common /sccalc/ time11,time12,time112,theti,it,nlobit
5524       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5525       double precision contr(maxlob)
5526       logical mixed
5527
5528       escloc_i=0.0D0
5529
5530       do j=1,3
5531         dersc(j)=0.0D0
5532       enddo
5533
5534       do j=1,nlobit
5535         do k=1,2
5536           z(k)=x(k)-censc(k,j,it)
5537         enddo
5538         z(3)=dwapi
5539         do k=1,3
5540           Axk=0.0D0
5541           do l=1,3
5542             Axk=Axk+gaussc(l,k,j,it)*z(l)
5543           enddo
5544           Ax(k,j)=Axk
5545         enddo
5546         expfac=0.0D0
5547         do k=1,3
5548           expfac=expfac+Ax(k,j)*z(k)
5549         enddo
5550         contr(j)=expfac
5551       enddo ! j
5552
5553 C As in the case of ebend, we want to avoid underflows in exponentiation and
5554 C subsequent NaNs and INFs in energy calculation.
5555 C Find the largest exponent
5556       emin=contr(1)
5557       do j=1,nlobit
5558         if (emin.gt.contr(j)) emin=contr(j)
5559       enddo
5560       emin=0.5D0*emin
5561
5562 C Compute the contribution to SC energy and derivatives
5563
5564       dersc12=0.0d0
5565       do j=1,nlobit
5566         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5567         escloc_i=escloc_i+expfac
5568         do k=1,2
5569           dersc(k)=dersc(k)+Ax(k,j)*expfac
5570         enddo
5571         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5572      &            +gaussc(1,2,j,it))*expfac
5573         dersc(3)=0.0d0
5574       enddo
5575
5576       dersc(1)=dersc(1)/cos(theti)**2
5577       dersc12=dersc12/cos(theti)**2
5578       escloci=-(dlog(escloc_i)-emin)
5579       do j=1,2
5580         dersc(j)=dersc(j)/escloc_i
5581       enddo
5582       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5583       return
5584       end
5585 #else
5586 c----------------------------------------------------------------------------------
5587       subroutine esc(escloc)
5588 C Calculate the local energy of a side chain and its derivatives in the
5589 C corresponding virtual-bond valence angles THETA and the spherical angles
5590 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5591 C added by Urszula Kozlowska. 07/11/2007
5592 C
5593       implicit real*8 (a-h,o-z)
5594       include 'DIMENSIONS'
5595       include 'COMMON.GEO'
5596       include 'COMMON.LOCAL'
5597       include 'COMMON.VAR'
5598       include 'COMMON.SCROT'
5599       include 'COMMON.INTERACT'
5600       include 'COMMON.DERIV'
5601       include 'COMMON.CHAIN'
5602       include 'COMMON.IOUNITS'
5603       include 'COMMON.NAMES'
5604       include 'COMMON.FFIELD'
5605       include 'COMMON.CONTROL'
5606       include 'COMMON.VECTORS'
5607       double precision x_prime(3),y_prime(3),z_prime(3)
5608      &    , sumene,dsc_i,dp2_i,x(65),
5609      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5610      &    de_dxx,de_dyy,de_dzz,de_dt
5611       double precision s1_t,s1_6_t,s2_t,s2_6_t
5612       double precision
5613      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5614      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5615      & dt_dCi(3),dt_dCi1(3)
5616       common /sccalc/ time11,time12,time112,theti,it,nlobit
5617       delta=0.02d0*pi
5618       escloc=0.0D0
5619       do i=loc_start,loc_end
5620         if (itype(i).eq.ntyp1) cycle
5621         costtab(i+1) =dcos(theta(i+1))
5622         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5623         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5624         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5625         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5626         cosfac=dsqrt(cosfac2)
5627         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5628         sinfac=dsqrt(sinfac2)
5629         it=iabs(itype(i))
5630         if (it.eq.10) goto 1
5631 c
5632 C  Compute the axes of tghe local cartesian coordinates system; store in
5633 c   x_prime, y_prime and z_prime
5634 c
5635         do j=1,3
5636           x_prime(j) = 0.00
5637           y_prime(j) = 0.00
5638           z_prime(j) = 0.00
5639         enddo
5640 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5641 C     &   dc_norm(3,i+nres)
5642         do j = 1,3
5643           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5644           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5645         enddo
5646         do j = 1,3
5647           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5648         enddo
5649 c       write (2,*) "i",i
5650 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5651 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5652 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5653 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5654 c      & " xy",scalar(x_prime(1),y_prime(1)),
5655 c      & " xz",scalar(x_prime(1),z_prime(1)),
5656 c      & " yy",scalar(y_prime(1),y_prime(1)),
5657 c      & " yz",scalar(y_prime(1),z_prime(1)),
5658 c      & " zz",scalar(z_prime(1),z_prime(1))
5659 c
5660 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5661 C to local coordinate system. Store in xx, yy, zz.
5662 c
5663         xx=0.0d0
5664         yy=0.0d0
5665         zz=0.0d0
5666         do j = 1,3
5667           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5668           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5669           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5670         enddo
5671
5672         xxtab(i)=xx
5673         yytab(i)=yy
5674         zztab(i)=zz
5675 C
5676 C Compute the energy of the ith side cbain
5677 C
5678 c        write (2,*) "xx",xx," yy",yy," zz",zz
5679         it=iabs(itype(i))
5680         do j = 1,65
5681           x(j) = sc_parmin(j,it)
5682         enddo
5683 #ifdef CHECK_COORD
5684 Cc diagnostics - remove later
5685         xx1 = dcos(alph(2))
5686         yy1 = dsin(alph(2))*dcos(omeg(2))
5687         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5688         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5689      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5690      &    xx1,yy1,zz1
5691 C,"  --- ", xx_w,yy_w,zz_w
5692 c end diagnostics
5693 #endif
5694         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5695      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5696      &   + x(10)*yy*zz
5697         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5698      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5699      & + x(20)*yy*zz
5700         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5701      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5702      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5703      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5704      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5705      &  +x(40)*xx*yy*zz
5706         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5707      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5708      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5709      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5710      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5711      &  +x(60)*xx*yy*zz
5712         dsc_i   = 0.743d0+x(61)
5713         dp2_i   = 1.9d0+x(62)
5714         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5715      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5716         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5717      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5718         s1=(1+x(63))/(0.1d0 + dscp1)
5719         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5720         s2=(1+x(65))/(0.1d0 + dscp2)
5721         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5722         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5723      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5724 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5725 c     &   sumene4,
5726 c     &   dscp1,dscp2,sumene
5727 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5728         escloc = escloc + sumene
5729 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5730 c     & ,zz,xx,yy
5731 c#define DEBUG
5732 #ifdef DEBUG
5733 C
5734 C This section to check the numerical derivatives of the energy of ith side
5735 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5736 C #define DEBUG in the code to turn it on.
5737 C
5738         write (2,*) "sumene               =",sumene
5739         aincr=1.0d-7
5740         xxsave=xx
5741         xx=xx+aincr
5742         write (2,*) xx,yy,zz
5743         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5744         de_dxx_num=(sumenep-sumene)/aincr
5745         xx=xxsave
5746         write (2,*) "xx+ sumene from enesc=",sumenep
5747         yysave=yy
5748         yy=yy+aincr
5749         write (2,*) xx,yy,zz
5750         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5751         de_dyy_num=(sumenep-sumene)/aincr
5752         yy=yysave
5753         write (2,*) "yy+ sumene from enesc=",sumenep
5754         zzsave=zz
5755         zz=zz+aincr
5756         write (2,*) xx,yy,zz
5757         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5758         de_dzz_num=(sumenep-sumene)/aincr
5759         zz=zzsave
5760         write (2,*) "zz+ sumene from enesc=",sumenep
5761         costsave=cost2tab(i+1)
5762         sintsave=sint2tab(i+1)
5763         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5764         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5765         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5766         de_dt_num=(sumenep-sumene)/aincr
5767         write (2,*) " t+ sumene from enesc=",sumenep
5768         cost2tab(i+1)=costsave
5769         sint2tab(i+1)=sintsave
5770 C End of diagnostics section.
5771 #endif
5772 C
5773 C Compute the gradient of esc
5774 C
5775 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5776         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5777         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5778         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5779         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5780         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5781         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5782         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5783         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5784         pom1=(sumene3*sint2tab(i+1)+sumene1)
5785      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5786         pom2=(sumene4*cost2tab(i+1)+sumene2)
5787      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5788         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5789         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5790      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5791      &  +x(40)*yy*zz
5792         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5793         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5794      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5795      &  +x(60)*yy*zz
5796         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5797      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5798      &        +(pom1+pom2)*pom_dx
5799 #ifdef DEBUG
5800         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5801 #endif
5802 C
5803         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5804         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5805      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5806      &  +x(40)*xx*zz
5807         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5808         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5809      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5810      &  +x(59)*zz**2 +x(60)*xx*zz
5811         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5812      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5813      &        +(pom1-pom2)*pom_dy
5814 #ifdef DEBUG
5815         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5816 #endif
5817 C
5818         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5819      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5820      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5821      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5822      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5823      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5824      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5825      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5826 #ifdef DEBUG
5827         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5828 #endif
5829 C
5830         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5831      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5832      &  +pom1*pom_dt1+pom2*pom_dt2
5833 #ifdef DEBUG
5834         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5835 #endif
5836 c#undef DEBUG
5837 c
5838 C
5839        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5840        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5841        cosfac2xx=cosfac2*xx
5842        sinfac2yy=sinfac2*yy
5843        do k = 1,3
5844          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5845      &      vbld_inv(i+1)
5846          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5847      &      vbld_inv(i)
5848          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5849          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5850 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5851 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5852 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5853 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5854          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5855          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5856          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5857          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5858          dZZ_Ci1(k)=0.0d0
5859          dZZ_Ci(k)=0.0d0
5860          do j=1,3
5861            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5862      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5863            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5864      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5865          enddo
5866
5867          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5868          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5869          dZZ_XYZ(k)=vbld_inv(i+nres)*
5870      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5871 c
5872          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5873          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5874        enddo
5875
5876        do k=1,3
5877          dXX_Ctab(k,i)=dXX_Ci(k)
5878          dXX_C1tab(k,i)=dXX_Ci1(k)
5879          dYY_Ctab(k,i)=dYY_Ci(k)
5880          dYY_C1tab(k,i)=dYY_Ci1(k)
5881          dZZ_Ctab(k,i)=dZZ_Ci(k)
5882          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5883          dXX_XYZtab(k,i)=dXX_XYZ(k)
5884          dYY_XYZtab(k,i)=dYY_XYZ(k)
5885          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5886        enddo
5887
5888        do k = 1,3
5889 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5890 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5891 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5892 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5893 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5894 c     &    dt_dci(k)
5895 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5896 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5897          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5898      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5899          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5900      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5901          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5902      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5903        enddo
5904 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5905 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5906
5907 C to check gradient call subroutine check_grad
5908
5909     1 continue
5910       enddo
5911       return
5912       end
5913 c------------------------------------------------------------------------------
5914       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5915       implicit none
5916       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5917      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5918       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5919      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5920      &   + x(10)*yy*zz
5921       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5922      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5923      & + x(20)*yy*zz
5924       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5925      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5926      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5927      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5928      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5929      &  +x(40)*xx*yy*zz
5930       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5931      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5932      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5933      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5934      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5935      &  +x(60)*xx*yy*zz
5936       dsc_i   = 0.743d0+x(61)
5937       dp2_i   = 1.9d0+x(62)
5938       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5939      &          *(xx*cost2+yy*sint2))
5940       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5941      &          *(xx*cost2-yy*sint2))
5942       s1=(1+x(63))/(0.1d0 + dscp1)
5943       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5944       s2=(1+x(65))/(0.1d0 + dscp2)
5945       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5946       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5947      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5948       enesc=sumene
5949       return
5950       end
5951 #endif
5952 c------------------------------------------------------------------------------
5953       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5954 C
5955 C This procedure calculates two-body contact function g(rij) and its derivative:
5956 C
5957 C           eps0ij                                     !       x < -1
5958 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5959 C            0                                         !       x > 1
5960 C
5961 C where x=(rij-r0ij)/delta
5962 C
5963 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5964 C
5965       implicit none
5966       double precision rij,r0ij,eps0ij,fcont,fprimcont
5967       double precision x,x2,x4,delta
5968 c     delta=0.02D0*r0ij
5969 c      delta=0.2D0*r0ij
5970       x=(rij-r0ij)/delta
5971       if (x.lt.-1.0D0) then
5972         fcont=eps0ij
5973         fprimcont=0.0D0
5974       else if (x.le.1.0D0) then
5975         x2=x*x
5976         x4=x2*x2
5977         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5978         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5979       else
5980         fcont=0.0D0
5981         fprimcont=0.0D0
5982       endif
5983       return
5984       end
5985 c------------------------------------------------------------------------------
5986       subroutine splinthet(theti,delta,ss,ssder)
5987       implicit real*8 (a-h,o-z)
5988       include 'DIMENSIONS'
5989       include 'COMMON.VAR'
5990       include 'COMMON.GEO'
5991       thetup=pi-delta
5992       thetlow=delta
5993       if (theti.gt.pipol) then
5994         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5995       else
5996         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5997         ssder=-ssder
5998       endif
5999       return
6000       end
6001 c------------------------------------------------------------------------------
6002       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6003       implicit none
6004       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6005       double precision ksi,ksi2,ksi3,a1,a2,a3
6006       a1=fprim0*delta/(f1-f0)
6007       a2=3.0d0-2.0d0*a1
6008       a3=a1-2.0d0
6009       ksi=(x-x0)/delta
6010       ksi2=ksi*ksi
6011       ksi3=ksi2*ksi
6012       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6013       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6014       return
6015       end
6016 c------------------------------------------------------------------------------
6017       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6018       implicit none
6019       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6020       double precision ksi,ksi2,ksi3,a1,a2,a3
6021       ksi=(x-x0)/delta
6022       ksi2=ksi*ksi
6023       ksi3=ksi2*ksi
6024       a1=fprim0x*delta
6025       a2=3*(f1x-f0x)-2*fprim0x*delta
6026       a3=fprim0x*delta-2*(f1x-f0x)
6027       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6028       return
6029       end
6030 C-----------------------------------------------------------------------------
6031 #ifdef CRYST_TOR
6032 C-----------------------------------------------------------------------------
6033       subroutine etor(etors,edihcnstr)
6034       implicit real*8 (a-h,o-z)
6035       include 'DIMENSIONS'
6036       include 'COMMON.VAR'
6037       include 'COMMON.GEO'
6038       include 'COMMON.LOCAL'
6039       include 'COMMON.TORSION'
6040       include 'COMMON.INTERACT'
6041       include 'COMMON.DERIV'
6042       include 'COMMON.CHAIN'
6043       include 'COMMON.NAMES'
6044       include 'COMMON.IOUNITS'
6045       include 'COMMON.FFIELD'
6046       include 'COMMON.TORCNSTR'
6047       include 'COMMON.CONTROL'
6048       logical lprn
6049 C Set lprn=.true. for debugging
6050       lprn=.false.
6051 c      lprn=.true.
6052       etors=0.0D0
6053       do i=iphi_start,iphi_end
6054       etors_ii=0.0D0
6055         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6056      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6057         itori=itortyp(itype(i-2))
6058         itori1=itortyp(itype(i-1))
6059         phii=phi(i)
6060         gloci=0.0D0
6061 C Proline-Proline pair is a special case...
6062         if (itori.eq.3 .and. itori1.eq.3) then
6063           if (phii.gt.-dwapi3) then
6064             cosphi=dcos(3*phii)
6065             fac=1.0D0/(1.0D0-cosphi)
6066             etorsi=v1(1,3,3)*fac
6067             etorsi=etorsi+etorsi
6068             etors=etors+etorsi-v1(1,3,3)
6069             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6070             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6071           endif
6072           do j=1,3
6073             v1ij=v1(j+1,itori,itori1)
6074             v2ij=v2(j+1,itori,itori1)
6075             cosphi=dcos(j*phii)
6076             sinphi=dsin(j*phii)
6077             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6078             if (energy_dec) etors_ii=etors_ii+
6079      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6080             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6081           enddo
6082         else
6083           do j=1,nterm_old
6084             v1ij=v1(j,itori,itori1)
6085             v2ij=v2(j,itori,itori1)
6086             cosphi=dcos(j*phii)
6087             sinphi=dsin(j*phii)
6088             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6089             if (energy_dec) etors_ii=etors_ii+
6090      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6091             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6092           enddo
6093         endif
6094         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6095              'etor',i,etors_ii
6096         if (lprn)
6097      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6098      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6099      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6100         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6101 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6102       enddo
6103 ! 6/20/98 - dihedral angle constraints
6104       edihcnstr=0.0d0
6105       do i=1,ndih_constr
6106         itori=idih_constr(i)
6107         phii=phi(itori)
6108         difi=phii-phi0(i)
6109         if (difi.gt.drange(i)) then
6110           difi=difi-drange(i)
6111           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6112           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6113         else if (difi.lt.-drange(i)) then
6114           difi=difi+drange(i)
6115           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6116           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6117         endif
6118 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6119 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6120       enddo
6121 !      write (iout,*) 'edihcnstr',edihcnstr
6122       return
6123       end
6124 c------------------------------------------------------------------------------
6125       subroutine etor_d(etors_d)
6126       etors_d=0.0d0
6127       return
6128       end
6129 c----------------------------------------------------------------------------
6130 #else
6131       subroutine etor(etors,edihcnstr)
6132       implicit real*8 (a-h,o-z)
6133       include 'DIMENSIONS'
6134       include 'COMMON.VAR'
6135       include 'COMMON.GEO'
6136       include 'COMMON.LOCAL'
6137       include 'COMMON.TORSION'
6138       include 'COMMON.INTERACT'
6139       include 'COMMON.DERIV'
6140       include 'COMMON.CHAIN'
6141       include 'COMMON.NAMES'
6142       include 'COMMON.IOUNITS'
6143       include 'COMMON.FFIELD'
6144       include 'COMMON.TORCNSTR'
6145       include 'COMMON.CONTROL'
6146       logical lprn
6147 C Set lprn=.true. for debugging
6148       lprn=.false.
6149 c     lprn=.true.
6150       etors=0.0D0
6151       do i=iphi_start,iphi_end
6152 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6153 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6154 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6155 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6156         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6157      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6158 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6159 C For introducing the NH3+ and COO- group please check the etor_d for reference
6160 C and guidance
6161         etors_ii=0.0D0
6162          if (iabs(itype(i)).eq.20) then
6163          iblock=2
6164          else
6165          iblock=1
6166          endif
6167         itori=itortyp(itype(i-2))
6168         itori1=itortyp(itype(i-1))
6169         phii=phi(i)
6170         gloci=0.0D0
6171 C Regular cosine and sine terms
6172         do j=1,nterm(itori,itori1,iblock)
6173           v1ij=v1(j,itori,itori1,iblock)
6174           v2ij=v2(j,itori,itori1,iblock)
6175           cosphi=dcos(j*phii)
6176           sinphi=dsin(j*phii)
6177           etors=etors+v1ij*cosphi+v2ij*sinphi
6178           if (energy_dec) etors_ii=etors_ii+
6179      &                v1ij*cosphi+v2ij*sinphi
6180           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6181         enddo
6182 C Lorentz terms
6183 C                         v1
6184 C  E = SUM ----------------------------------- - v1
6185 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6186 C
6187         cosphi=dcos(0.5d0*phii)
6188         sinphi=dsin(0.5d0*phii)
6189         do j=1,nlor(itori,itori1,iblock)
6190           vl1ij=vlor1(j,itori,itori1)
6191           vl2ij=vlor2(j,itori,itori1)
6192           vl3ij=vlor3(j,itori,itori1)
6193           pom=vl2ij*cosphi+vl3ij*sinphi
6194           pom1=1.0d0/(pom*pom+1.0d0)
6195           etors=etors+vl1ij*pom1
6196           if (energy_dec) etors_ii=etors_ii+
6197      &                vl1ij*pom1
6198           pom=-pom*pom1*pom1
6199           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6200         enddo
6201 C Subtract the constant term
6202         etors=etors-v0(itori,itori1,iblock)
6203           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6204      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6205         if (lprn)
6206      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6207      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6208      &  (v1(j,itori,itori1,iblock),j=1,6),
6209      &  (v2(j,itori,itori1,iblock),j=1,6)
6210         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6211 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6212       enddo
6213 ! 6/20/98 - dihedral angle constraints
6214       edihcnstr=0.0d0
6215 c      do i=1,ndih_constr
6216       do i=idihconstr_start,idihconstr_end
6217         itori=idih_constr(i)
6218         phii=phi(itori)
6219         difi=pinorm(phii-phi0(i))
6220         if (difi.gt.drange(i)) then
6221           difi=difi-drange(i)
6222           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6223           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6224         else if (difi.lt.-drange(i)) then
6225           difi=difi+drange(i)
6226           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6227           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6228         else
6229           difi=0.0
6230         endif
6231 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6232 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6233 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6234       enddo
6235 cd       write (iout,*) 'edihcnstr',edihcnstr
6236       return
6237       end
6238 c----------------------------------------------------------------------------
6239       subroutine etor_d(etors_d)
6240 C 6/23/01 Compute double torsional energy
6241       implicit real*8 (a-h,o-z)
6242       include 'DIMENSIONS'
6243       include 'COMMON.VAR'
6244       include 'COMMON.GEO'
6245       include 'COMMON.LOCAL'
6246       include 'COMMON.TORSION'
6247       include 'COMMON.INTERACT'
6248       include 'COMMON.DERIV'
6249       include 'COMMON.CHAIN'
6250       include 'COMMON.NAMES'
6251       include 'COMMON.IOUNITS'
6252       include 'COMMON.FFIELD'
6253       include 'COMMON.TORCNSTR'
6254       logical lprn
6255 C Set lprn=.true. for debugging
6256       lprn=.false.
6257 c     lprn=.true.
6258       etors_d=0.0D0
6259 c      write(iout,*) "a tu??"
6260       do i=iphid_start,iphid_end
6261 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6262 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6263 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6264 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6265 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6266          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6267      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6268      &  (itype(i+1).eq.ntyp1)) cycle
6269 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6270         itori=itortyp(itype(i-2))
6271         itori1=itortyp(itype(i-1))
6272         itori2=itortyp(itype(i))
6273         phii=phi(i)
6274         phii1=phi(i+1)
6275         gloci1=0.0D0
6276         gloci2=0.0D0
6277         iblock=1
6278         if (iabs(itype(i+1)).eq.20) iblock=2
6279 C Iblock=2 Proline type
6280 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6281 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6282 C        if (itype(i+1).eq.ntyp1) iblock=3
6283 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6284 C IS or IS NOT need for this
6285 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6286 C        is (itype(i-3).eq.ntyp1) ntblock=2
6287 C        ntblock is N-terminal blocking group
6288
6289 C Regular cosine and sine terms
6290         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6291 C Example of changes for NH3+ blocking group
6292 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6293 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6294           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6295           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6296           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6297           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6298           cosphi1=dcos(j*phii)
6299           sinphi1=dsin(j*phii)
6300           cosphi2=dcos(j*phii1)
6301           sinphi2=dsin(j*phii1)
6302           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6303      &     v2cij*cosphi2+v2sij*sinphi2
6304           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6305           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6306         enddo
6307         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6308           do l=1,k-1
6309             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6310             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6311             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6312             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6313             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6314             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6315             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6316             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6317             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6318      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6319             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6320      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6321             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6322      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6323           enddo
6324         enddo
6325         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6326         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6327       enddo
6328       return
6329       end
6330 #endif
6331 c------------------------------------------------------------------------------
6332       subroutine eback_sc_corr(esccor)
6333 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6334 c        conformational states; temporarily implemented as differences
6335 c        between UNRES torsional potentials (dependent on three types of
6336 c        residues) and the torsional potentials dependent on all 20 types
6337 c        of residues computed from AM1  energy surfaces of terminally-blocked
6338 c        amino-acid residues.
6339       implicit real*8 (a-h,o-z)
6340       include 'DIMENSIONS'
6341       include 'COMMON.VAR'
6342       include 'COMMON.GEO'
6343       include 'COMMON.LOCAL'
6344       include 'COMMON.TORSION'
6345       include 'COMMON.SCCOR'
6346       include 'COMMON.INTERACT'
6347       include 'COMMON.DERIV'
6348       include 'COMMON.CHAIN'
6349       include 'COMMON.NAMES'
6350       include 'COMMON.IOUNITS'
6351       include 'COMMON.FFIELD'
6352       include 'COMMON.CONTROL'
6353       logical lprn
6354 C Set lprn=.true. for debugging
6355       lprn=.false.
6356 c      lprn=.true.
6357 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6358       esccor=0.0D0
6359       do i=itau_start,itau_end
6360         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6361         esccor_ii=0.0D0
6362         isccori=isccortyp(itype(i-2))
6363         isccori1=isccortyp(itype(i-1))
6364 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6365         phii=phi(i)
6366         do intertyp=1,3 !intertyp
6367 cc Added 09 May 2012 (Adasko)
6368 cc  Intertyp means interaction type of backbone mainchain correlation:
6369 c   1 = SC...Ca...Ca...Ca
6370 c   2 = Ca...Ca...Ca...SC
6371 c   3 = SC...Ca...Ca...SCi
6372         gloci=0.0D0
6373         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6374      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6375      &      (itype(i-1).eq.ntyp1)))
6376      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6377      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6378      &     .or.(itype(i).eq.ntyp1)))
6379      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6380      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6381      &      (itype(i-3).eq.ntyp1)))) cycle
6382         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6383         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6384      & cycle
6385        do j=1,nterm_sccor(isccori,isccori1)
6386           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6387           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6388           cosphi=dcos(j*tauangle(intertyp,i))
6389           sinphi=dsin(j*tauangle(intertyp,i))
6390           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6391           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6392         enddo
6393 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6394         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6395         if (lprn)
6396      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6397      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6398      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6399      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6400         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6401        enddo !intertyp
6402       enddo
6403
6404       return
6405       end
6406 c----------------------------------------------------------------------------
6407       subroutine multibody(ecorr)
6408 C This subroutine calculates multi-body contributions to energy following
6409 C the idea of Skolnick et al. If side chains I and J make a contact and
6410 C at the same time side chains I+1 and J+1 make a contact, an extra
6411 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6412       implicit real*8 (a-h,o-z)
6413       include 'DIMENSIONS'
6414       include 'COMMON.IOUNITS'
6415       include 'COMMON.DERIV'
6416       include 'COMMON.INTERACT'
6417       include 'COMMON.CONTACTS'
6418       double precision gx(3),gx1(3)
6419       logical lprn
6420
6421 C Set lprn=.true. for debugging
6422       lprn=.false.
6423
6424       if (lprn) then
6425         write (iout,'(a)') 'Contact function values:'
6426         do i=nnt,nct-2
6427           write (iout,'(i2,20(1x,i2,f10.5))')
6428      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6429         enddo
6430       endif
6431       ecorr=0.0D0
6432       do i=nnt,nct
6433         do j=1,3
6434           gradcorr(j,i)=0.0D0
6435           gradxorr(j,i)=0.0D0
6436         enddo
6437       enddo
6438       do i=nnt,nct-2
6439
6440         DO ISHIFT = 3,4
6441
6442         i1=i+ishift
6443         num_conti=num_cont(i)
6444         num_conti1=num_cont(i1)
6445         do jj=1,num_conti
6446           j=jcont(jj,i)
6447           do kk=1,num_conti1
6448             j1=jcont(kk,i1)
6449             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6450 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6451 cd   &                   ' ishift=',ishift
6452 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6453 C The system gains extra energy.
6454               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6455             endif   ! j1==j+-ishift
6456           enddo     ! kk
6457         enddo       ! jj
6458
6459         ENDDO ! ISHIFT
6460
6461       enddo         ! i
6462       return
6463       end
6464 c------------------------------------------------------------------------------
6465       double precision function esccorr(i,j,k,l,jj,kk)
6466       implicit real*8 (a-h,o-z)
6467       include 'DIMENSIONS'
6468       include 'COMMON.IOUNITS'
6469       include 'COMMON.DERIV'
6470       include 'COMMON.INTERACT'
6471       include 'COMMON.CONTACTS'
6472       double precision gx(3),gx1(3)
6473       logical lprn
6474       lprn=.false.
6475       eij=facont(jj,i)
6476       ekl=facont(kk,k)
6477 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6478 C Calculate the multi-body contribution to energy.
6479 C Calculate multi-body contributions to the gradient.
6480 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6481 cd   & k,l,(gacont(m,kk,k),m=1,3)
6482       do m=1,3
6483         gx(m) =ekl*gacont(m,jj,i)
6484         gx1(m)=eij*gacont(m,kk,k)
6485         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6486         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6487         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6488         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6489       enddo
6490       do m=i,j-1
6491         do ll=1,3
6492           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6493         enddo
6494       enddo
6495       do m=k,l-1
6496         do ll=1,3
6497           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6498         enddo
6499       enddo
6500       esccorr=-eij*ekl
6501       return
6502       end
6503 c------------------------------------------------------------------------------
6504       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6505 C This subroutine calculates multi-body contributions to hydrogen-bonding
6506       implicit real*8 (a-h,o-z)
6507       include 'DIMENSIONS'
6508       include 'COMMON.IOUNITS'
6509 #ifdef MPI
6510       include "mpif.h"
6511       parameter (max_cont=maxconts)
6512       parameter (max_dim=26)
6513       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6514       double precision zapas(max_dim,maxconts,max_fg_procs),
6515      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6516       common /przechowalnia/ zapas
6517       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6518      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6519 #endif
6520       include 'COMMON.SETUP'
6521       include 'COMMON.FFIELD'
6522       include 'COMMON.DERIV'
6523       include 'COMMON.INTERACT'
6524       include 'COMMON.CONTACTS'
6525       include 'COMMON.CONTROL'
6526       include 'COMMON.LOCAL'
6527       double precision gx(3),gx1(3),time00
6528       logical lprn,ldone
6529
6530 C Set lprn=.true. for debugging
6531       lprn=.false.
6532 #ifdef MPI
6533       n_corr=0
6534       n_corr1=0
6535       if (nfgtasks.le.1) goto 30
6536       if (lprn) then
6537         write (iout,'(a)') 'Contact function values before RECEIVE:'
6538         do i=nnt,nct-2
6539           write (iout,'(2i3,50(1x,i2,f5.2))')
6540      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6541      &    j=1,num_cont_hb(i))
6542         enddo
6543       endif
6544       call flush(iout)
6545       do i=1,ntask_cont_from
6546         ncont_recv(i)=0
6547       enddo
6548       do i=1,ntask_cont_to
6549         ncont_sent(i)=0
6550       enddo
6551 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6552 c     & ntask_cont_to
6553 C Make the list of contacts to send to send to other procesors
6554 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6555 c      call flush(iout)
6556       do i=iturn3_start,iturn3_end
6557 c        write (iout,*) "make contact list turn3",i," num_cont",
6558 c     &    num_cont_hb(i)
6559         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6560       enddo
6561       do i=iturn4_start,iturn4_end
6562 c        write (iout,*) "make contact list turn4",i," num_cont",
6563 c     &   num_cont_hb(i)
6564         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6565       enddo
6566       do ii=1,nat_sent
6567         i=iat_sent(ii)
6568 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6569 c     &    num_cont_hb(i)
6570         do j=1,num_cont_hb(i)
6571         do k=1,4
6572           jjc=jcont_hb(j,i)
6573           iproc=iint_sent_local(k,jjc,ii)
6574 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6575           if (iproc.gt.0) then
6576             ncont_sent(iproc)=ncont_sent(iproc)+1
6577             nn=ncont_sent(iproc)
6578             zapas(1,nn,iproc)=i
6579             zapas(2,nn,iproc)=jjc
6580             zapas(3,nn,iproc)=facont_hb(j,i)
6581             zapas(4,nn,iproc)=ees0p(j,i)
6582             zapas(5,nn,iproc)=ees0m(j,i)
6583             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6584             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6585             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6586             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6587             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6588             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6589             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6590             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6591             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6592             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6593             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6594             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6595             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6596             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6597             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6598             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6599             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6600             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6601             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6602             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6603             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6604           endif
6605         enddo
6606         enddo
6607       enddo
6608       if (lprn) then
6609       write (iout,*)
6610      &  "Numbers of contacts to be sent to other processors",
6611      &  (ncont_sent(i),i=1,ntask_cont_to)
6612       write (iout,*) "Contacts sent"
6613       do ii=1,ntask_cont_to
6614         nn=ncont_sent(ii)
6615         iproc=itask_cont_to(ii)
6616         write (iout,*) nn," contacts to processor",iproc,
6617      &   " of CONT_TO_COMM group"
6618         do i=1,nn
6619           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6620         enddo
6621       enddo
6622       call flush(iout)
6623       endif
6624       CorrelType=477
6625       CorrelID=fg_rank+1
6626       CorrelType1=478
6627       CorrelID1=nfgtasks+fg_rank+1
6628       ireq=0
6629 C Receive the numbers of needed contacts from other processors
6630       do ii=1,ntask_cont_from
6631         iproc=itask_cont_from(ii)
6632         ireq=ireq+1
6633         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6634      &    FG_COMM,req(ireq),IERR)
6635       enddo
6636 c      write (iout,*) "IRECV ended"
6637 c      call flush(iout)
6638 C Send the number of contacts needed by other processors
6639       do ii=1,ntask_cont_to
6640         iproc=itask_cont_to(ii)
6641         ireq=ireq+1
6642         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6643      &    FG_COMM,req(ireq),IERR)
6644       enddo
6645 c      write (iout,*) "ISEND ended"
6646 c      write (iout,*) "number of requests (nn)",ireq
6647       call flush(iout)
6648       if (ireq.gt.0)
6649      &  call MPI_Waitall(ireq,req,status_array,ierr)
6650 c      write (iout,*)
6651 c     &  "Numbers of contacts to be received from other processors",
6652 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6653 c      call flush(iout)
6654 C Receive contacts
6655       ireq=0
6656       do ii=1,ntask_cont_from
6657         iproc=itask_cont_from(ii)
6658         nn=ncont_recv(ii)
6659 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6660 c     &   " of CONT_TO_COMM group"
6661         call flush(iout)
6662         if (nn.gt.0) then
6663           ireq=ireq+1
6664           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6665      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6666 c          write (iout,*) "ireq,req",ireq,req(ireq)
6667         endif
6668       enddo
6669 C Send the contacts to processors that need them
6670       do ii=1,ntask_cont_to
6671         iproc=itask_cont_to(ii)
6672         nn=ncont_sent(ii)
6673 c        write (iout,*) nn," contacts to processor",iproc,
6674 c     &   " of CONT_TO_COMM group"
6675         if (nn.gt.0) then
6676           ireq=ireq+1
6677           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6678      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6679 c          write (iout,*) "ireq,req",ireq,req(ireq)
6680 c          do i=1,nn
6681 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6682 c          enddo
6683         endif
6684       enddo
6685 c      write (iout,*) "number of requests (contacts)",ireq
6686 c      write (iout,*) "req",(req(i),i=1,4)
6687 c      call flush(iout)
6688       if (ireq.gt.0)
6689      & call MPI_Waitall(ireq,req,status_array,ierr)
6690       do iii=1,ntask_cont_from
6691         iproc=itask_cont_from(iii)
6692         nn=ncont_recv(iii)
6693         if (lprn) then
6694         write (iout,*) "Received",nn," contacts from processor",iproc,
6695      &   " of CONT_FROM_COMM group"
6696         call flush(iout)
6697         do i=1,nn
6698           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6699         enddo
6700         call flush(iout)
6701         endif
6702         do i=1,nn
6703           ii=zapas_recv(1,i,iii)
6704 c Flag the received contacts to prevent double-counting
6705           jj=-zapas_recv(2,i,iii)
6706 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6707 c          call flush(iout)
6708           nnn=num_cont_hb(ii)+1
6709           num_cont_hb(ii)=nnn
6710           jcont_hb(nnn,ii)=jj
6711           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6712           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6713           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6714           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6715           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6716           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6717           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6718           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6719           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6720           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6721           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6722           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6723           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6724           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6725           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6726           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6727           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6728           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6729           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6730           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6731           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6732           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6733           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6734           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6735         enddo
6736       enddo
6737       call flush(iout)
6738       if (lprn) then
6739         write (iout,'(a)') 'Contact function values after receive:'
6740         do i=nnt,nct-2
6741           write (iout,'(2i3,50(1x,i3,f5.2))')
6742      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6743      &    j=1,num_cont_hb(i))
6744         enddo
6745         call flush(iout)
6746       endif
6747    30 continue
6748 #endif
6749       if (lprn) then
6750         write (iout,'(a)') 'Contact function values:'
6751         do i=nnt,nct-2
6752           write (iout,'(2i3,50(1x,i3,f5.2))')
6753      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6754      &    j=1,num_cont_hb(i))
6755         enddo
6756       endif
6757       ecorr=0.0D0
6758 C Remove the loop below after debugging !!!
6759       do i=nnt,nct
6760         do j=1,3
6761           gradcorr(j,i)=0.0D0
6762           gradxorr(j,i)=0.0D0
6763         enddo
6764       enddo
6765 C Calculate the local-electrostatic correlation terms
6766       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6767         i1=i+1
6768         num_conti=num_cont_hb(i)
6769         num_conti1=num_cont_hb(i+1)
6770         do jj=1,num_conti
6771           j=jcont_hb(jj,i)
6772           jp=iabs(j)
6773           do kk=1,num_conti1
6774             j1=jcont_hb(kk,i1)
6775             jp1=iabs(j1)
6776 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6777 c     &         ' jj=',jj,' kk=',kk
6778             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6779      &          .or. j.lt.0 .and. j1.gt.0) .and.
6780      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6781 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6782 C The system gains extra energy.
6783               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6784               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6785      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6786               n_corr=n_corr+1
6787             else if (j1.eq.j) then
6788 C Contacts I-J and I-(J+1) occur simultaneously.
6789 C The system loses extra energy.
6790 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6791             endif
6792           enddo ! kk
6793           do kk=1,num_conti
6794             j1=jcont_hb(kk,i)
6795 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6796 c    &         ' jj=',jj,' kk=',kk
6797             if (j1.eq.j+1) then
6798 C Contacts I-J and (I+1)-J occur simultaneously.
6799 C The system loses extra energy.
6800 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6801             endif ! j1==j+1
6802           enddo ! kk
6803         enddo ! jj
6804       enddo ! i
6805       return
6806       end
6807 c------------------------------------------------------------------------------
6808       subroutine add_hb_contact(ii,jj,itask)
6809       implicit real*8 (a-h,o-z)
6810       include "DIMENSIONS"
6811       include "COMMON.IOUNITS"
6812       integer max_cont
6813       integer max_dim
6814       parameter (max_cont=maxconts)
6815       parameter (max_dim=26)
6816       include "COMMON.CONTACTS"
6817       double precision zapas(max_dim,maxconts,max_fg_procs),
6818      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6819       common /przechowalnia/ zapas
6820       integer i,j,ii,jj,iproc,itask(4),nn
6821 c      write (iout,*) "itask",itask
6822       do i=1,2
6823         iproc=itask(i)
6824         if (iproc.gt.0) then
6825           do j=1,num_cont_hb(ii)
6826             jjc=jcont_hb(j,ii)
6827 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6828             if (jjc.eq.jj) then
6829               ncont_sent(iproc)=ncont_sent(iproc)+1
6830               nn=ncont_sent(iproc)
6831               zapas(1,nn,iproc)=ii
6832               zapas(2,nn,iproc)=jjc
6833               zapas(3,nn,iproc)=facont_hb(j,ii)
6834               zapas(4,nn,iproc)=ees0p(j,ii)
6835               zapas(5,nn,iproc)=ees0m(j,ii)
6836               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6837               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6838               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6839               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6840               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6841               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6842               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6843               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6844               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6845               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6846               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6847               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6848               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6849               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6850               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6851               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6852               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6853               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6854               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6855               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6856               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6857               exit
6858             endif
6859           enddo
6860         endif
6861       enddo
6862       return
6863       end
6864 c------------------------------------------------------------------------------
6865       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6866      &  n_corr1)
6867 C This subroutine calculates multi-body contributions to hydrogen-bonding
6868       implicit real*8 (a-h,o-z)
6869       include 'DIMENSIONS'
6870       include 'COMMON.IOUNITS'
6871 #ifdef MPI
6872       include "mpif.h"
6873       parameter (max_cont=maxconts)
6874       parameter (max_dim=70)
6875       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6876       double precision zapas(max_dim,maxconts,max_fg_procs),
6877      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6878       common /przechowalnia/ zapas
6879       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6880      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6881 #endif
6882       include 'COMMON.SETUP'
6883       include 'COMMON.FFIELD'
6884       include 'COMMON.DERIV'
6885       include 'COMMON.LOCAL'
6886       include 'COMMON.INTERACT'
6887       include 'COMMON.CONTACTS'
6888       include 'COMMON.CHAIN'
6889       include 'COMMON.CONTROL'
6890       double precision gx(3),gx1(3)
6891       integer num_cont_hb_old(maxres)
6892       logical lprn,ldone
6893       double precision eello4,eello5,eelo6,eello_turn6
6894       external eello4,eello5,eello6,eello_turn6
6895 C Set lprn=.true. for debugging
6896       lprn=.false.
6897       eturn6=0.0d0
6898 #ifdef MPI
6899       do i=1,nres
6900         num_cont_hb_old(i)=num_cont_hb(i)
6901       enddo
6902       n_corr=0
6903       n_corr1=0
6904       if (nfgtasks.le.1) goto 30
6905       if (lprn) then
6906         write (iout,'(a)') 'Contact function values before RECEIVE:'
6907         do i=nnt,nct-2
6908           write (iout,'(2i3,50(1x,i2,f5.2))')
6909      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6910      &    j=1,num_cont_hb(i))
6911         enddo
6912       endif
6913       call flush(iout)
6914       do i=1,ntask_cont_from
6915         ncont_recv(i)=0
6916       enddo
6917       do i=1,ntask_cont_to
6918         ncont_sent(i)=0
6919       enddo
6920 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6921 c     & ntask_cont_to
6922 C Make the list of contacts to send to send to other procesors
6923       do i=iturn3_start,iturn3_end
6924 c        write (iout,*) "make contact list turn3",i," num_cont",
6925 c     &    num_cont_hb(i)
6926         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6927       enddo
6928       do i=iturn4_start,iturn4_end
6929 c        write (iout,*) "make contact list turn4",i," num_cont",
6930 c     &   num_cont_hb(i)
6931         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6932       enddo
6933       do ii=1,nat_sent
6934         i=iat_sent(ii)
6935 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6936 c     &    num_cont_hb(i)
6937         do j=1,num_cont_hb(i)
6938         do k=1,4
6939           jjc=jcont_hb(j,i)
6940           iproc=iint_sent_local(k,jjc,ii)
6941 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6942           if (iproc.ne.0) then
6943             ncont_sent(iproc)=ncont_sent(iproc)+1
6944             nn=ncont_sent(iproc)
6945             zapas(1,nn,iproc)=i
6946             zapas(2,nn,iproc)=jjc
6947             zapas(3,nn,iproc)=d_cont(j,i)
6948             ind=3
6949             do kk=1,3
6950               ind=ind+1
6951               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6952             enddo
6953             do kk=1,2
6954               do ll=1,2
6955                 ind=ind+1
6956                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6957               enddo
6958             enddo
6959             do jj=1,5
6960               do kk=1,3
6961                 do ll=1,2
6962                   do mm=1,2
6963                     ind=ind+1
6964                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6965                   enddo
6966                 enddo
6967               enddo
6968             enddo
6969           endif
6970         enddo
6971         enddo
6972       enddo
6973       if (lprn) then
6974       write (iout,*)
6975      &  "Numbers of contacts to be sent to other processors",
6976      &  (ncont_sent(i),i=1,ntask_cont_to)
6977       write (iout,*) "Contacts sent"
6978       do ii=1,ntask_cont_to
6979         nn=ncont_sent(ii)
6980         iproc=itask_cont_to(ii)
6981         write (iout,*) nn," contacts to processor",iproc,
6982      &   " of CONT_TO_COMM group"
6983         do i=1,nn
6984           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6985         enddo
6986       enddo
6987       call flush(iout)
6988       endif
6989       CorrelType=477
6990       CorrelID=fg_rank+1
6991       CorrelType1=478
6992       CorrelID1=nfgtasks+fg_rank+1
6993       ireq=0
6994 C Receive the numbers of needed contacts from other processors
6995       do ii=1,ntask_cont_from
6996         iproc=itask_cont_from(ii)
6997         ireq=ireq+1
6998         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6999      &    FG_COMM,req(ireq),IERR)
7000       enddo
7001 c      write (iout,*) "IRECV ended"
7002 c      call flush(iout)
7003 C Send the number of contacts needed by other processors
7004       do ii=1,ntask_cont_to
7005         iproc=itask_cont_to(ii)
7006         ireq=ireq+1
7007         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7008      &    FG_COMM,req(ireq),IERR)
7009       enddo
7010 c      write (iout,*) "ISEND ended"
7011 c      write (iout,*) "number of requests (nn)",ireq
7012       call flush(iout)
7013       if (ireq.gt.0)
7014      &  call MPI_Waitall(ireq,req,status_array,ierr)
7015 c      write (iout,*)
7016 c     &  "Numbers of contacts to be received from other processors",
7017 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7018 c      call flush(iout)
7019 C Receive contacts
7020       ireq=0
7021       do ii=1,ntask_cont_from
7022         iproc=itask_cont_from(ii)
7023         nn=ncont_recv(ii)
7024 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7025 c     &   " of CONT_TO_COMM group"
7026         call flush(iout)
7027         if (nn.gt.0) then
7028           ireq=ireq+1
7029           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7030      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7031 c          write (iout,*) "ireq,req",ireq,req(ireq)
7032         endif
7033       enddo
7034 C Send the contacts to processors that need them
7035       do ii=1,ntask_cont_to
7036         iproc=itask_cont_to(ii)
7037         nn=ncont_sent(ii)
7038 c        write (iout,*) nn," contacts to processor",iproc,
7039 c     &   " of CONT_TO_COMM group"
7040         if (nn.gt.0) then
7041           ireq=ireq+1
7042           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7043      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7044 c          write (iout,*) "ireq,req",ireq,req(ireq)
7045 c          do i=1,nn
7046 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7047 c          enddo
7048         endif
7049       enddo
7050 c      write (iout,*) "number of requests (contacts)",ireq
7051 c      write (iout,*) "req",(req(i),i=1,4)
7052 c      call flush(iout)
7053       if (ireq.gt.0)
7054      & call MPI_Waitall(ireq,req,status_array,ierr)
7055       do iii=1,ntask_cont_from
7056         iproc=itask_cont_from(iii)
7057         nn=ncont_recv(iii)
7058         if (lprn) then
7059         write (iout,*) "Received",nn," contacts from processor",iproc,
7060      &   " of CONT_FROM_COMM group"
7061         call flush(iout)
7062         do i=1,nn
7063           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7064         enddo
7065         call flush(iout)
7066         endif
7067         do i=1,nn
7068           ii=zapas_recv(1,i,iii)
7069 c Flag the received contacts to prevent double-counting
7070           jj=-zapas_recv(2,i,iii)
7071 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7072 c          call flush(iout)
7073           nnn=num_cont_hb(ii)+1
7074           num_cont_hb(ii)=nnn
7075           jcont_hb(nnn,ii)=jj
7076           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7077           ind=3
7078           do kk=1,3
7079             ind=ind+1
7080             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7081           enddo
7082           do kk=1,2
7083             do ll=1,2
7084               ind=ind+1
7085               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7086             enddo
7087           enddo
7088           do jj=1,5
7089             do kk=1,3
7090               do ll=1,2
7091                 do mm=1,2
7092                   ind=ind+1
7093                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7094                 enddo
7095               enddo
7096             enddo
7097           enddo
7098         enddo
7099       enddo
7100       call flush(iout)
7101       if (lprn) then
7102         write (iout,'(a)') 'Contact function values after receive:'
7103         do i=nnt,nct-2
7104           write (iout,'(2i3,50(1x,i3,5f6.3))')
7105      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7106      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7107         enddo
7108         call flush(iout)
7109       endif
7110    30 continue
7111 #endif
7112       if (lprn) then
7113         write (iout,'(a)') 'Contact function values:'
7114         do i=nnt,nct-2
7115           write (iout,'(2i3,50(1x,i2,5f6.3))')
7116      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7117      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7118         enddo
7119       endif
7120       ecorr=0.0D0
7121       ecorr5=0.0d0
7122       ecorr6=0.0d0
7123 C Remove the loop below after debugging !!!
7124       do i=nnt,nct
7125         do j=1,3
7126           gradcorr(j,i)=0.0D0
7127           gradxorr(j,i)=0.0D0
7128         enddo
7129       enddo
7130 C Calculate the dipole-dipole interaction energies
7131       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7132       do i=iatel_s,iatel_e+1
7133         num_conti=num_cont_hb(i)
7134         do jj=1,num_conti
7135           j=jcont_hb(jj,i)
7136 #ifdef MOMENT
7137           call dipole(i,j,jj)
7138 #endif
7139         enddo
7140       enddo
7141       endif
7142 C Calculate the local-electrostatic correlation terms
7143 c                write (iout,*) "gradcorr5 in eello5 before loop"
7144 c                do iii=1,nres
7145 c                  write (iout,'(i5,3f10.5)')
7146 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7147 c                enddo
7148       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7149 c        write (iout,*) "corr loop i",i
7150         i1=i+1
7151         num_conti=num_cont_hb(i)
7152         num_conti1=num_cont_hb(i+1)
7153         do jj=1,num_conti
7154           j=jcont_hb(jj,i)
7155           jp=iabs(j)
7156           do kk=1,num_conti1
7157             j1=jcont_hb(kk,i1)
7158             jp1=iabs(j1)
7159 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7160 c     &         ' jj=',jj,' kk=',kk
7161 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7162             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7163      &          .or. j.lt.0 .and. j1.gt.0) .and.
7164      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7165 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7166 C The system gains extra energy.
7167               n_corr=n_corr+1
7168               sqd1=dsqrt(d_cont(jj,i))
7169               sqd2=dsqrt(d_cont(kk,i1))
7170               sred_geom = sqd1*sqd2
7171               IF (sred_geom.lt.cutoff_corr) THEN
7172                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7173      &            ekont,fprimcont)
7174 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7175 cd     &         ' jj=',jj,' kk=',kk
7176                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7177                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7178                 do l=1,3
7179                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7180                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7181                 enddo
7182                 n_corr1=n_corr1+1
7183 cd               write (iout,*) 'sred_geom=',sred_geom,
7184 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7185 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7186 cd               write (iout,*) "g_contij",g_contij
7187 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7188 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7189                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7190                 if (wcorr4.gt.0.0d0)
7191      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7192                   if (energy_dec.and.wcorr4.gt.0.0d0)
7193      1                 write (iout,'(a6,4i5,0pf7.3)')
7194      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7195 c                write (iout,*) "gradcorr5 before eello5"
7196 c                do iii=1,nres
7197 c                  write (iout,'(i5,3f10.5)')
7198 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7199 c                enddo
7200                 if (wcorr5.gt.0.0d0)
7201      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7202 c                write (iout,*) "gradcorr5 after eello5"
7203 c                do iii=1,nres
7204 c                  write (iout,'(i5,3f10.5)')
7205 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7206 c                enddo
7207                   if (energy_dec.and.wcorr5.gt.0.0d0)
7208      1                 write (iout,'(a6,4i5,0pf7.3)')
7209      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7210 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7211 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7212                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7213      &               .or. wturn6.eq.0.0d0))then
7214 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7215                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7216                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7217      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7218 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7219 cd     &            'ecorr6=',ecorr6
7220 cd                write (iout,'(4e15.5)') sred_geom,
7221 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7222 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7223 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7224                 else if (wturn6.gt.0.0d0
7225      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7226 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7227                   eturn6=eturn6+eello_turn6(i,jj,kk)
7228                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7229      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7230 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7231                 endif
7232               ENDIF
7233 1111          continue
7234             endif
7235           enddo ! kk
7236         enddo ! jj
7237       enddo ! i
7238       do i=1,nres
7239         num_cont_hb(i)=num_cont_hb_old(i)
7240       enddo
7241 c                write (iout,*) "gradcorr5 in eello5"
7242 c                do iii=1,nres
7243 c                  write (iout,'(i5,3f10.5)')
7244 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7245 c                enddo
7246       return
7247       end
7248 c------------------------------------------------------------------------------
7249       subroutine add_hb_contact_eello(ii,jj,itask)
7250       implicit real*8 (a-h,o-z)
7251       include "DIMENSIONS"
7252       include "COMMON.IOUNITS"
7253       integer max_cont
7254       integer max_dim
7255       parameter (max_cont=maxconts)
7256       parameter (max_dim=70)
7257       include "COMMON.CONTACTS"
7258       double precision zapas(max_dim,maxconts,max_fg_procs),
7259      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7260       common /przechowalnia/ zapas
7261       integer i,j,ii,jj,iproc,itask(4),nn
7262 c      write (iout,*) "itask",itask
7263       do i=1,2
7264         iproc=itask(i)
7265         if (iproc.gt.0) then
7266           do j=1,num_cont_hb(ii)
7267             jjc=jcont_hb(j,ii)
7268 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7269             if (jjc.eq.jj) then
7270               ncont_sent(iproc)=ncont_sent(iproc)+1
7271               nn=ncont_sent(iproc)
7272               zapas(1,nn,iproc)=ii
7273               zapas(2,nn,iproc)=jjc
7274               zapas(3,nn,iproc)=d_cont(j,ii)
7275               ind=3
7276               do kk=1,3
7277                 ind=ind+1
7278                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7279               enddo
7280               do kk=1,2
7281                 do ll=1,2
7282                   ind=ind+1
7283                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7284                 enddo
7285               enddo
7286               do jj=1,5
7287                 do kk=1,3
7288                   do ll=1,2
7289                     do mm=1,2
7290                       ind=ind+1
7291                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7292                     enddo
7293                   enddo
7294                 enddo
7295               enddo
7296               exit
7297             endif
7298           enddo
7299         endif
7300       enddo
7301       return
7302       end
7303 c------------------------------------------------------------------------------
7304       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7305       implicit real*8 (a-h,o-z)
7306       include 'DIMENSIONS'
7307       include 'COMMON.IOUNITS'
7308       include 'COMMON.DERIV'
7309       include 'COMMON.INTERACT'
7310       include 'COMMON.CONTACTS'
7311       double precision gx(3),gx1(3)
7312       logical lprn
7313       lprn=.false.
7314       eij=facont_hb(jj,i)
7315       ekl=facont_hb(kk,k)
7316       ees0pij=ees0p(jj,i)
7317       ees0pkl=ees0p(kk,k)
7318       ees0mij=ees0m(jj,i)
7319       ees0mkl=ees0m(kk,k)
7320       ekont=eij*ekl
7321       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7322 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7323 C Following 4 lines for diagnostics.
7324 cd    ees0pkl=0.0D0
7325 cd    ees0pij=1.0D0
7326 cd    ees0mkl=0.0D0
7327 cd    ees0mij=1.0D0
7328 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7329 c     & 'Contacts ',i,j,
7330 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7331 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7332 c     & 'gradcorr_long'
7333 C Calculate the multi-body contribution to energy.
7334 c      ecorr=ecorr+ekont*ees
7335 C Calculate multi-body contributions to the gradient.
7336       coeffpees0pij=coeffp*ees0pij
7337       coeffmees0mij=coeffm*ees0mij
7338       coeffpees0pkl=coeffp*ees0pkl
7339       coeffmees0mkl=coeffm*ees0mkl
7340       do ll=1,3
7341 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7342         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7343      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7344      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7345         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7346      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7347      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7348 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7349         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7350      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7351      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7352         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7353      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7354      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7355         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7356      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7357      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7358         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7359         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7360         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7361      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7362      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7363         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7364         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7365 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7366       enddo
7367 c      write (iout,*)
7368 cgrad      do m=i+1,j-1
7369 cgrad        do ll=1,3
7370 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7371 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7372 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7373 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7374 cgrad        enddo
7375 cgrad      enddo
7376 cgrad      do m=k+1,l-1
7377 cgrad        do ll=1,3
7378 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7379 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7380 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7381 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7382 cgrad        enddo
7383 cgrad      enddo
7384 c      write (iout,*) "ehbcorr",ekont*ees
7385       ehbcorr=ekont*ees
7386       return
7387       end
7388 #ifdef MOMENT
7389 C---------------------------------------------------------------------------
7390       subroutine dipole(i,j,jj)
7391       implicit real*8 (a-h,o-z)
7392       include 'DIMENSIONS'
7393       include 'COMMON.IOUNITS'
7394       include 'COMMON.CHAIN'
7395       include 'COMMON.FFIELD'
7396       include 'COMMON.DERIV'
7397       include 'COMMON.INTERACT'
7398       include 'COMMON.CONTACTS'
7399       include 'COMMON.TORSION'
7400       include 'COMMON.VAR'
7401       include 'COMMON.GEO'
7402       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7403      &  auxmat(2,2)
7404       iti1 = itortyp(itype(i+1))
7405       if (j.lt.nres-1) then
7406         itj1 = itortyp(itype(j+1))
7407       else
7408         itj1=ntortyp
7409       endif
7410       do iii=1,2
7411         dipi(iii,1)=Ub2(iii,i)
7412         dipderi(iii)=Ub2der(iii,i)
7413         dipi(iii,2)=b1(iii,iti1)
7414         dipj(iii,1)=Ub2(iii,j)
7415         dipderj(iii)=Ub2der(iii,j)
7416         dipj(iii,2)=b1(iii,itj1)
7417       enddo
7418       kkk=0
7419       do iii=1,2
7420         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7421         do jjj=1,2
7422           kkk=kkk+1
7423           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7424         enddo
7425       enddo
7426       do kkk=1,5
7427         do lll=1,3
7428           mmm=0
7429           do iii=1,2
7430             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7431      &        auxvec(1))
7432             do jjj=1,2
7433               mmm=mmm+1
7434               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7435             enddo
7436           enddo
7437         enddo
7438       enddo
7439       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7440       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7441       do iii=1,2
7442         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7443       enddo
7444       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7445       do iii=1,2
7446         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7447       enddo
7448       return
7449       end
7450 #endif
7451 C---------------------------------------------------------------------------
7452       subroutine calc_eello(i,j,k,l,jj,kk)
7453 C
7454 C This subroutine computes matrices and vectors needed to calculate
7455 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7456 C
7457       implicit real*8 (a-h,o-z)
7458       include 'DIMENSIONS'
7459       include 'COMMON.IOUNITS'
7460       include 'COMMON.CHAIN'
7461       include 'COMMON.DERIV'
7462       include 'COMMON.INTERACT'
7463       include 'COMMON.CONTACTS'
7464       include 'COMMON.TORSION'
7465       include 'COMMON.VAR'
7466       include 'COMMON.GEO'
7467       include 'COMMON.FFIELD'
7468       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7469      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7470       logical lprn
7471       common /kutas/ lprn
7472 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7473 cd     & ' jj=',jj,' kk=',kk
7474 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7475 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7476 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7477       do iii=1,2
7478         do jjj=1,2
7479           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7480           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7481         enddo
7482       enddo
7483       call transpose2(aa1(1,1),aa1t(1,1))
7484       call transpose2(aa2(1,1),aa2t(1,1))
7485       do kkk=1,5
7486         do lll=1,3
7487           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7488      &      aa1tder(1,1,lll,kkk))
7489           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7490      &      aa2tder(1,1,lll,kkk))
7491         enddo
7492       enddo
7493       if (l.eq.j+1) then
7494 C parallel orientation of the two CA-CA-CA frames.
7495         if (i.gt.1) then
7496           iti=itortyp(itype(i))
7497         else
7498           iti=ntortyp
7499         endif
7500         itk1=itortyp(itype(k+1))
7501         itj=itortyp(itype(j))
7502         if (l.lt.nres-1) then
7503           itl1=itortyp(itype(l+1))
7504         else
7505           itl1=ntortyp
7506         endif
7507 C A1 kernel(j+1) A2T
7508 cd        do iii=1,2
7509 cd          write (iout,'(3f10.5,5x,3f10.5)')
7510 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7511 cd        enddo
7512         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7513      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7514      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7515 C Following matrices are needed only for 6-th order cumulants
7516         IF (wcorr6.gt.0.0d0) THEN
7517         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7518      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7519      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7520         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7521      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7522      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7523      &   ADtEAderx(1,1,1,1,1,1))
7524         lprn=.false.
7525         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7526      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7527      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7528      &   ADtEA1derx(1,1,1,1,1,1))
7529         ENDIF
7530 C End 6-th order cumulants
7531 cd        lprn=.false.
7532 cd        if (lprn) then
7533 cd        write (2,*) 'In calc_eello6'
7534 cd        do iii=1,2
7535 cd          write (2,*) 'iii=',iii
7536 cd          do kkk=1,5
7537 cd            write (2,*) 'kkk=',kkk
7538 cd            do jjj=1,2
7539 cd              write (2,'(3(2f10.5),5x)')
7540 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7541 cd            enddo
7542 cd          enddo
7543 cd        enddo
7544 cd        endif
7545         call transpose2(EUgder(1,1,k),auxmat(1,1))
7546         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7547         call transpose2(EUg(1,1,k),auxmat(1,1))
7548         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7549         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7550         do iii=1,2
7551           do kkk=1,5
7552             do lll=1,3
7553               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7554      &          EAEAderx(1,1,lll,kkk,iii,1))
7555             enddo
7556           enddo
7557         enddo
7558 C A1T kernel(i+1) A2
7559         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7560      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7561      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7562 C Following matrices are needed only for 6-th order cumulants
7563         IF (wcorr6.gt.0.0d0) THEN
7564         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7565      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7566      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7567         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7568      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7569      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7570      &   ADtEAderx(1,1,1,1,1,2))
7571         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7572      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7573      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7574      &   ADtEA1derx(1,1,1,1,1,2))
7575         ENDIF
7576 C End 6-th order cumulants
7577         call transpose2(EUgder(1,1,l),auxmat(1,1))
7578         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7579         call transpose2(EUg(1,1,l),auxmat(1,1))
7580         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7581         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7582         do iii=1,2
7583           do kkk=1,5
7584             do lll=1,3
7585               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7586      &          EAEAderx(1,1,lll,kkk,iii,2))
7587             enddo
7588           enddo
7589         enddo
7590 C AEAb1 and AEAb2
7591 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7592 C They are needed only when the fifth- or the sixth-order cumulants are
7593 C indluded.
7594         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7595         call transpose2(AEA(1,1,1),auxmat(1,1))
7596         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7597         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7598         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7599         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7600         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7601         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7602         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7603         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7604         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7605         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7606         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7607         call transpose2(AEA(1,1,2),auxmat(1,1))
7608         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7609         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7610         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7611         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7612         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7613         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7614         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7615         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7616         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7617         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7618         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7619 C Calculate the Cartesian derivatives of the vectors.
7620         do iii=1,2
7621           do kkk=1,5
7622             do lll=1,3
7623               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7624               call matvec2(auxmat(1,1),b1(1,iti),
7625      &          AEAb1derx(1,lll,kkk,iii,1,1))
7626               call matvec2(auxmat(1,1),Ub2(1,i),
7627      &          AEAb2derx(1,lll,kkk,iii,1,1))
7628               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7629      &          AEAb1derx(1,lll,kkk,iii,2,1))
7630               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7631      &          AEAb2derx(1,lll,kkk,iii,2,1))
7632               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7633               call matvec2(auxmat(1,1),b1(1,itj),
7634      &          AEAb1derx(1,lll,kkk,iii,1,2))
7635               call matvec2(auxmat(1,1),Ub2(1,j),
7636      &          AEAb2derx(1,lll,kkk,iii,1,2))
7637               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7638      &          AEAb1derx(1,lll,kkk,iii,2,2))
7639               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7640      &          AEAb2derx(1,lll,kkk,iii,2,2))
7641             enddo
7642           enddo
7643         enddo
7644         ENDIF
7645 C End vectors
7646       else
7647 C Antiparallel orientation of the two CA-CA-CA frames.
7648         if (i.gt.1) then
7649           iti=itortyp(itype(i))
7650         else
7651           iti=ntortyp
7652         endif
7653         itk1=itortyp(itype(k+1))
7654         itl=itortyp(itype(l))
7655         itj=itortyp(itype(j))
7656         if (j.lt.nres-1) then
7657           itj1=itortyp(itype(j+1))
7658         else
7659           itj1=ntortyp
7660         endif
7661 C A2 kernel(j-1)T A1T
7662         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7663      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7664      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7665 C Following matrices are needed only for 6-th order cumulants
7666         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7667      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7668         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7669      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7670      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7671         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7672      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7673      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7674      &   ADtEAderx(1,1,1,1,1,1))
7675         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7676      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7677      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7678      &   ADtEA1derx(1,1,1,1,1,1))
7679         ENDIF
7680 C End 6-th order cumulants
7681         call transpose2(EUgder(1,1,k),auxmat(1,1))
7682         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7683         call transpose2(EUg(1,1,k),auxmat(1,1))
7684         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7685         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7686         do iii=1,2
7687           do kkk=1,5
7688             do lll=1,3
7689               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7690      &          EAEAderx(1,1,lll,kkk,iii,1))
7691             enddo
7692           enddo
7693         enddo
7694 C A2T kernel(i+1)T A1
7695         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7696      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7697      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7698 C Following matrices are needed only for 6-th order cumulants
7699         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7700      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7701         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7702      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7703      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7704         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7705      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7706      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7707      &   ADtEAderx(1,1,1,1,1,2))
7708         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7709      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7710      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7711      &   ADtEA1derx(1,1,1,1,1,2))
7712         ENDIF
7713 C End 6-th order cumulants
7714         call transpose2(EUgder(1,1,j),auxmat(1,1))
7715         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7716         call transpose2(EUg(1,1,j),auxmat(1,1))
7717         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7718         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7719         do iii=1,2
7720           do kkk=1,5
7721             do lll=1,3
7722               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7723      &          EAEAderx(1,1,lll,kkk,iii,2))
7724             enddo
7725           enddo
7726         enddo
7727 C AEAb1 and AEAb2
7728 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7729 C They are needed only when the fifth- or the sixth-order cumulants are
7730 C indluded.
7731         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7732      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7733         call transpose2(AEA(1,1,1),auxmat(1,1))
7734         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7735         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7736         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7737         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7738         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7739         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7740         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7741         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7742         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7743         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7744         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7745         call transpose2(AEA(1,1,2),auxmat(1,1))
7746         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7747         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7748         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7749         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7750         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7751         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7752         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7753         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7754         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7755         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7756         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7757 C Calculate the Cartesian derivatives of the vectors.
7758         do iii=1,2
7759           do kkk=1,5
7760             do lll=1,3
7761               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7762               call matvec2(auxmat(1,1),b1(1,iti),
7763      &          AEAb1derx(1,lll,kkk,iii,1,1))
7764               call matvec2(auxmat(1,1),Ub2(1,i),
7765      &          AEAb2derx(1,lll,kkk,iii,1,1))
7766               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7767      &          AEAb1derx(1,lll,kkk,iii,2,1))
7768               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7769      &          AEAb2derx(1,lll,kkk,iii,2,1))
7770               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7771               call matvec2(auxmat(1,1),b1(1,itl),
7772      &          AEAb1derx(1,lll,kkk,iii,1,2))
7773               call matvec2(auxmat(1,1),Ub2(1,l),
7774      &          AEAb2derx(1,lll,kkk,iii,1,2))
7775               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7776      &          AEAb1derx(1,lll,kkk,iii,2,2))
7777               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7778      &          AEAb2derx(1,lll,kkk,iii,2,2))
7779             enddo
7780           enddo
7781         enddo
7782         ENDIF
7783 C End vectors
7784       endif
7785       return
7786       end
7787 C---------------------------------------------------------------------------
7788       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7789      &  KK,KKderg,AKA,AKAderg,AKAderx)
7790       implicit none
7791       integer nderg
7792       logical transp
7793       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7794      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7795      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7796       integer iii,kkk,lll
7797       integer jjj,mmm
7798       logical lprn
7799       common /kutas/ lprn
7800       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7801       do iii=1,nderg
7802         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7803      &    AKAderg(1,1,iii))
7804       enddo
7805 cd      if (lprn) write (2,*) 'In kernel'
7806       do kkk=1,5
7807 cd        if (lprn) write (2,*) 'kkk=',kkk
7808         do lll=1,3
7809           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7810      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7811 cd          if (lprn) then
7812 cd            write (2,*) 'lll=',lll
7813 cd            write (2,*) 'iii=1'
7814 cd            do jjj=1,2
7815 cd              write (2,'(3(2f10.5),5x)')
7816 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7817 cd            enddo
7818 cd          endif
7819           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7820      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7821 cd          if (lprn) then
7822 cd            write (2,*) 'lll=',lll
7823 cd            write (2,*) 'iii=2'
7824 cd            do jjj=1,2
7825 cd              write (2,'(3(2f10.5),5x)')
7826 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7827 cd            enddo
7828 cd          endif
7829         enddo
7830       enddo
7831       return
7832       end
7833 C---------------------------------------------------------------------------
7834       double precision function eello4(i,j,k,l,jj,kk)
7835       implicit real*8 (a-h,o-z)
7836       include 'DIMENSIONS'
7837       include 'COMMON.IOUNITS'
7838       include 'COMMON.CHAIN'
7839       include 'COMMON.DERIV'
7840       include 'COMMON.INTERACT'
7841       include 'COMMON.CONTACTS'
7842       include 'COMMON.TORSION'
7843       include 'COMMON.VAR'
7844       include 'COMMON.GEO'
7845       double precision pizda(2,2),ggg1(3),ggg2(3)
7846 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7847 cd        eello4=0.0d0
7848 cd        return
7849 cd      endif
7850 cd      print *,'eello4:',i,j,k,l,jj,kk
7851 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7852 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7853 cold      eij=facont_hb(jj,i)
7854 cold      ekl=facont_hb(kk,k)
7855 cold      ekont=eij*ekl
7856       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7857 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7858       gcorr_loc(k-1)=gcorr_loc(k-1)
7859      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7860       if (l.eq.j+1) then
7861         gcorr_loc(l-1)=gcorr_loc(l-1)
7862      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7863       else
7864         gcorr_loc(j-1)=gcorr_loc(j-1)
7865      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7866       endif
7867       do iii=1,2
7868         do kkk=1,5
7869           do lll=1,3
7870             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7871      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7872 cd            derx(lll,kkk,iii)=0.0d0
7873           enddo
7874         enddo
7875       enddo
7876 cd      gcorr_loc(l-1)=0.0d0
7877 cd      gcorr_loc(j-1)=0.0d0
7878 cd      gcorr_loc(k-1)=0.0d0
7879 cd      eel4=1.0d0
7880 cd      write (iout,*)'Contacts have occurred for peptide groups',
7881 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7882 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7883       if (j.lt.nres-1) then
7884         j1=j+1
7885         j2=j-1
7886       else
7887         j1=j-1
7888         j2=j-2
7889       endif
7890       if (l.lt.nres-1) then
7891         l1=l+1
7892         l2=l-1
7893       else
7894         l1=l-1
7895         l2=l-2
7896       endif
7897       do ll=1,3
7898 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7899 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7900         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7901         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7902 cgrad        ghalf=0.5d0*ggg1(ll)
7903         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7904         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7905         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7906         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7907         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7908         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7909 cgrad        ghalf=0.5d0*ggg2(ll)
7910         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7911         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7912         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7913         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7914         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7915         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7916       enddo
7917 cgrad      do m=i+1,j-1
7918 cgrad        do ll=1,3
7919 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7920 cgrad        enddo
7921 cgrad      enddo
7922 cgrad      do m=k+1,l-1
7923 cgrad        do ll=1,3
7924 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7925 cgrad        enddo
7926 cgrad      enddo
7927 cgrad      do m=i+2,j2
7928 cgrad        do ll=1,3
7929 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7930 cgrad        enddo
7931 cgrad      enddo
7932 cgrad      do m=k+2,l2
7933 cgrad        do ll=1,3
7934 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7935 cgrad        enddo
7936 cgrad      enddo
7937 cd      do iii=1,nres-3
7938 cd        write (2,*) iii,gcorr_loc(iii)
7939 cd      enddo
7940       eello4=ekont*eel4
7941 cd      write (2,*) 'ekont',ekont
7942 cd      write (iout,*) 'eello4',ekont*eel4
7943       return
7944       end
7945 C---------------------------------------------------------------------------
7946       double precision function eello5(i,j,k,l,jj,kk)
7947       implicit real*8 (a-h,o-z)
7948       include 'DIMENSIONS'
7949       include 'COMMON.IOUNITS'
7950       include 'COMMON.CHAIN'
7951       include 'COMMON.DERIV'
7952       include 'COMMON.INTERACT'
7953       include 'COMMON.CONTACTS'
7954       include 'COMMON.TORSION'
7955       include 'COMMON.VAR'
7956       include 'COMMON.GEO'
7957       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7958       double precision ggg1(3),ggg2(3)
7959 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7960 C                                                                              C
7961 C                            Parallel chains                                   C
7962 C                                                                              C
7963 C          o             o                   o             o                   C
7964 C         /l\           / \             \   / \           / \   /              C
7965 C        /   \         /   \             \ /   \         /   \ /               C
7966 C       j| o |l1       | o |              o| o |         | o |o                C
7967 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7968 C      \i/   \         /   \ /             /   \         /   \                 C
7969 C       o    k1             o                                                  C
7970 C         (I)          (II)                (III)          (IV)                 C
7971 C                                                                              C
7972 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7973 C                                                                              C
7974 C                            Antiparallel chains                               C
7975 C                                                                              C
7976 C          o             o                   o             o                   C
7977 C         /j\           / \             \   / \           / \   /              C
7978 C        /   \         /   \             \ /   \         /   \ /               C
7979 C      j1| o |l        | o |              o| o |         | o |o                C
7980 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7981 C      \i/   \         /   \ /             /   \         /   \                 C
7982 C       o     k1            o                                                  C
7983 C         (I)          (II)                (III)          (IV)                 C
7984 C                                                                              C
7985 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7986 C                                                                              C
7987 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7988 C                                                                              C
7989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7990 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7991 cd        eello5=0.0d0
7992 cd        return
7993 cd      endif
7994 cd      write (iout,*)
7995 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7996 cd     &   ' and',k,l
7997       itk=itortyp(itype(k))
7998       itl=itortyp(itype(l))
7999       itj=itortyp(itype(j))
8000       eello5_1=0.0d0
8001       eello5_2=0.0d0
8002       eello5_3=0.0d0
8003       eello5_4=0.0d0
8004 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8005 cd     &   eel5_3_num,eel5_4_num)
8006       do iii=1,2
8007         do kkk=1,5
8008           do lll=1,3
8009             derx(lll,kkk,iii)=0.0d0
8010           enddo
8011         enddo
8012       enddo
8013 cd      eij=facont_hb(jj,i)
8014 cd      ekl=facont_hb(kk,k)
8015 cd      ekont=eij*ekl
8016 cd      write (iout,*)'Contacts have occurred for peptide groups',
8017 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8018 cd      goto 1111
8019 C Contribution from the graph I.
8020 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8021 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8022       call transpose2(EUg(1,1,k),auxmat(1,1))
8023       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8024       vv(1)=pizda(1,1)-pizda(2,2)
8025       vv(2)=pizda(1,2)+pizda(2,1)
8026       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8027      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8028 C Explicit gradient in virtual-dihedral angles.
8029       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8030      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8031      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8032       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8033       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8034       vv(1)=pizda(1,1)-pizda(2,2)
8035       vv(2)=pizda(1,2)+pizda(2,1)
8036       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8037      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8038      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8039       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8040       vv(1)=pizda(1,1)-pizda(2,2)
8041       vv(2)=pizda(1,2)+pizda(2,1)
8042       if (l.eq.j+1) then
8043         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8044      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8045      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8046       else
8047         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8048      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8049      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8050       endif
8051 C Cartesian gradient
8052       do iii=1,2
8053         do kkk=1,5
8054           do lll=1,3
8055             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8056      &        pizda(1,1))
8057             vv(1)=pizda(1,1)-pizda(2,2)
8058             vv(2)=pizda(1,2)+pizda(2,1)
8059             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8060      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8061      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8062           enddo
8063         enddo
8064       enddo
8065 c      goto 1112
8066 c1111  continue
8067 C Contribution from graph II
8068       call transpose2(EE(1,1,itk),auxmat(1,1))
8069       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8070       vv(1)=pizda(1,1)+pizda(2,2)
8071       vv(2)=pizda(2,1)-pizda(1,2)
8072       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8073      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8074 C Explicit gradient in virtual-dihedral angles.
8075       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8076      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8077       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8078       vv(1)=pizda(1,1)+pizda(2,2)
8079       vv(2)=pizda(2,1)-pizda(1,2)
8080       if (l.eq.j+1) then
8081         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8082      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8083      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8084       else
8085         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8086      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8087      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8088       endif
8089 C Cartesian gradient
8090       do iii=1,2
8091         do kkk=1,5
8092           do lll=1,3
8093             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8094      &        pizda(1,1))
8095             vv(1)=pizda(1,1)+pizda(2,2)
8096             vv(2)=pizda(2,1)-pizda(1,2)
8097             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8098      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8099      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8100           enddo
8101         enddo
8102       enddo
8103 cd      goto 1112
8104 cd1111  continue
8105       if (l.eq.j+1) then
8106 cd        goto 1110
8107 C Parallel orientation
8108 C Contribution from graph III
8109         call transpose2(EUg(1,1,l),auxmat(1,1))
8110         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8111         vv(1)=pizda(1,1)-pizda(2,2)
8112         vv(2)=pizda(1,2)+pizda(2,1)
8113         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8114      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8115 C Explicit gradient in virtual-dihedral angles.
8116         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8117      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8118      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8119         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8120         vv(1)=pizda(1,1)-pizda(2,2)
8121         vv(2)=pizda(1,2)+pizda(2,1)
8122         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8123      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8124      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8125         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8126         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8127         vv(1)=pizda(1,1)-pizda(2,2)
8128         vv(2)=pizda(1,2)+pizda(2,1)
8129         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8130      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8131      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8132 C Cartesian gradient
8133         do iii=1,2
8134           do kkk=1,5
8135             do lll=1,3
8136               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8137      &          pizda(1,1))
8138               vv(1)=pizda(1,1)-pizda(2,2)
8139               vv(2)=pizda(1,2)+pizda(2,1)
8140               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8141      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8142      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8143             enddo
8144           enddo
8145         enddo
8146 cd        goto 1112
8147 C Contribution from graph IV
8148 cd1110    continue
8149         call transpose2(EE(1,1,itl),auxmat(1,1))
8150         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8151         vv(1)=pizda(1,1)+pizda(2,2)
8152         vv(2)=pizda(2,1)-pizda(1,2)
8153         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8154      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8155 C Explicit gradient in virtual-dihedral angles.
8156         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8157      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8158         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8159         vv(1)=pizda(1,1)+pizda(2,2)
8160         vv(2)=pizda(2,1)-pizda(1,2)
8161         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8162      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8163      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8164 C Cartesian gradient
8165         do iii=1,2
8166           do kkk=1,5
8167             do lll=1,3
8168               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8169      &          pizda(1,1))
8170               vv(1)=pizda(1,1)+pizda(2,2)
8171               vv(2)=pizda(2,1)-pizda(1,2)
8172               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8173      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8174      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8175             enddo
8176           enddo
8177         enddo
8178       else
8179 C Antiparallel orientation
8180 C Contribution from graph III
8181 c        goto 1110
8182         call transpose2(EUg(1,1,j),auxmat(1,1))
8183         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8184         vv(1)=pizda(1,1)-pizda(2,2)
8185         vv(2)=pizda(1,2)+pizda(2,1)
8186         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8187      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8188 C Explicit gradient in virtual-dihedral angles.
8189         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8190      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8191      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8192         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8193         vv(1)=pizda(1,1)-pizda(2,2)
8194         vv(2)=pizda(1,2)+pizda(2,1)
8195         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8196      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8197      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8198         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8199         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8200         vv(1)=pizda(1,1)-pizda(2,2)
8201         vv(2)=pizda(1,2)+pizda(2,1)
8202         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8203      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8204      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8205 C Cartesian gradient
8206         do iii=1,2
8207           do kkk=1,5
8208             do lll=1,3
8209               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8210      &          pizda(1,1))
8211               vv(1)=pizda(1,1)-pizda(2,2)
8212               vv(2)=pizda(1,2)+pizda(2,1)
8213               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8214      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8215      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8216             enddo
8217           enddo
8218         enddo
8219 cd        goto 1112
8220 C Contribution from graph IV
8221 1110    continue
8222         call transpose2(EE(1,1,itj),auxmat(1,1))
8223         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8224         vv(1)=pizda(1,1)+pizda(2,2)
8225         vv(2)=pizda(2,1)-pizda(1,2)
8226         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8227      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8228 C Explicit gradient in virtual-dihedral angles.
8229         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8230      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8231         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8232         vv(1)=pizda(1,1)+pizda(2,2)
8233         vv(2)=pizda(2,1)-pizda(1,2)
8234         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8235      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8236      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8237 C Cartesian gradient
8238         do iii=1,2
8239           do kkk=1,5
8240             do lll=1,3
8241               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8242      &          pizda(1,1))
8243               vv(1)=pizda(1,1)+pizda(2,2)
8244               vv(2)=pizda(2,1)-pizda(1,2)
8245               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8246      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8247      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8248             enddo
8249           enddo
8250         enddo
8251       endif
8252 1112  continue
8253       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8254 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8255 cd        write (2,*) 'ijkl',i,j,k,l
8256 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8257 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8258 cd      endif
8259 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8260 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8261 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8262 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8263       if (j.lt.nres-1) then
8264         j1=j+1
8265         j2=j-1
8266       else
8267         j1=j-1
8268         j2=j-2
8269       endif
8270       if (l.lt.nres-1) then
8271         l1=l+1
8272         l2=l-1
8273       else
8274         l1=l-1
8275         l2=l-2
8276       endif
8277 cd      eij=1.0d0
8278 cd      ekl=1.0d0
8279 cd      ekont=1.0d0
8280 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8281 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8282 C        summed up outside the subrouine as for the other subroutines
8283 C        handling long-range interactions. The old code is commented out
8284 C        with "cgrad" to keep track of changes.
8285       do ll=1,3
8286 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8287 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8288         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8289         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8290 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8291 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8292 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8293 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8294 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8295 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8296 c     &   gradcorr5ij,
8297 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8298 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8299 cgrad        ghalf=0.5d0*ggg1(ll)
8300 cd        ghalf=0.0d0
8301         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8302         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8303         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8304         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8305         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8306         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8307 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8308 cgrad        ghalf=0.5d0*ggg2(ll)
8309 cd        ghalf=0.0d0
8310         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8311         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8312         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8313         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8314         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8315         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8316       enddo
8317 cd      goto 1112
8318 cgrad      do m=i+1,j-1
8319 cgrad        do ll=1,3
8320 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8321 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8322 cgrad        enddo
8323 cgrad      enddo
8324 cgrad      do m=k+1,l-1
8325 cgrad        do ll=1,3
8326 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8327 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8328 cgrad        enddo
8329 cgrad      enddo
8330 c1112  continue
8331 cgrad      do m=i+2,j2
8332 cgrad        do ll=1,3
8333 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8334 cgrad        enddo
8335 cgrad      enddo
8336 cgrad      do m=k+2,l2
8337 cgrad        do ll=1,3
8338 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8339 cgrad        enddo
8340 cgrad      enddo
8341 cd      do iii=1,nres-3
8342 cd        write (2,*) iii,g_corr5_loc(iii)
8343 cd      enddo
8344       eello5=ekont*eel5
8345 cd      write (2,*) 'ekont',ekont
8346 cd      write (iout,*) 'eello5',ekont*eel5
8347       return
8348       end
8349 c--------------------------------------------------------------------------
8350       double precision function eello6(i,j,k,l,jj,kk)
8351       implicit real*8 (a-h,o-z)
8352       include 'DIMENSIONS'
8353       include 'COMMON.IOUNITS'
8354       include 'COMMON.CHAIN'
8355       include 'COMMON.DERIV'
8356       include 'COMMON.INTERACT'
8357       include 'COMMON.CONTACTS'
8358       include 'COMMON.TORSION'
8359       include 'COMMON.VAR'
8360       include 'COMMON.GEO'
8361       include 'COMMON.FFIELD'
8362       double precision ggg1(3),ggg2(3)
8363 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8364 cd        eello6=0.0d0
8365 cd        return
8366 cd      endif
8367 cd      write (iout,*)
8368 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8369 cd     &   ' and',k,l
8370       eello6_1=0.0d0
8371       eello6_2=0.0d0
8372       eello6_3=0.0d0
8373       eello6_4=0.0d0
8374       eello6_5=0.0d0
8375       eello6_6=0.0d0
8376 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8377 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8378       do iii=1,2
8379         do kkk=1,5
8380           do lll=1,3
8381             derx(lll,kkk,iii)=0.0d0
8382           enddo
8383         enddo
8384       enddo
8385 cd      eij=facont_hb(jj,i)
8386 cd      ekl=facont_hb(kk,k)
8387 cd      ekont=eij*ekl
8388 cd      eij=1.0d0
8389 cd      ekl=1.0d0
8390 cd      ekont=1.0d0
8391       if (l.eq.j+1) then
8392         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8393         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8394         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8395         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8396         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8397         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8398       else
8399         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8400         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8401         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8402         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8403         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8404           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8405         else
8406           eello6_5=0.0d0
8407         endif
8408         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8409       endif
8410 C If turn contributions are considered, they will be handled separately.
8411       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8412 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8413 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8414 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8415 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8416 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8417 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8418 cd      goto 1112
8419       if (j.lt.nres-1) then
8420         j1=j+1
8421         j2=j-1
8422       else
8423         j1=j-1
8424         j2=j-2
8425       endif
8426       if (l.lt.nres-1) then
8427         l1=l+1
8428         l2=l-1
8429       else
8430         l1=l-1
8431         l2=l-2
8432       endif
8433       do ll=1,3
8434 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8435 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8436 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8437 cgrad        ghalf=0.5d0*ggg1(ll)
8438 cd        ghalf=0.0d0
8439         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8440         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8441         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8442         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8443         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8444         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8445         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8446         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8447 cgrad        ghalf=0.5d0*ggg2(ll)
8448 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8449 cd        ghalf=0.0d0
8450         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8451         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8452         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8453         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8454         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8455         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8456       enddo
8457 cd      goto 1112
8458 cgrad      do m=i+1,j-1
8459 cgrad        do ll=1,3
8460 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8461 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8462 cgrad        enddo
8463 cgrad      enddo
8464 cgrad      do m=k+1,l-1
8465 cgrad        do ll=1,3
8466 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8467 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8468 cgrad        enddo
8469 cgrad      enddo
8470 cgrad1112  continue
8471 cgrad      do m=i+2,j2
8472 cgrad        do ll=1,3
8473 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8474 cgrad        enddo
8475 cgrad      enddo
8476 cgrad      do m=k+2,l2
8477 cgrad        do ll=1,3
8478 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8479 cgrad        enddo
8480 cgrad      enddo
8481 cd      do iii=1,nres-3
8482 cd        write (2,*) iii,g_corr6_loc(iii)
8483 cd      enddo
8484       eello6=ekont*eel6
8485 cd      write (2,*) 'ekont',ekont
8486 cd      write (iout,*) 'eello6',ekont*eel6
8487       return
8488       end
8489 c--------------------------------------------------------------------------
8490       double precision function eello6_graph1(i,j,k,l,imat,swap)
8491       implicit real*8 (a-h,o-z)
8492       include 'DIMENSIONS'
8493       include 'COMMON.IOUNITS'
8494       include 'COMMON.CHAIN'
8495       include 'COMMON.DERIV'
8496       include 'COMMON.INTERACT'
8497       include 'COMMON.CONTACTS'
8498       include 'COMMON.TORSION'
8499       include 'COMMON.VAR'
8500       include 'COMMON.GEO'
8501       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8502       logical swap
8503       logical lprn
8504       common /kutas/ lprn
8505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8506 C                                                                              C
8507 C      Parallel       Antiparallel                                             C
8508 C                                                                              C
8509 C          o             o                                                     C
8510 C         /l\           /j\                                                    C
8511 C        /   \         /   \                                                   C
8512 C       /| o |         | o |\                                                  C
8513 C     \ j|/k\|  /   \  |/k\|l /                                                C
8514 C      \ /   \ /     \ /   \ /                                                 C
8515 C       o     o       o     o                                                  C
8516 C       i             i                                                        C
8517 C                                                                              C
8518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8519       itk=itortyp(itype(k))
8520       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8521       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8522       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8523       call transpose2(EUgC(1,1,k),auxmat(1,1))
8524       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8525       vv1(1)=pizda1(1,1)-pizda1(2,2)
8526       vv1(2)=pizda1(1,2)+pizda1(2,1)
8527       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8528       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8529       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8530       s5=scalar2(vv(1),Dtobr2(1,i))
8531 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8532       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8533       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8534      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8535      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8536      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8537      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8538      & +scalar2(vv(1),Dtobr2der(1,i)))
8539       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8540       vv1(1)=pizda1(1,1)-pizda1(2,2)
8541       vv1(2)=pizda1(1,2)+pizda1(2,1)
8542       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8543       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8544       if (l.eq.j+1) then
8545         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8546      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8547      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8548      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8549      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8550       else
8551         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8552      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8553      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8554      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8555      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8556       endif
8557       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8558       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8559       vv1(1)=pizda1(1,1)-pizda1(2,2)
8560       vv1(2)=pizda1(1,2)+pizda1(2,1)
8561       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8562      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8563      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8564      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8565       do iii=1,2
8566         if (swap) then
8567           ind=3-iii
8568         else
8569           ind=iii
8570         endif
8571         do kkk=1,5
8572           do lll=1,3
8573             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8574             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8575             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8576             call transpose2(EUgC(1,1,k),auxmat(1,1))
8577             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8578      &        pizda1(1,1))
8579             vv1(1)=pizda1(1,1)-pizda1(2,2)
8580             vv1(2)=pizda1(1,2)+pizda1(2,1)
8581             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8582             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8583      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8584             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8585      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8586             s5=scalar2(vv(1),Dtobr2(1,i))
8587             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8588           enddo
8589         enddo
8590       enddo
8591       return
8592       end
8593 c----------------------------------------------------------------------------
8594       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8595       implicit real*8 (a-h,o-z)
8596       include 'DIMENSIONS'
8597       include 'COMMON.IOUNITS'
8598       include 'COMMON.CHAIN'
8599       include 'COMMON.DERIV'
8600       include 'COMMON.INTERACT'
8601       include 'COMMON.CONTACTS'
8602       include 'COMMON.TORSION'
8603       include 'COMMON.VAR'
8604       include 'COMMON.GEO'
8605       logical swap
8606       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8607      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8608       logical lprn
8609       common /kutas/ lprn
8610 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8611 C                                                                              C
8612 C      Parallel       Antiparallel                                             C
8613 C                                                                              C
8614 C          o             o                                                     C
8615 C     \   /l\           /j\   /                                                C
8616 C      \ /   \         /   \ /                                                 C
8617 C       o| o |         | o |o                                                  C
8618 C     \ j|/k\|      \  |/k\|l                                                  C
8619 C      \ /   \       \ /   \                                                   C
8620 C       o             o                                                        C
8621 C       i             i                                                        C
8622 C                                                                              C
8623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8624 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8625 C AL 7/4/01 s1 would occur in the sixth-order moment,
8626 C           but not in a cluster cumulant
8627 #ifdef MOMENT
8628       s1=dip(1,jj,i)*dip(1,kk,k)
8629 #endif
8630       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8631       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8632       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8633       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8634       call transpose2(EUg(1,1,k),auxmat(1,1))
8635       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8636       vv(1)=pizda(1,1)-pizda(2,2)
8637       vv(2)=pizda(1,2)+pizda(2,1)
8638       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8639 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8640 #ifdef MOMENT
8641       eello6_graph2=-(s1+s2+s3+s4)
8642 #else
8643       eello6_graph2=-(s2+s3+s4)
8644 #endif
8645 c      eello6_graph2=-s3
8646 C Derivatives in gamma(i-1)
8647       if (i.gt.1) then
8648 #ifdef MOMENT
8649         s1=dipderg(1,jj,i)*dip(1,kk,k)
8650 #endif
8651         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8652         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8653         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8654         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8655 #ifdef MOMENT
8656         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8657 #else
8658         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8659 #endif
8660 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8661       endif
8662 C Derivatives in gamma(k-1)
8663 #ifdef MOMENT
8664       s1=dip(1,jj,i)*dipderg(1,kk,k)
8665 #endif
8666       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8667       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8668       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8669       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8670       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8671       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8672       vv(1)=pizda(1,1)-pizda(2,2)
8673       vv(2)=pizda(1,2)+pizda(2,1)
8674       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8675 #ifdef MOMENT
8676       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8677 #else
8678       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8679 #endif
8680 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8681 C Derivatives in gamma(j-1) or gamma(l-1)
8682       if (j.gt.1) then
8683 #ifdef MOMENT
8684         s1=dipderg(3,jj,i)*dip(1,kk,k)
8685 #endif
8686         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8687         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8688         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8689         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8690         vv(1)=pizda(1,1)-pizda(2,2)
8691         vv(2)=pizda(1,2)+pizda(2,1)
8692         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8693 #ifdef MOMENT
8694         if (swap) then
8695           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8696         else
8697           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8698         endif
8699 #endif
8700         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8701 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8702       endif
8703 C Derivatives in gamma(l-1) or gamma(j-1)
8704       if (l.gt.1) then
8705 #ifdef MOMENT
8706         s1=dip(1,jj,i)*dipderg(3,kk,k)
8707 #endif
8708         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8709         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8710         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8711         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8712         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8713         vv(1)=pizda(1,1)-pizda(2,2)
8714         vv(2)=pizda(1,2)+pizda(2,1)
8715         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8716 #ifdef MOMENT
8717         if (swap) then
8718           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8719         else
8720           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8721         endif
8722 #endif
8723         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8724 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8725       endif
8726 C Cartesian derivatives.
8727       if (lprn) then
8728         write (2,*) 'In eello6_graph2'
8729         do iii=1,2
8730           write (2,*) 'iii=',iii
8731           do kkk=1,5
8732             write (2,*) 'kkk=',kkk
8733             do jjj=1,2
8734               write (2,'(3(2f10.5),5x)')
8735      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8736             enddo
8737           enddo
8738         enddo
8739       endif
8740       do iii=1,2
8741         do kkk=1,5
8742           do lll=1,3
8743 #ifdef MOMENT
8744             if (iii.eq.1) then
8745               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8746             else
8747               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8748             endif
8749 #endif
8750             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8751      &        auxvec(1))
8752             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8753             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8754      &        auxvec(1))
8755             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8756             call transpose2(EUg(1,1,k),auxmat(1,1))
8757             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8758      &        pizda(1,1))
8759             vv(1)=pizda(1,1)-pizda(2,2)
8760             vv(2)=pizda(1,2)+pizda(2,1)
8761             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8762 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8763 #ifdef MOMENT
8764             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8765 #else
8766             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8767 #endif
8768             if (swap) then
8769               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8770             else
8771               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8772             endif
8773           enddo
8774         enddo
8775       enddo
8776       return
8777       end
8778 c----------------------------------------------------------------------------
8779       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8780       implicit real*8 (a-h,o-z)
8781       include 'DIMENSIONS'
8782       include 'COMMON.IOUNITS'
8783       include 'COMMON.CHAIN'
8784       include 'COMMON.DERIV'
8785       include 'COMMON.INTERACT'
8786       include 'COMMON.CONTACTS'
8787       include 'COMMON.TORSION'
8788       include 'COMMON.VAR'
8789       include 'COMMON.GEO'
8790       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8791       logical swap
8792 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8793 C                                                                              C
8794 C      Parallel       Antiparallel                                             C
8795 C                                                                              C
8796 C          o             o                                                     C
8797 C         /l\   /   \   /j\                                                    C
8798 C        /   \ /     \ /   \                                                   C
8799 C       /| o |o       o| o |\                                                  C
8800 C       j|/k\|  /      |/k\|l /                                                C
8801 C        /   \ /       /   \ /                                                 C
8802 C       /     o       /     o                                                  C
8803 C       i             i                                                        C
8804 C                                                                              C
8805 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8806 C
8807 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8808 C           energy moment and not to the cluster cumulant.
8809       iti=itortyp(itype(i))
8810       if (j.lt.nres-1) then
8811         itj1=itortyp(itype(j+1))
8812       else
8813         itj1=ntortyp
8814       endif
8815       itk=itortyp(itype(k))
8816       itk1=itortyp(itype(k+1))
8817       if (l.lt.nres-1) then
8818         itl1=itortyp(itype(l+1))
8819       else
8820         itl1=ntortyp
8821       endif
8822 #ifdef MOMENT
8823       s1=dip(4,jj,i)*dip(4,kk,k)
8824 #endif
8825       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8826       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8827       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8828       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8829       call transpose2(EE(1,1,itk),auxmat(1,1))
8830       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8831       vv(1)=pizda(1,1)+pizda(2,2)
8832       vv(2)=pizda(2,1)-pizda(1,2)
8833       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8834 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8835 cd     & "sum",-(s2+s3+s4)
8836 #ifdef MOMENT
8837       eello6_graph3=-(s1+s2+s3+s4)
8838 #else
8839       eello6_graph3=-(s2+s3+s4)
8840 #endif
8841 c      eello6_graph3=-s4
8842 C Derivatives in gamma(k-1)
8843       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8844       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8845       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8846       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8847 C Derivatives in gamma(l-1)
8848       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8849       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8850       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8851       vv(1)=pizda(1,1)+pizda(2,2)
8852       vv(2)=pizda(2,1)-pizda(1,2)
8853       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8854       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8855 C Cartesian derivatives.
8856       do iii=1,2
8857         do kkk=1,5
8858           do lll=1,3
8859 #ifdef MOMENT
8860             if (iii.eq.1) then
8861               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8862             else
8863               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8864             endif
8865 #endif
8866             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8867      &        auxvec(1))
8868             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8869             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8870      &        auxvec(1))
8871             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8872             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8873      &        pizda(1,1))
8874             vv(1)=pizda(1,1)+pizda(2,2)
8875             vv(2)=pizda(2,1)-pizda(1,2)
8876             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8877 #ifdef MOMENT
8878             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8879 #else
8880             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8881 #endif
8882             if (swap) then
8883               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8884             else
8885               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8886             endif
8887 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8888           enddo
8889         enddo
8890       enddo
8891       return
8892       end
8893 c----------------------------------------------------------------------------
8894       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8895       implicit real*8 (a-h,o-z)
8896       include 'DIMENSIONS'
8897       include 'COMMON.IOUNITS'
8898       include 'COMMON.CHAIN'
8899       include 'COMMON.DERIV'
8900       include 'COMMON.INTERACT'
8901       include 'COMMON.CONTACTS'
8902       include 'COMMON.TORSION'
8903       include 'COMMON.VAR'
8904       include 'COMMON.GEO'
8905       include 'COMMON.FFIELD'
8906       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8907      & auxvec1(2),auxmat1(2,2)
8908       logical swap
8909 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8910 C                                                                              C
8911 C      Parallel       Antiparallel                                             C
8912 C                                                                              C
8913 C          o             o                                                     C
8914 C         /l\   /   \   /j\                                                    C
8915 C        /   \ /     \ /   \                                                   C
8916 C       /| o |o       o| o |\                                                  C
8917 C     \ j|/k\|      \  |/k\|l                                                  C
8918 C      \ /   \       \ /   \                                                   C
8919 C       o     \       o     \                                                  C
8920 C       i             i                                                        C
8921 C                                                                              C
8922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8923 C
8924 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8925 C           energy moment and not to the cluster cumulant.
8926 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8927       iti=itortyp(itype(i))
8928       itj=itortyp(itype(j))
8929       if (j.lt.nres-1) then
8930         itj1=itortyp(itype(j+1))
8931       else
8932         itj1=ntortyp
8933       endif
8934       itk=itortyp(itype(k))
8935       if (k.lt.nres-1) then
8936         itk1=itortyp(itype(k+1))
8937       else
8938         itk1=ntortyp
8939       endif
8940       itl=itortyp(itype(l))
8941       if (l.lt.nres-1) then
8942         itl1=itortyp(itype(l+1))
8943       else
8944         itl1=ntortyp
8945       endif
8946 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8947 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8948 cd     & ' itl',itl,' itl1',itl1
8949 #ifdef MOMENT
8950       if (imat.eq.1) then
8951         s1=dip(3,jj,i)*dip(3,kk,k)
8952       else
8953         s1=dip(2,jj,j)*dip(2,kk,l)
8954       endif
8955 #endif
8956       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8957       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8958       if (j.eq.l+1) then
8959         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8960         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8961       else
8962         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8963         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8964       endif
8965       call transpose2(EUg(1,1,k),auxmat(1,1))
8966       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8967       vv(1)=pizda(1,1)-pizda(2,2)
8968       vv(2)=pizda(2,1)+pizda(1,2)
8969       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8970 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8971 #ifdef MOMENT
8972       eello6_graph4=-(s1+s2+s3+s4)
8973 #else
8974       eello6_graph4=-(s2+s3+s4)
8975 #endif
8976 C Derivatives in gamma(i-1)
8977       if (i.gt.1) then
8978 #ifdef MOMENT
8979         if (imat.eq.1) then
8980           s1=dipderg(2,jj,i)*dip(3,kk,k)
8981         else
8982           s1=dipderg(4,jj,j)*dip(2,kk,l)
8983         endif
8984 #endif
8985         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8986         if (j.eq.l+1) then
8987           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8988           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8989         else
8990           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8991           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8992         endif
8993         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8994         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8995 cd          write (2,*) 'turn6 derivatives'
8996 #ifdef MOMENT
8997           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8998 #else
8999           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9000 #endif
9001         else
9002 #ifdef MOMENT
9003           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9004 #else
9005           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9006 #endif
9007         endif
9008       endif
9009 C Derivatives in gamma(k-1)
9010 #ifdef MOMENT
9011       if (imat.eq.1) then
9012         s1=dip(3,jj,i)*dipderg(2,kk,k)
9013       else
9014         s1=dip(2,jj,j)*dipderg(4,kk,l)
9015       endif
9016 #endif
9017       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9018       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9019       if (j.eq.l+1) then
9020         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9021         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9022       else
9023         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9024         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9025       endif
9026       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9027       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9028       vv(1)=pizda(1,1)-pizda(2,2)
9029       vv(2)=pizda(2,1)+pizda(1,2)
9030       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9031       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9032 #ifdef MOMENT
9033         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9034 #else
9035         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9036 #endif
9037       else
9038 #ifdef MOMENT
9039         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9040 #else
9041         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9042 #endif
9043       endif
9044 C Derivatives in gamma(j-1) or gamma(l-1)
9045       if (l.eq.j+1 .and. l.gt.1) then
9046         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9047         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9048         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9049         vv(1)=pizda(1,1)-pizda(2,2)
9050         vv(2)=pizda(2,1)+pizda(1,2)
9051         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9052         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9053       else if (j.gt.1) then
9054         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9055         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9056         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9057         vv(1)=pizda(1,1)-pizda(2,2)
9058         vv(2)=pizda(2,1)+pizda(1,2)
9059         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9060         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9061           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9062         else
9063           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9064         endif
9065       endif
9066 C Cartesian derivatives.
9067       do iii=1,2
9068         do kkk=1,5
9069           do lll=1,3
9070 #ifdef MOMENT
9071             if (iii.eq.1) then
9072               if (imat.eq.1) then
9073                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9074               else
9075                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9076               endif
9077             else
9078               if (imat.eq.1) then
9079                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9080               else
9081                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9082               endif
9083             endif
9084 #endif
9085             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9086      &        auxvec(1))
9087             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9088             if (j.eq.l+1) then
9089               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9090      &          b1(1,itj1),auxvec(1))
9091               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9092             else
9093               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9094      &          b1(1,itl1),auxvec(1))
9095               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9096             endif
9097             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9098      &        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),Dtobr2(1,i))
9102             if (swap) then
9103               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9104 #ifdef MOMENT
9105                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9106      &             -(s1+s2+s4)
9107 #else
9108                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9109      &             -(s2+s4)
9110 #endif
9111                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9112               else
9113 #ifdef MOMENT
9114                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9115 #else
9116                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9117 #endif
9118                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9119               endif
9120             else
9121 #ifdef MOMENT
9122               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9123 #else
9124               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9125 #endif
9126               if (l.eq.j+1) then
9127                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9128               else
9129                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9130               endif
9131             endif
9132           enddo
9133         enddo
9134       enddo
9135       return
9136       end
9137 c----------------------------------------------------------------------------
9138       double precision function eello_turn6(i,jj,kk)
9139       implicit real*8 (a-h,o-z)
9140       include 'DIMENSIONS'
9141       include 'COMMON.IOUNITS'
9142       include 'COMMON.CHAIN'
9143       include 'COMMON.DERIV'
9144       include 'COMMON.INTERACT'
9145       include 'COMMON.CONTACTS'
9146       include 'COMMON.TORSION'
9147       include 'COMMON.VAR'
9148       include 'COMMON.GEO'
9149       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9150      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9151      &  ggg1(3),ggg2(3)
9152       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9153      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9154 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9155 C           the respective energy moment and not to the cluster cumulant.
9156       s1=0.0d0
9157       s8=0.0d0
9158       s13=0.0d0
9159 c
9160       eello_turn6=0.0d0
9161       j=i+4
9162       k=i+1
9163       l=i+3
9164       iti=itortyp(itype(i))
9165       itk=itortyp(itype(k))
9166       itk1=itortyp(itype(k+1))
9167       itl=itortyp(itype(l))
9168       itj=itortyp(itype(j))
9169 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9170 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9171 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9172 cd        eello6=0.0d0
9173 cd        return
9174 cd      endif
9175 cd      write (iout,*)
9176 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9177 cd     &   ' and',k,l
9178 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9179       do iii=1,2
9180         do kkk=1,5
9181           do lll=1,3
9182             derx_turn(lll,kkk,iii)=0.0d0
9183           enddo
9184         enddo
9185       enddo
9186 cd      eij=1.0d0
9187 cd      ekl=1.0d0
9188 cd      ekont=1.0d0
9189       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9190 cd      eello6_5=0.0d0
9191 cd      write (2,*) 'eello6_5',eello6_5
9192 #ifdef MOMENT
9193       call transpose2(AEA(1,1,1),auxmat(1,1))
9194       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9195       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9196       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9197 #endif
9198       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9199       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9200       s2 = scalar2(b1(1,itk),vtemp1(1))
9201 #ifdef MOMENT
9202       call transpose2(AEA(1,1,2),atemp(1,1))
9203       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9204       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9205       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9206 #endif
9207       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9208       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9209       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9210 #ifdef MOMENT
9211       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9212       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9213       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9214       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9215       ss13 = scalar2(b1(1,itk),vtemp4(1))
9216       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9217 #endif
9218 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9219 c      s1=0.0d0
9220 c      s2=0.0d0
9221 c      s8=0.0d0
9222 c      s12=0.0d0
9223 c      s13=0.0d0
9224       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9225 C Derivatives in gamma(i+2)
9226       s1d =0.0d0
9227       s8d =0.0d0
9228 #ifdef MOMENT
9229       call transpose2(AEA(1,1,1),auxmatd(1,1))
9230       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9231       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9232       call transpose2(AEAderg(1,1,2),atempd(1,1))
9233       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9234       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9235 #endif
9236       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9237       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9238       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9239 c      s1d=0.0d0
9240 c      s2d=0.0d0
9241 c      s8d=0.0d0
9242 c      s12d=0.0d0
9243 c      s13d=0.0d0
9244       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9245 C Derivatives in gamma(i+3)
9246 #ifdef MOMENT
9247       call transpose2(AEA(1,1,1),auxmatd(1,1))
9248       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9249       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9250       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9251 #endif
9252       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9253       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9254       s2d = scalar2(b1(1,itk),vtemp1d(1))
9255 #ifdef MOMENT
9256       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9257       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9258 #endif
9259       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9260 #ifdef MOMENT
9261       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9262       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9263       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9264 #endif
9265 c      s1d=0.0d0
9266 c      s2d=0.0d0
9267 c      s8d=0.0d0
9268 c      s12d=0.0d0
9269 c      s13d=0.0d0
9270 #ifdef MOMENT
9271       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9272      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9273 #else
9274       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9275      &               -0.5d0*ekont*(s2d+s12d)
9276 #endif
9277 C Derivatives in gamma(i+4)
9278       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9279       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9280       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9281 #ifdef MOMENT
9282       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9283       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9284       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9285 #endif
9286 c      s1d=0.0d0
9287 c      s2d=0.0d0
9288 c      s8d=0.0d0
9289 C      s12d=0.0d0
9290 c      s13d=0.0d0
9291 #ifdef MOMENT
9292       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9293 #else
9294       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9295 #endif
9296 C Derivatives in gamma(i+5)
9297 #ifdef MOMENT
9298       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9299       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9300       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9301 #endif
9302       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9303       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9304       s2d = scalar2(b1(1,itk),vtemp1d(1))
9305 #ifdef MOMENT
9306       call transpose2(AEA(1,1,2),atempd(1,1))
9307       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9308       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9309 #endif
9310       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9311       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9312 #ifdef MOMENT
9313       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9314       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9315       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9316 #endif
9317 c      s1d=0.0d0
9318 c      s2d=0.0d0
9319 c      s8d=0.0d0
9320 c      s12d=0.0d0
9321 c      s13d=0.0d0
9322 #ifdef MOMENT
9323       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9324      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9325 #else
9326       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9327      &               -0.5d0*ekont*(s2d+s12d)
9328 #endif
9329 C Cartesian derivatives
9330       do iii=1,2
9331         do kkk=1,5
9332           do lll=1,3
9333 #ifdef MOMENT
9334             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9335             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9336             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9337 #endif
9338             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9339             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9340      &          vtemp1d(1))
9341             s2d = scalar2(b1(1,itk),vtemp1d(1))
9342 #ifdef MOMENT
9343             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9344             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9345             s8d = -(atempd(1,1)+atempd(2,2))*
9346      &           scalar2(cc(1,1,itl),vtemp2(1))
9347 #endif
9348             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9349      &           auxmatd(1,1))
9350             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9351             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9352 c      s1d=0.0d0
9353 c      s2d=0.0d0
9354 c      s8d=0.0d0
9355 c      s12d=0.0d0
9356 c      s13d=0.0d0
9357 #ifdef MOMENT
9358             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9359      &        - 0.5d0*(s1d+s2d)
9360 #else
9361             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9362      &        - 0.5d0*s2d
9363 #endif
9364 #ifdef MOMENT
9365             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9366      &        - 0.5d0*(s8d+s12d)
9367 #else
9368             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9369      &        - 0.5d0*s12d
9370 #endif
9371           enddo
9372         enddo
9373       enddo
9374 #ifdef MOMENT
9375       do kkk=1,5
9376         do lll=1,3
9377           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9378      &      achuj_tempd(1,1))
9379           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9380           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9381           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9382           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9383           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9384      &      vtemp4d(1))
9385           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9386           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9387           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9388         enddo
9389       enddo
9390 #endif
9391 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9392 cd     &  16*eel_turn6_num
9393 cd      goto 1112
9394       if (j.lt.nres-1) then
9395         j1=j+1
9396         j2=j-1
9397       else
9398         j1=j-1
9399         j2=j-2
9400       endif
9401       if (l.lt.nres-1) then
9402         l1=l+1
9403         l2=l-1
9404       else
9405         l1=l-1
9406         l2=l-2
9407       endif
9408       do ll=1,3
9409 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9410 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9411 cgrad        ghalf=0.5d0*ggg1(ll)
9412 cd        ghalf=0.0d0
9413         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9414         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9415         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9416      &    +ekont*derx_turn(ll,2,1)
9417         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9418         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9419      &    +ekont*derx_turn(ll,4,1)
9420         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9421         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9422         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9423 cgrad        ghalf=0.5d0*ggg2(ll)
9424 cd        ghalf=0.0d0
9425         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9426      &    +ekont*derx_turn(ll,2,2)
9427         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9428         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9429      &    +ekont*derx_turn(ll,4,2)
9430         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9431         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9432         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9433       enddo
9434 cd      goto 1112
9435 cgrad      do m=i+1,j-1
9436 cgrad        do ll=1,3
9437 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9438 cgrad        enddo
9439 cgrad      enddo
9440 cgrad      do m=k+1,l-1
9441 cgrad        do ll=1,3
9442 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9443 cgrad        enddo
9444 cgrad      enddo
9445 cgrad1112  continue
9446 cgrad      do m=i+2,j2
9447 cgrad        do ll=1,3
9448 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9449 cgrad        enddo
9450 cgrad      enddo
9451 cgrad      do m=k+2,l2
9452 cgrad        do ll=1,3
9453 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9454 cgrad        enddo
9455 cgrad      enddo
9456 cd      do iii=1,nres-3
9457 cd        write (2,*) iii,g_corr6_loc(iii)
9458 cd      enddo
9459       eello_turn6=ekont*eel_turn6
9460 cd      write (2,*) 'ekont',ekont
9461 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9462       return
9463       end
9464
9465 C-----------------------------------------------------------------------------
9466       double precision function scalar(u,v)
9467 !DIR$ INLINEALWAYS scalar
9468 #ifndef OSF
9469 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9470 #endif
9471       implicit none
9472       double precision u(3),v(3)
9473 cd      double precision sc
9474 cd      integer i
9475 cd      sc=0.0d0
9476 cd      do i=1,3
9477 cd        sc=sc+u(i)*v(i)
9478 cd      enddo
9479 cd      scalar=sc
9480
9481       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9482       return
9483       end
9484 crc-------------------------------------------------
9485       SUBROUTINE MATVEC2(A1,V1,V2)
9486 !DIR$ INLINEALWAYS MATVEC2
9487 #ifndef OSF
9488 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9489 #endif
9490       implicit real*8 (a-h,o-z)
9491       include 'DIMENSIONS'
9492       DIMENSION A1(2,2),V1(2),V2(2)
9493 c      DO 1 I=1,2
9494 c        VI=0.0
9495 c        DO 3 K=1,2
9496 c    3     VI=VI+A1(I,K)*V1(K)
9497 c        Vaux(I)=VI
9498 c    1 CONTINUE
9499
9500       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9501       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9502
9503       v2(1)=vaux1
9504       v2(2)=vaux2
9505       END
9506 C---------------------------------------
9507       SUBROUTINE MATMAT2(A1,A2,A3)
9508 #ifndef OSF
9509 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9510 #endif
9511       implicit real*8 (a-h,o-z)
9512       include 'DIMENSIONS'
9513       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9514 c      DIMENSION AI3(2,2)
9515 c        DO  J=1,2
9516 c          A3IJ=0.0
9517 c          DO K=1,2
9518 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9519 c          enddo
9520 c          A3(I,J)=A3IJ
9521 c       enddo
9522 c      enddo
9523
9524       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9525       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9526       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9527       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9528
9529       A3(1,1)=AI3_11
9530       A3(2,1)=AI3_21
9531       A3(1,2)=AI3_12
9532       A3(2,2)=AI3_22
9533       END
9534
9535 c-------------------------------------------------------------------------
9536       double precision function scalar2(u,v)
9537 !DIR$ INLINEALWAYS scalar2
9538       implicit none
9539       double precision u(2),v(2)
9540       double precision sc
9541       integer i
9542       scalar2=u(1)*v(1)+u(2)*v(2)
9543       return
9544       end
9545
9546 C-----------------------------------------------------------------------------
9547
9548       subroutine transpose2(a,at)
9549 !DIR$ INLINEALWAYS transpose2
9550 #ifndef OSF
9551 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9552 #endif
9553       implicit none
9554       double precision a(2,2),at(2,2)
9555       at(1,1)=a(1,1)
9556       at(1,2)=a(2,1)
9557       at(2,1)=a(1,2)
9558       at(2,2)=a(2,2)
9559       return
9560       end
9561 c--------------------------------------------------------------------------
9562       subroutine transpose(n,a,at)
9563       implicit none
9564       integer n,i,j
9565       double precision a(n,n),at(n,n)
9566       do i=1,n
9567         do j=1,n
9568           at(j,i)=a(i,j)
9569         enddo
9570       enddo
9571       return
9572       end
9573 C---------------------------------------------------------------------------
9574       subroutine prodmat3(a1,a2,kk,transp,prod)
9575 !DIR$ INLINEALWAYS prodmat3
9576 #ifndef OSF
9577 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9578 #endif
9579       implicit none
9580       integer i,j
9581       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9582       logical transp
9583 crc      double precision auxmat(2,2),prod_(2,2)
9584
9585       if (transp) then
9586 crc        call transpose2(kk(1,1),auxmat(1,1))
9587 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9588 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9589
9590            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9591      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9592            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9593      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9594            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9595      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9596            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9597      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9598
9599       else
9600 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9601 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9602
9603            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9604      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9605            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9606      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9607            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9608      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9609            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9610      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9611
9612       endif
9613 c      call transpose2(a2(1,1),a2t(1,1))
9614
9615 crc      print *,transp
9616 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9617 crc      print *,((prod(i,j),i=1,2),j=1,2)
9618
9619       return
9620       end
9621