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 C      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           xmedi=mod(xmedi,boxxsize)
2029           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2030           ymedi=mod(ymedi,boxysize)
2031           if (ymedi.lt.0) ymedi=ymedi+boxysize
2032           zmedi=mod(zmedi,boxzsize)
2033           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2034         num_conti=0
2035 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2036         do j=ielstart(i),ielend(i)
2037           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2038           ind=ind+1
2039           iteli=itel(i)
2040           itelj=itel(j)
2041           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2042           r0ij=rpp(iteli,itelj)
2043           r0ijsq=r0ij*r0ij
2044           dxj=dc(1,j)
2045           dyj=dc(2,j)
2046           dzj=dc(3,j)
2047           xj=c(1,j)+0.5D0*dxj
2048           yj=c(2,j)+0.5D0*dyj
2049           zj=c(3,j)+0.5D0*dzj
2050           xj=mod(xj,boxxsize)
2051           if (xj.lt.0) xj=xj+boxxsize
2052           yj=mod(yj,boxysize)
2053           if (yj.lt.0) yj=yj+boxysize
2054           zj=mod(zj,boxzsize)
2055           if (zj.lt.0) zj=zj+boxzsize
2056       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2057       xj_safe=xj
2058       yj_safe=yj
2059       zj_safe=zj
2060       isubchap=0
2061       do xshift=-1,1
2062       do yshift=-1,1
2063       do zshift=-1,1
2064           xj=xj_safe+xshift*boxxsize
2065           yj=yj_safe+yshift*boxysize
2066           zj=zj_safe+zshift*boxzsize
2067           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2068           if(dist_temp.lt.dist_init) then
2069             dist_init=dist_temp
2070             xj_temp=xj
2071             yj_temp=yj
2072             zj_temp=zj
2073             isubchap=1
2074           endif
2075        enddo
2076        enddo
2077        enddo
2078        if (isubchap.eq.1) then
2079           xj=xj_temp-xmedi
2080           yj=yj_temp-ymedi
2081           zj=zj_temp-zmedi
2082        else
2083           xj=xj_safe-xmedi
2084           yj=yj_safe-ymedi
2085           zj=zj_safe-zmedi
2086        endif
2087           rij=xj*xj+yj*yj+zj*zj
2088             sss=sscale(sqrt(rij))
2089             sssgrad=sscagrad(sqrt(rij))
2090           if (rij.lt.r0ijsq) then
2091             evdw1ij=0.25d0*(rij-r0ijsq)**2
2092             fac=rij-r0ijsq
2093           else
2094             evdw1ij=0.0d0
2095             fac=0.0d0
2096           endif
2097           evdw1=evdw1+evdw1ij*sss
2098 C
2099 C Calculate contributions to the Cartesian gradient.
2100 C
2101           ggg(1)=fac*xj*sssgrad
2102           ggg(2)=fac*yj*sssgrad
2103           ggg(3)=fac*zj*sssgrad
2104           do k=1,3
2105             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2106             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2107           enddo
2108 *
2109 * Loop over residues i+1 thru j-1.
2110 *
2111 cgrad          do k=i+1,j-1
2112 cgrad            do l=1,3
2113 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2114 cgrad            enddo
2115 cgrad          enddo
2116         enddo ! j
2117       enddo   ! i
2118 cgrad      do i=nnt,nct-1
2119 cgrad        do k=1,3
2120 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2121 cgrad        enddo
2122 cgrad        do j=i+1,nct-1
2123 cgrad          do k=1,3
2124 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2125 cgrad          enddo
2126 cgrad        enddo
2127 cgrad      enddo
2128       return
2129       end
2130 c------------------------------------------------------------------------------
2131       subroutine vec_and_deriv
2132       implicit real*8 (a-h,o-z)
2133       include 'DIMENSIONS'
2134 #ifdef MPI
2135       include 'mpif.h'
2136 #endif
2137       include 'COMMON.IOUNITS'
2138       include 'COMMON.GEO'
2139       include 'COMMON.VAR'
2140       include 'COMMON.LOCAL'
2141       include 'COMMON.CHAIN'
2142       include 'COMMON.VECTORS'
2143       include 'COMMON.SETUP'
2144       include 'COMMON.TIME1'
2145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2146 C Compute the local reference systems. For reference system (i), the
2147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2149 #ifdef PARVEC
2150       do i=ivec_start,ivec_end
2151 #else
2152       do i=1,nres-1
2153 #endif
2154           if (i.eq.nres-1) then
2155 C Case of the last full residue
2156 C Compute the Z-axis
2157             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2158             costh=dcos(pi-theta(nres))
2159             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2160             do k=1,3
2161               uz(k,i)=fac*uz(k,i)
2162             enddo
2163 C Compute the derivatives of uz
2164             uzder(1,1,1)= 0.0d0
2165             uzder(2,1,1)=-dc_norm(3,i-1)
2166             uzder(3,1,1)= dc_norm(2,i-1)
2167             uzder(1,2,1)= dc_norm(3,i-1)
2168             uzder(2,2,1)= 0.0d0
2169             uzder(3,2,1)=-dc_norm(1,i-1)
2170             uzder(1,3,1)=-dc_norm(2,i-1)
2171             uzder(2,3,1)= dc_norm(1,i-1)
2172             uzder(3,3,1)= 0.0d0
2173             uzder(1,1,2)= 0.0d0
2174             uzder(2,1,2)= dc_norm(3,i)
2175             uzder(3,1,2)=-dc_norm(2,i)
2176             uzder(1,2,2)=-dc_norm(3,i)
2177             uzder(2,2,2)= 0.0d0
2178             uzder(3,2,2)= dc_norm(1,i)
2179             uzder(1,3,2)= dc_norm(2,i)
2180             uzder(2,3,2)=-dc_norm(1,i)
2181             uzder(3,3,2)= 0.0d0
2182 C Compute the Y-axis
2183             facy=fac
2184             do k=1,3
2185               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2186             enddo
2187 C Compute the derivatives of uy
2188             do j=1,3
2189               do k=1,3
2190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2193               enddo
2194               uyder(j,j,1)=uyder(j,j,1)-costh
2195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2196             enddo
2197             do j=1,2
2198               do k=1,3
2199                 do l=1,3
2200                   uygrad(l,k,j,i)=uyder(l,k,j)
2201                   uzgrad(l,k,j,i)=uzder(l,k,j)
2202                 enddo
2203               enddo
2204             enddo
2205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2209           else
2210 C Other residues
2211 C Compute the Z-axis
2212             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2213             costh=dcos(pi-theta(i+2))
2214             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2215             do k=1,3
2216               uz(k,i)=fac*uz(k,i)
2217             enddo
2218 C Compute the derivatives of uz
2219             uzder(1,1,1)= 0.0d0
2220             uzder(2,1,1)=-dc_norm(3,i+1)
2221             uzder(3,1,1)= dc_norm(2,i+1)
2222             uzder(1,2,1)= dc_norm(3,i+1)
2223             uzder(2,2,1)= 0.0d0
2224             uzder(3,2,1)=-dc_norm(1,i+1)
2225             uzder(1,3,1)=-dc_norm(2,i+1)
2226             uzder(2,3,1)= dc_norm(1,i+1)
2227             uzder(3,3,1)= 0.0d0
2228             uzder(1,1,2)= 0.0d0
2229             uzder(2,1,2)= dc_norm(3,i)
2230             uzder(3,1,2)=-dc_norm(2,i)
2231             uzder(1,2,2)=-dc_norm(3,i)
2232             uzder(2,2,2)= 0.0d0
2233             uzder(3,2,2)= dc_norm(1,i)
2234             uzder(1,3,2)= dc_norm(2,i)
2235             uzder(2,3,2)=-dc_norm(1,i)
2236             uzder(3,3,2)= 0.0d0
2237 C Compute the Y-axis
2238             facy=fac
2239             do k=1,3
2240               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2241             enddo
2242 C Compute the derivatives of uy
2243             do j=1,3
2244               do k=1,3
2245                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2246      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2247                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2248               enddo
2249               uyder(j,j,1)=uyder(j,j,1)-costh
2250               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2251             enddo
2252             do j=1,2
2253               do k=1,3
2254                 do l=1,3
2255                   uygrad(l,k,j,i)=uyder(l,k,j)
2256                   uzgrad(l,k,j,i)=uzder(l,k,j)
2257                 enddo
2258               enddo
2259             enddo
2260             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2261             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2262             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2263             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2264           endif
2265       enddo
2266       do i=1,nres-1
2267         vbld_inv_temp(1)=vbld_inv(i+1)
2268         if (i.lt.nres-1) then
2269           vbld_inv_temp(2)=vbld_inv(i+2)
2270           else
2271           vbld_inv_temp(2)=vbld_inv(i)
2272           endif
2273         do j=1,2
2274           do k=1,3
2275             do l=1,3
2276               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2277               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2278             enddo
2279           enddo
2280         enddo
2281       enddo
2282 #if defined(PARVEC) && defined(MPI)
2283       if (nfgtasks1.gt.1) then
2284         time00=MPI_Wtime()
2285 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2286 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2287 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2288         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2289      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2290      &   FG_COMM1,IERR)
2291         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2292      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2293      &   FG_COMM1,IERR)
2294         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2295      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2296      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2297         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2298      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2299      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2300         time_gather=time_gather+MPI_Wtime()-time00
2301       endif
2302 c      if (fg_rank.eq.0) then
2303 c        write (iout,*) "Arrays UY and UZ"
2304 c        do i=1,nres-1
2305 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2306 c     &     (uz(k,i),k=1,3)
2307 c        enddo
2308 c      endif
2309 #endif
2310       return
2311       end
2312 C-----------------------------------------------------------------------------
2313       subroutine check_vecgrad
2314       implicit real*8 (a-h,o-z)
2315       include 'DIMENSIONS'
2316       include 'COMMON.IOUNITS'
2317       include 'COMMON.GEO'
2318       include 'COMMON.VAR'
2319       include 'COMMON.LOCAL'
2320       include 'COMMON.CHAIN'
2321       include 'COMMON.VECTORS'
2322       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2323       dimension uyt(3,maxres),uzt(3,maxres)
2324       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2325       double precision delta /1.0d-7/
2326       call vec_and_deriv
2327 cd      do i=1,nres
2328 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2329 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2330 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2331 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2332 cd     &     (dc_norm(if90,i),if90=1,3)
2333 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2334 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2335 cd          write(iout,'(a)')
2336 cd      enddo
2337       do i=1,nres
2338         do j=1,2
2339           do k=1,3
2340             do l=1,3
2341               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2342               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2343             enddo
2344           enddo
2345         enddo
2346       enddo
2347       call vec_and_deriv
2348       do i=1,nres
2349         do j=1,3
2350           uyt(j,i)=uy(j,i)
2351           uzt(j,i)=uz(j,i)
2352         enddo
2353       enddo
2354       do i=1,nres
2355 cd        write (iout,*) 'i=',i
2356         do k=1,3
2357           erij(k)=dc_norm(k,i)
2358         enddo
2359         do j=1,3
2360           do k=1,3
2361             dc_norm(k,i)=erij(k)
2362           enddo
2363           dc_norm(j,i)=dc_norm(j,i)+delta
2364 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2365 c          do k=1,3
2366 c            dc_norm(k,i)=dc_norm(k,i)/fac
2367 c          enddo
2368 c          write (iout,*) (dc_norm(k,i),k=1,3)
2369 c          write (iout,*) (erij(k),k=1,3)
2370           call vec_and_deriv
2371           do k=1,3
2372             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2373             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2374             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2375             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2376           enddo
2377 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2378 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2379 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2380         enddo
2381         do k=1,3
2382           dc_norm(k,i)=erij(k)
2383         enddo
2384 cd        do k=1,3
2385 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2386 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2387 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2388 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2389 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2390 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2391 cd          write (iout,'(a)')
2392 cd        enddo
2393       enddo
2394       return
2395       end
2396 C--------------------------------------------------------------------------
2397       subroutine set_matrices
2398       implicit real*8 (a-h,o-z)
2399       include 'DIMENSIONS'
2400 #ifdef MPI
2401       include "mpif.h"
2402       include "COMMON.SETUP"
2403       integer IERR
2404       integer status(MPI_STATUS_SIZE)
2405 #endif
2406       include 'COMMON.IOUNITS'
2407       include 'COMMON.GEO'
2408       include 'COMMON.VAR'
2409       include 'COMMON.LOCAL'
2410       include 'COMMON.CHAIN'
2411       include 'COMMON.DERIV'
2412       include 'COMMON.INTERACT'
2413       include 'COMMON.CONTACTS'
2414       include 'COMMON.TORSION'
2415       include 'COMMON.VECTORS'
2416       include 'COMMON.FFIELD'
2417       double precision auxvec(2),auxmat(2,2)
2418 C
2419 C Compute the virtual-bond-torsional-angle dependent quantities needed
2420 C to calculate the el-loc multibody terms of various order.
2421 C
2422 #ifdef PARMAT
2423       do i=ivec_start+2,ivec_end+2
2424 #else
2425       do i=3,nres+1
2426 #endif
2427         if (i .lt. nres+1) then
2428           sin1=dsin(phi(i))
2429           cos1=dcos(phi(i))
2430           sintab(i-2)=sin1
2431           costab(i-2)=cos1
2432           obrot(1,i-2)=cos1
2433           obrot(2,i-2)=sin1
2434           sin2=dsin(2*phi(i))
2435           cos2=dcos(2*phi(i))
2436           sintab2(i-2)=sin2
2437           costab2(i-2)=cos2
2438           obrot2(1,i-2)=cos2
2439           obrot2(2,i-2)=sin2
2440           Ug(1,1,i-2)=-cos1
2441           Ug(1,2,i-2)=-sin1
2442           Ug(2,1,i-2)=-sin1
2443           Ug(2,2,i-2)= cos1
2444           Ug2(1,1,i-2)=-cos2
2445           Ug2(1,2,i-2)=-sin2
2446           Ug2(2,1,i-2)=-sin2
2447           Ug2(2,2,i-2)= cos2
2448         else
2449           costab(i-2)=1.0d0
2450           sintab(i-2)=0.0d0
2451           obrot(1,i-2)=1.0d0
2452           obrot(2,i-2)=0.0d0
2453           obrot2(1,i-2)=0.0d0
2454           obrot2(2,i-2)=0.0d0
2455           Ug(1,1,i-2)=1.0d0
2456           Ug(1,2,i-2)=0.0d0
2457           Ug(2,1,i-2)=0.0d0
2458           Ug(2,2,i-2)=1.0d0
2459           Ug2(1,1,i-2)=0.0d0
2460           Ug2(1,2,i-2)=0.0d0
2461           Ug2(2,1,i-2)=0.0d0
2462           Ug2(2,2,i-2)=0.0d0
2463         endif
2464         if (i .gt. 3 .and. i .lt. nres+1) then
2465           obrot_der(1,i-2)=-sin1
2466           obrot_der(2,i-2)= cos1
2467           Ugder(1,1,i-2)= sin1
2468           Ugder(1,2,i-2)=-cos1
2469           Ugder(2,1,i-2)=-cos1
2470           Ugder(2,2,i-2)=-sin1
2471           dwacos2=cos2+cos2
2472           dwasin2=sin2+sin2
2473           obrot2_der(1,i-2)=-dwasin2
2474           obrot2_der(2,i-2)= dwacos2
2475           Ug2der(1,1,i-2)= dwasin2
2476           Ug2der(1,2,i-2)=-dwacos2
2477           Ug2der(2,1,i-2)=-dwacos2
2478           Ug2der(2,2,i-2)=-dwasin2
2479         else
2480           obrot_der(1,i-2)=0.0d0
2481           obrot_der(2,i-2)=0.0d0
2482           Ugder(1,1,i-2)=0.0d0
2483           Ugder(1,2,i-2)=0.0d0
2484           Ugder(2,1,i-2)=0.0d0
2485           Ugder(2,2,i-2)=0.0d0
2486           obrot2_der(1,i-2)=0.0d0
2487           obrot2_der(2,i-2)=0.0d0
2488           Ug2der(1,1,i-2)=0.0d0
2489           Ug2der(1,2,i-2)=0.0d0
2490           Ug2der(2,1,i-2)=0.0d0
2491           Ug2der(2,2,i-2)=0.0d0
2492         endif
2493 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2494         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2495           iti = itortyp(itype(i-2))
2496         else
2497           iti=ntortyp
2498         endif
2499 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2500         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2501           iti1 = itortyp(itype(i-1))
2502         else
2503           iti1=ntortyp
2504         endif
2505 cd        write (iout,*) '*******i',i,' iti1',iti
2506 cd        write (iout,*) 'b1',b1(:,iti)
2507 cd        write (iout,*) 'b2',b2(:,iti)
2508 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2509 c        if (i .gt. iatel_s+2) then
2510         if (i .gt. nnt+2) then
2511           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2512           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2513           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2514      &    then
2515           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2516           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2517           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2518           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2519           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2520           endif
2521         else
2522           do k=1,2
2523             Ub2(k,i-2)=0.0d0
2524             Ctobr(k,i-2)=0.0d0
2525             Dtobr2(k,i-2)=0.0d0
2526             do l=1,2
2527               EUg(l,k,i-2)=0.0d0
2528               CUg(l,k,i-2)=0.0d0
2529               DUg(l,k,i-2)=0.0d0
2530               DtUg2(l,k,i-2)=0.0d0
2531             enddo
2532           enddo
2533         endif
2534         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2535         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2536         do k=1,2
2537           muder(k,i-2)=Ub2der(k,i-2)
2538         enddo
2539 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2540         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2541           if (itype(i-1).le.ntyp) then
2542             iti1 = itortyp(itype(i-1))
2543           else
2544             iti1=ntortyp
2545           endif
2546         else
2547           iti1=ntortyp
2548         endif
2549         do k=1,2
2550           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2551         enddo
2552 cd        write (iout,*) 'mu ',mu(:,i-2)
2553 cd        write (iout,*) 'mu1',mu1(:,i-2)
2554 cd        write (iout,*) 'mu2',mu2(:,i-2)
2555         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2556      &  then
2557         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2558         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2559         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2560         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2561         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2562 C Vectors and matrices dependent on a single virtual-bond dihedral.
2563         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2564         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2565         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2566         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2567         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2568         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2569         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2570         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2571         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2572         endif
2573       enddo
2574 C Matrices dependent on two consecutive virtual-bond dihedrals.
2575 C The order of matrices is from left to right.
2576       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2577      &then
2578 c      do i=max0(ivec_start,2),ivec_end
2579       do i=2,nres-1
2580         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2581         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2582         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2583         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2584         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2585         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2586         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2587         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2588       enddo
2589       endif
2590 #if defined(MPI) && defined(PARMAT)
2591 #ifdef DEBUG
2592 c      if (fg_rank.eq.0) then
2593         write (iout,*) "Arrays UG and UGDER before GATHER"
2594         do i=1,nres-1
2595           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2596      &     ((ug(l,k,i),l=1,2),k=1,2),
2597      &     ((ugder(l,k,i),l=1,2),k=1,2)
2598         enddo
2599         write (iout,*) "Arrays UG2 and UG2DER"
2600         do i=1,nres-1
2601           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2602      &     ((ug2(l,k,i),l=1,2),k=1,2),
2603      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2604         enddo
2605         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2606         do i=1,nres-1
2607           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2608      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2609      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2610         enddo
2611         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2612         do i=1,nres-1
2613           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2614      &     costab(i),sintab(i),costab2(i),sintab2(i)
2615         enddo
2616         write (iout,*) "Array MUDER"
2617         do i=1,nres-1
2618           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2619         enddo
2620 c      endif
2621 #endif
2622       if (nfgtasks.gt.1) then
2623         time00=MPI_Wtime()
2624 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2625 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2626 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2627 #ifdef MATGATHER
2628         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2630      &   FG_COMM1,IERR)
2631         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2641      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2642      &   FG_COMM1,IERR)
2643         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2644      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2645      &   FG_COMM1,IERR)
2646         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2647      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2648      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2649         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2650      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2651      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2652         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2653      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2654      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2655         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2656      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2657      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2658         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2659      &  then
2660         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2661      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2662      &   FG_COMM1,IERR)
2663         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2664      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2665      &   FG_COMM1,IERR)
2666         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2667      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2668      &   FG_COMM1,IERR)
2669        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2670      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2671      &   FG_COMM1,IERR)
2672         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2673      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2674      &   FG_COMM1,IERR)
2675         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2676      &   ivec_count(fg_rank1),
2677      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2678      &   FG_COMM1,IERR)
2679         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2680      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2681      &   FG_COMM1,IERR)
2682         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2683      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2684      &   FG_COMM1,IERR)
2685         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2701      &   ivec_count(fg_rank1),
2702      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2706      &   FG_COMM1,IERR)
2707        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2712      &   FG_COMM1,IERR)
2713        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2714      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2715      &   FG_COMM1,IERR)
2716         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2717      &   ivec_count(fg_rank1),
2718      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2721      &   ivec_count(fg_rank1),
2722      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2723      &   FG_COMM1,IERR)
2724         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2725      &   ivec_count(fg_rank1),
2726      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2727      &   MPI_MAT2,FG_COMM1,IERR)
2728         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2729      &   ivec_count(fg_rank1),
2730      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2731      &   MPI_MAT2,FG_COMM1,IERR)
2732         endif
2733 #else
2734 c Passes matrix info through the ring
2735       isend=fg_rank1
2736       irecv=fg_rank1-1
2737       if (irecv.lt.0) irecv=nfgtasks1-1
2738       iprev=irecv
2739       inext=fg_rank1+1
2740       if (inext.ge.nfgtasks1) inext=0
2741       do i=1,nfgtasks1-1
2742 c        write (iout,*) "isend",isend," irecv",irecv
2743 c        call flush(iout)
2744         lensend=lentyp(isend)
2745         lenrecv=lentyp(irecv)
2746 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2747 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2748 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2749 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2750 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2751 c        write (iout,*) "Gather ROTAT1"
2752 c        call flush(iout)
2753 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2754 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2755 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2756 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2757 c        write (iout,*) "Gather ROTAT2"
2758 c        call flush(iout)
2759         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2760      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2761      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2762      &   iprev,4400+irecv,FG_COMM,status,IERR)
2763 c        write (iout,*) "Gather ROTAT_OLD"
2764 c        call flush(iout)
2765         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2766      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2767      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2768      &   iprev,5500+irecv,FG_COMM,status,IERR)
2769 c        write (iout,*) "Gather PRECOMP11"
2770 c        call flush(iout)
2771         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2772      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2773      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2774      &   iprev,6600+irecv,FG_COMM,status,IERR)
2775 c        write (iout,*) "Gather PRECOMP12"
2776 c        call flush(iout)
2777         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2778      &  then
2779         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2780      &   MPI_ROTAT2(lensend),inext,7700+isend,
2781      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2782      &   iprev,7700+irecv,FG_COMM,status,IERR)
2783 c        write (iout,*) "Gather PRECOMP21"
2784 c        call flush(iout)
2785         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2786      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2787      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2788      &   iprev,8800+irecv,FG_COMM,status,IERR)
2789 c        write (iout,*) "Gather PRECOMP22"
2790 c        call flush(iout)
2791         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2792      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2793      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2794      &   MPI_PRECOMP23(lenrecv),
2795      &   iprev,9900+irecv,FG_COMM,status,IERR)
2796 c        write (iout,*) "Gather PRECOMP23"
2797 c        call flush(iout)
2798         endif
2799         isend=irecv
2800         irecv=irecv-1
2801         if (irecv.lt.0) irecv=nfgtasks1-1
2802       enddo
2803 #endif
2804         time_gather=time_gather+MPI_Wtime()-time00
2805       endif
2806 #ifdef DEBUG
2807 c      if (fg_rank.eq.0) then
2808         write (iout,*) "Arrays UG and UGDER"
2809         do i=1,nres-1
2810           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2811      &     ((ug(l,k,i),l=1,2),k=1,2),
2812      &     ((ugder(l,k,i),l=1,2),k=1,2)
2813         enddo
2814         write (iout,*) "Arrays UG2 and UG2DER"
2815         do i=1,nres-1
2816           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2817      &     ((ug2(l,k,i),l=1,2),k=1,2),
2818      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2819         enddo
2820         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2821         do i=1,nres-1
2822           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2823      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2824      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2825         enddo
2826         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2827         do i=1,nres-1
2828           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2829      &     costab(i),sintab(i),costab2(i),sintab2(i)
2830         enddo
2831         write (iout,*) "Array MUDER"
2832         do i=1,nres-1
2833           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2834         enddo
2835 c      endif
2836 #endif
2837 #endif
2838 cd      do i=1,nres
2839 cd        iti = itortyp(itype(i))
2840 cd        write (iout,*) i
2841 cd        do j=1,2
2842 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2843 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2844 cd        enddo
2845 cd      enddo
2846       return
2847       end
2848 C--------------------------------------------------------------------------
2849       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2850 C
2851 C This subroutine calculates the average interaction energy and its gradient
2852 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2853 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2854 C The potential depends both on the distance of peptide-group centers and on
2855 C the orientation of the CA-CA virtual bonds.
2856 C
2857       implicit real*8 (a-h,o-z)
2858 #ifdef MPI
2859       include 'mpif.h'
2860 #endif
2861       include 'DIMENSIONS'
2862       include 'COMMON.CONTROL'
2863       include 'COMMON.SETUP'
2864       include 'COMMON.IOUNITS'
2865       include 'COMMON.GEO'
2866       include 'COMMON.VAR'
2867       include 'COMMON.LOCAL'
2868       include 'COMMON.CHAIN'
2869       include 'COMMON.DERIV'
2870       include 'COMMON.INTERACT'
2871       include 'COMMON.CONTACTS'
2872       include 'COMMON.TORSION'
2873       include 'COMMON.VECTORS'
2874       include 'COMMON.FFIELD'
2875       include 'COMMON.TIME1'
2876       include 'COMMON.SPLITELE'
2877       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2878      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2879       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2880      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2881       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2882      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2883      &    num_conti,j1,j2
2884 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2885 #ifdef MOMENT
2886       double precision scal_el /1.0d0/
2887 #else
2888       double precision scal_el /0.5d0/
2889 #endif
2890 C 12/13/98
2891 C 13-go grudnia roku pamietnego...
2892       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2893      &                   0.0d0,1.0d0,0.0d0,
2894      &                   0.0d0,0.0d0,1.0d0/
2895 cd      write(iout,*) 'In EELEC'
2896 cd      do i=1,nloctyp
2897 cd        write(iout,*) 'Type',i
2898 cd        write(iout,*) 'B1',B1(:,i)
2899 cd        write(iout,*) 'B2',B2(:,i)
2900 cd        write(iout,*) 'CC',CC(:,:,i)
2901 cd        write(iout,*) 'DD',DD(:,:,i)
2902 cd        write(iout,*) 'EE',EE(:,:,i)
2903 cd      enddo
2904 cd      call check_vecgrad
2905 cd      stop
2906       if (icheckgrad.eq.1) then
2907         do i=1,nres-1
2908           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2909           do k=1,3
2910             dc_norm(k,i)=dc(k,i)*fac
2911           enddo
2912 c          write (iout,*) 'i',i,' fac',fac
2913         enddo
2914       endif
2915       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2916      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2917      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2918 c        call vec_and_deriv
2919 #ifdef TIMING
2920         time01=MPI_Wtime()
2921 #endif
2922         call set_matrices
2923 #ifdef TIMING
2924         time_mat=time_mat+MPI_Wtime()-time01
2925 #endif
2926       endif
2927 cd      do i=1,nres-1
2928 cd        write (iout,*) 'i=',i
2929 cd        do k=1,3
2930 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2931 cd        enddo
2932 cd        do k=1,3
2933 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2934 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2935 cd        enddo
2936 cd      enddo
2937       t_eelecij=0.0d0
2938       ees=0.0D0
2939       evdw1=0.0D0
2940       eel_loc=0.0d0
2941       eello_turn3=0.0d0
2942       eello_turn4=0.0d0
2943       ind=0
2944       do i=1,nres
2945         num_cont_hb(i)=0
2946       enddo
2947 cd      print '(a)','Enter EELEC'
2948 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2949       do i=1,nres
2950         gel_loc_loc(i)=0.0d0
2951         gcorr_loc(i)=0.0d0
2952       enddo
2953 c
2954 c
2955 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2956 C
2957 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2958 C
2959 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2960       do i=iturn3_start,iturn3_end
2961         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2962      &  .or. itype(i+2).eq.ntyp1
2963      &  .or. itype(i+3).eq.ntyp1
2964      &  .or. itype(i-1).eq.ntyp1
2965      &  .or. itype(i+4).eq.ntyp1
2966      &  ) cycle
2967         dxi=dc(1,i)
2968         dyi=dc(2,i)
2969         dzi=dc(3,i)
2970         dx_normi=dc_norm(1,i)
2971         dy_normi=dc_norm(2,i)
2972         dz_normi=dc_norm(3,i)
2973         xmedi=c(1,i)+0.5d0*dxi
2974         ymedi=c(2,i)+0.5d0*dyi
2975         zmedi=c(3,i)+0.5d0*dzi
2976           xmedi=mod(xmedi,boxxsize)
2977           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2978           ymedi=mod(ymedi,boxysize)
2979           if (ymedi.lt.0) ymedi=ymedi+boxysize
2980           zmedi=mod(zmedi,boxzsize)
2981           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2982         num_conti=0
2983         call eelecij(i,i+2,ees,evdw1,eel_loc)
2984         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2985         num_cont_hb(i)=num_conti
2986       enddo
2987       do i=iturn4_start,iturn4_end
2988         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2989      &    .or. itype(i+3).eq.ntyp1
2990      &    .or. itype(i+4).eq.ntyp1
2991      &    .or. itype(i+5).eq.ntyp1
2992      &    .or. itype(i).eq.ntyp1
2993      &    .or. itype(i-1).eq.ntyp1
2994      &                             ) cycle
2995         dxi=dc(1,i)
2996         dyi=dc(2,i)
2997         dzi=dc(3,i)
2998         dx_normi=dc_norm(1,i)
2999         dy_normi=dc_norm(2,i)
3000         dz_normi=dc_norm(3,i)
3001         xmedi=c(1,i)+0.5d0*dxi
3002         ymedi=c(2,i)+0.5d0*dyi
3003         zmedi=c(3,i)+0.5d0*dzi
3004 C Return atom into box, boxxsize is size of box in x dimension
3005 c  194   continue
3006 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3007 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3008 C Condition for being inside the proper box
3009 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3010 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3011 c        go to 194
3012 c        endif
3013 c  195   continue
3014 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3015 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3016 C Condition for being inside the proper box
3017 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3018 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3019 c        go to 195
3020 c        endif
3021 c  196   continue
3022 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3023 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3024 C Condition for being inside the proper box
3025 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3026 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3027 c        go to 196
3028 c        endif
3029           xmedi=mod(xmedi,boxxsize)
3030           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3031           ymedi=mod(ymedi,boxysize)
3032           if (ymedi.lt.0) ymedi=ymedi+boxysize
3033           zmedi=mod(zmedi,boxzsize)
3034           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3035
3036         num_conti=num_cont_hb(i)
3037         call eelecij(i,i+3,ees,evdw1,eel_loc)
3038         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3039      &   call eturn4(i,eello_turn4)
3040         num_cont_hb(i)=num_conti
3041       enddo   ! i
3042 C Loop over all neighbouring boxes
3043 C      do xshift=-1,1
3044 C      do yshift=-1,1
3045 C      do zshift=-1,1
3046 c
3047 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3048 c
3049       do i=iatel_s,iatel_e
3050         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3051      &  .or. itype(i+2).eq.ntyp1
3052      &  .or. itype(i-1).eq.ntyp1
3053      &                ) cycle
3054         dxi=dc(1,i)
3055         dyi=dc(2,i)
3056         dzi=dc(3,i)
3057         dx_normi=dc_norm(1,i)
3058         dy_normi=dc_norm(2,i)
3059         dz_normi=dc_norm(3,i)
3060         xmedi=c(1,i)+0.5d0*dxi
3061         ymedi=c(2,i)+0.5d0*dyi
3062         zmedi=c(3,i)+0.5d0*dzi
3063           xmedi=mod(xmedi,boxxsize)
3064           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3065           ymedi=mod(ymedi,boxysize)
3066           if (ymedi.lt.0) ymedi=ymedi+boxysize
3067           zmedi=mod(zmedi,boxzsize)
3068           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3069 C          xmedi=xmedi+xshift*boxxsize
3070 C          ymedi=ymedi+yshift*boxysize
3071 C          zmedi=zmedi+zshift*boxzsize
3072
3073 C Return tom into box, boxxsize is size of box in x dimension
3074 c  164   continue
3075 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3076 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3077 C Condition for being inside the proper box
3078 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3079 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3080 c        go to 164
3081 c        endif
3082 c  165   continue
3083 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3084 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3085 C Condition for being inside the proper box
3086 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3087 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3088 c        go to 165
3089 c        endif
3090 c  166   continue
3091 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3092 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3093 cC Condition for being inside the proper box
3094 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3095 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3096 c        go to 166
3097 c        endif
3098
3099 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3100         num_conti=num_cont_hb(i)
3101         do j=ielstart(i),ielend(i)
3102 c          write (iout,*) i,j,itype(i),itype(j)
3103           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3104      & .or.itype(j+2).eq.ntyp1
3105      & .or.itype(j-1).eq.ntyp1
3106      &) cycle
3107           call eelecij(i,j,ees,evdw1,eel_loc)
3108         enddo ! j
3109         num_cont_hb(i)=num_conti
3110       enddo   ! i
3111 C     enddo   ! zshift
3112 C      enddo   ! yshift
3113 C      enddo   ! xshift
3114
3115 c      write (iout,*) "Number of loop steps in EELEC:",ind
3116 cd      do i=1,nres
3117 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3118 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3119 cd      enddo
3120 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3121 ccc      eel_loc=eel_loc+eello_turn3
3122 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3123       return
3124       end
3125 C-------------------------------------------------------------------------------
3126       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3127       implicit real*8 (a-h,o-z)
3128       include 'DIMENSIONS'
3129 #ifdef MPI
3130       include "mpif.h"
3131 #endif
3132       include 'COMMON.CONTROL'
3133       include 'COMMON.IOUNITS'
3134       include 'COMMON.GEO'
3135       include 'COMMON.VAR'
3136       include 'COMMON.LOCAL'
3137       include 'COMMON.CHAIN'
3138       include 'COMMON.DERIV'
3139       include 'COMMON.INTERACT'
3140       include 'COMMON.CONTACTS'
3141       include 'COMMON.TORSION'
3142       include 'COMMON.VECTORS'
3143       include 'COMMON.FFIELD'
3144       include 'COMMON.TIME1'
3145       include 'COMMON.SPLITELE'
3146       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3147      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3148       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3149      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3150       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3151      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3152      &    num_conti,j1,j2
3153 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3154 #ifdef MOMENT
3155       double precision scal_el /1.0d0/
3156 #else
3157       double precision scal_el /0.5d0/
3158 #endif
3159 C 12/13/98
3160 C 13-go grudnia roku pamietnego...
3161       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3162      &                   0.0d0,1.0d0,0.0d0,
3163      &                   0.0d0,0.0d0,1.0d0/
3164 c          time00=MPI_Wtime()
3165 cd      write (iout,*) "eelecij",i,j
3166 c          ind=ind+1
3167           iteli=itel(i)
3168           itelj=itel(j)
3169           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3170           aaa=app(iteli,itelj)
3171           bbb=bpp(iteli,itelj)
3172           ael6i=ael6(iteli,itelj)
3173           ael3i=ael3(iteli,itelj)
3174           dxj=dc(1,j)
3175           dyj=dc(2,j)
3176           dzj=dc(3,j)
3177           dx_normj=dc_norm(1,j)
3178           dy_normj=dc_norm(2,j)
3179           dz_normj=dc_norm(3,j)
3180 C          xj=c(1,j)+0.5D0*dxj-xmedi
3181 C          yj=c(2,j)+0.5D0*dyj-ymedi
3182 C          zj=c(3,j)+0.5D0*dzj-zmedi
3183           xj=c(1,j)+0.5D0*dxj
3184           yj=c(2,j)+0.5D0*dyj
3185           zj=c(3,j)+0.5D0*dzj
3186           xj=mod(xj,boxxsize)
3187           if (xj.lt.0) xj=xj+boxxsize
3188           yj=mod(yj,boxysize)
3189           if (yj.lt.0) yj=yj+boxysize
3190           zj=mod(zj,boxzsize)
3191           if (zj.lt.0) zj=zj+boxzsize
3192           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3193       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3194       xj_safe=xj
3195       yj_safe=yj
3196       zj_safe=zj
3197       isubchap=0
3198       do xshift=-1,1
3199       do yshift=-1,1
3200       do zshift=-1,1
3201           xj=xj_safe+xshift*boxxsize
3202           yj=yj_safe+yshift*boxysize
3203           zj=zj_safe+zshift*boxzsize
3204           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3205           if(dist_temp.lt.dist_init) then
3206             dist_init=dist_temp
3207             xj_temp=xj
3208             yj_temp=yj
3209             zj_temp=zj
3210             isubchap=1
3211           endif
3212        enddo
3213        enddo
3214        enddo
3215        if (isubchap.eq.1) then
3216           xj=xj_temp-xmedi
3217           yj=yj_temp-ymedi
3218           zj=zj_temp-zmedi
3219        else
3220           xj=xj_safe-xmedi
3221           yj=yj_safe-ymedi
3222           zj=zj_safe-zmedi
3223        endif
3224 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3225 c  174   continue
3226 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3227 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3228 C Condition for being inside the proper box
3229 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3230 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3231 c        go to 174
3232 c        endif
3233 c  175   continue
3234 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3235 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3236 C Condition for being inside the proper box
3237 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3238 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3239 c        go to 175
3240 c        endif
3241 c  176   continue
3242 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3243 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3244 C Condition for being inside the proper box
3245 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3246 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3247 c        go to 176
3248 c        endif
3249 C        endif !endPBC condintion
3250 C        xj=xj-xmedi
3251 C        yj=yj-ymedi
3252 C        zj=zj-zmedi
3253           rij=xj*xj+yj*yj+zj*zj
3254
3255             sss=sscale(sqrt(rij))
3256             sssgrad=sscagrad(sqrt(rij))
3257 c            if (sss.gt.0.0d0) then
3258           rrmij=1.0D0/rij
3259           rij=dsqrt(rij)
3260           rmij=1.0D0/rij
3261           r3ij=rrmij*rmij
3262           r6ij=r3ij*r3ij
3263           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3264           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3265           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3266           fac=cosa-3.0D0*cosb*cosg
3267           ev1=aaa*r6ij*r6ij
3268 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3269           if (j.eq.i+2) ev1=scal_el*ev1
3270           ev2=bbb*r6ij
3271           fac3=ael6i*r6ij
3272           fac4=ael3i*r3ij
3273           evdwij=(ev1+ev2)
3274           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3275           el2=fac4*fac
3276 C MARYSIA
3277           eesij=(el1+el2)
3278 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3279           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3280           ees=ees+eesij
3281           evdw1=evdw1+evdwij*sss
3282 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3283 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3284 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3285 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3286
3287           if (energy_dec) then
3288               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3289      &'evdw1',i,j,evdwij
3290      &,iteli,itelj,aaa,evdw1
3291               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3292           endif
3293
3294 C
3295 C Calculate contributions to the Cartesian gradient.
3296 C
3297 #ifdef SPLITELE
3298           facvdw=-6*rrmij*(ev1+evdwij)*sss
3299           facel=-3*rrmij*(el1+eesij)
3300           fac1=fac
3301           erij(1)=xj*rmij
3302           erij(2)=yj*rmij
3303           erij(3)=zj*rmij
3304 *
3305 * Radial derivatives. First process both termini of the fragment (i,j)
3306 *
3307           ggg(1)=facel*xj
3308           ggg(2)=facel*yj
3309           ggg(3)=facel*zj
3310 c          do k=1,3
3311 c            ghalf=0.5D0*ggg(k)
3312 c            gelc(k,i)=gelc(k,i)+ghalf
3313 c            gelc(k,j)=gelc(k,j)+ghalf
3314 c          enddo
3315 c 9/28/08 AL Gradient compotents will be summed only at the end
3316           do k=1,3
3317             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3318             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3319           enddo
3320 *
3321 * Loop over residues i+1 thru j-1.
3322 *
3323 cgrad          do k=i+1,j-1
3324 cgrad            do l=1,3
3325 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3326 cgrad            enddo
3327 cgrad          enddo
3328           if (sss.gt.0.0) then
3329           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3330           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3331           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3332           else
3333           ggg(1)=0.0
3334           ggg(2)=0.0
3335           ggg(3)=0.0
3336           endif
3337 c          do k=1,3
3338 c            ghalf=0.5D0*ggg(k)
3339 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3340 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3341 c          enddo
3342 c 9/28/08 AL Gradient compotents will be summed only at the end
3343           do k=1,3
3344             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3345             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3346           enddo
3347 *
3348 * Loop over residues i+1 thru j-1.
3349 *
3350 cgrad          do k=i+1,j-1
3351 cgrad            do l=1,3
3352 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3353 cgrad            enddo
3354 cgrad          enddo
3355 #else
3356 C MARYSIA
3357           facvdw=(ev1+evdwij)*sss
3358           facel=(el1+eesij)
3359           fac1=fac
3360           fac=-3*rrmij*(facvdw+facvdw+facel)
3361           erij(1)=xj*rmij
3362           erij(2)=yj*rmij
3363           erij(3)=zj*rmij
3364 *
3365 * Radial derivatives. First process both termini of the fragment (i,j)
3366 *
3367           ggg(1)=fac*xj
3368           ggg(2)=fac*yj
3369           ggg(3)=fac*zj
3370 c          do k=1,3
3371 c            ghalf=0.5D0*ggg(k)
3372 c            gelc(k,i)=gelc(k,i)+ghalf
3373 c            gelc(k,j)=gelc(k,j)+ghalf
3374 c          enddo
3375 c 9/28/08 AL Gradient compotents will be summed only at the end
3376           do k=1,3
3377             gelc_long(k,j)=gelc(k,j)+ggg(k)
3378             gelc_long(k,i)=gelc(k,i)-ggg(k)
3379           enddo
3380 *
3381 * Loop over residues i+1 thru j-1.
3382 *
3383 cgrad          do k=i+1,j-1
3384 cgrad            do l=1,3
3385 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3386 cgrad            enddo
3387 cgrad          enddo
3388 c 9/28/08 AL Gradient compotents will be summed only at the end
3389           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3390           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3391           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3392           do k=1,3
3393             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3394             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3395           enddo
3396 #endif
3397 *
3398 * Angular part
3399 *
3400           ecosa=2.0D0*fac3*fac1+fac4
3401           fac4=-3.0D0*fac4
3402           fac3=-6.0D0*fac3
3403           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3404           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3405           do k=1,3
3406             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3407             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3408           enddo
3409 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3410 cd   &          (dcosg(k),k=1,3)
3411           do k=1,3
3412             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3413           enddo
3414 c          do k=1,3
3415 c            ghalf=0.5D0*ggg(k)
3416 c            gelc(k,i)=gelc(k,i)+ghalf
3417 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3418 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3419 c            gelc(k,j)=gelc(k,j)+ghalf
3420 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3421 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3422 c          enddo
3423 cgrad          do k=i+1,j-1
3424 cgrad            do l=1,3
3425 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3426 cgrad            enddo
3427 cgrad          enddo
3428           do k=1,3
3429             gelc(k,i)=gelc(k,i)
3430      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3431      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3432             gelc(k,j)=gelc(k,j)
3433      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3434      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3435             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3436             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3437           enddo
3438 C MARYSIA
3439 c          endif !sscale
3440           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3441      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3442      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3443 C
3444 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3445 C   energy of a peptide unit is assumed in the form of a second-order
3446 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3447 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3448 C   are computed for EVERY pair of non-contiguous peptide groups.
3449 C
3450           if (j.lt.nres-1) then
3451             j1=j+1
3452             j2=j-1
3453           else
3454             j1=j-1
3455             j2=j-2
3456           endif
3457           kkk=0
3458           do k=1,2
3459             do l=1,2
3460               kkk=kkk+1
3461               muij(kkk)=mu(k,i)*mu(l,j)
3462             enddo
3463           enddo
3464 cd         write (iout,*) 'EELEC: i',i,' j',j
3465 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3466 cd          write(iout,*) 'muij',muij
3467           ury=scalar(uy(1,i),erij)
3468           urz=scalar(uz(1,i),erij)
3469           vry=scalar(uy(1,j),erij)
3470           vrz=scalar(uz(1,j),erij)
3471           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3472           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3473           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3474           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3475           fac=dsqrt(-ael6i)*r3ij
3476           a22=a22*fac
3477           a23=a23*fac
3478           a32=a32*fac
3479           a33=a33*fac
3480 cd          write (iout,'(4i5,4f10.5)')
3481 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3482 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3483 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3484 cd     &      uy(:,j),uz(:,j)
3485 cd          write (iout,'(4f10.5)')
3486 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3487 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3488 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3489 cd           write (iout,'(9f10.5/)')
3490 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3491 C Derivatives of the elements of A in virtual-bond vectors
3492           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3493           do k=1,3
3494             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3495             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3496             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3497             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3498             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3499             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3500             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3501             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3502             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3503             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3504             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3505             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3506           enddo
3507 C Compute radial contributions to the gradient
3508           facr=-3.0d0*rrmij
3509           a22der=a22*facr
3510           a23der=a23*facr
3511           a32der=a32*facr
3512           a33der=a33*facr
3513           agg(1,1)=a22der*xj
3514           agg(2,1)=a22der*yj
3515           agg(3,1)=a22der*zj
3516           agg(1,2)=a23der*xj
3517           agg(2,2)=a23der*yj
3518           agg(3,2)=a23der*zj
3519           agg(1,3)=a32der*xj
3520           agg(2,3)=a32der*yj
3521           agg(3,3)=a32der*zj
3522           agg(1,4)=a33der*xj
3523           agg(2,4)=a33der*yj
3524           agg(3,4)=a33der*zj
3525 C Add the contributions coming from er
3526           fac3=-3.0d0*fac
3527           do k=1,3
3528             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3529             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3530             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3531             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3532           enddo
3533           do k=1,3
3534 C Derivatives in DC(i)
3535 cgrad            ghalf1=0.5d0*agg(k,1)
3536 cgrad            ghalf2=0.5d0*agg(k,2)
3537 cgrad            ghalf3=0.5d0*agg(k,3)
3538 cgrad            ghalf4=0.5d0*agg(k,4)
3539             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3540      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3541             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3542      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3543             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3544      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3545             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3546      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3547 C Derivatives in DC(i+1)
3548             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3549      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3550             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3551      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3552             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3553      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3554             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3555      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3556 C Derivatives in DC(j)
3557             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3558      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3559             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3560      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3561             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3562      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3563             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3564      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3565 C Derivatives in DC(j+1) or DC(nres-1)
3566             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3567      &      -3.0d0*vryg(k,3)*ury)
3568             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3569      &      -3.0d0*vrzg(k,3)*ury)
3570             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3571      &      -3.0d0*vryg(k,3)*urz)
3572             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3573      &      -3.0d0*vrzg(k,3)*urz)
3574 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3575 cgrad              do l=1,4
3576 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3577 cgrad              enddo
3578 cgrad            endif
3579           enddo
3580           acipa(1,1)=a22
3581           acipa(1,2)=a23
3582           acipa(2,1)=a32
3583           acipa(2,2)=a33
3584           a22=-a22
3585           a23=-a23
3586           do l=1,2
3587             do k=1,3
3588               agg(k,l)=-agg(k,l)
3589               aggi(k,l)=-aggi(k,l)
3590               aggi1(k,l)=-aggi1(k,l)
3591               aggj(k,l)=-aggj(k,l)
3592               aggj1(k,l)=-aggj1(k,l)
3593             enddo
3594           enddo
3595           if (j.lt.nres-1) then
3596             a22=-a22
3597             a32=-a32
3598             do l=1,3,2
3599               do k=1,3
3600                 agg(k,l)=-agg(k,l)
3601                 aggi(k,l)=-aggi(k,l)
3602                 aggi1(k,l)=-aggi1(k,l)
3603                 aggj(k,l)=-aggj(k,l)
3604                 aggj1(k,l)=-aggj1(k,l)
3605               enddo
3606             enddo
3607           else
3608             a22=-a22
3609             a23=-a23
3610             a32=-a32
3611             a33=-a33
3612             do l=1,4
3613               do k=1,3
3614                 agg(k,l)=-agg(k,l)
3615                 aggi(k,l)=-aggi(k,l)
3616                 aggi1(k,l)=-aggi1(k,l)
3617                 aggj(k,l)=-aggj(k,l)
3618                 aggj1(k,l)=-aggj1(k,l)
3619               enddo
3620             enddo
3621           endif
3622           ENDIF ! WCORR
3623           IF (wel_loc.gt.0.0d0) THEN
3624 C Contribution to the local-electrostatic energy coming from the i-j pair
3625           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3626      &     +a33*muij(4)
3627 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3628 c     &                     ' eel_loc_ij',eel_loc_ij
3629
3630           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3631      &            'eelloc',i,j,eel_loc_ij
3632 c           if (eel_loc_ij.ne.0)
3633 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3634 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3635
3636           eel_loc=eel_loc+eel_loc_ij
3637 C Partial derivatives in virtual-bond dihedral angles gamma
3638           if (i.gt.1)
3639      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3640      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3641      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3642           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3643      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3644      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3645 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3646           do l=1,3
3647             ggg(l)=agg(l,1)*muij(1)+
3648      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3649             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3650             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3651 cgrad            ghalf=0.5d0*ggg(l)
3652 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3653 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3654           enddo
3655 cgrad          do k=i+1,j2
3656 cgrad            do l=1,3
3657 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3658 cgrad            enddo
3659 cgrad          enddo
3660 C Remaining derivatives of eello
3661           do l=1,3
3662             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3663      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3664             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3665      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3666             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3667      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3668             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3669      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3670           enddo
3671           ENDIF
3672 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3673 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3674           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3675      &       .and. num_conti.le.maxconts) then
3676 c            write (iout,*) i,j," entered corr"
3677 C
3678 C Calculate the contact function. The ith column of the array JCONT will
3679 C contain the numbers of atoms that make contacts with the atom I (of numbers
3680 C greater than I). The arrays FACONT and GACONT will contain the values of
3681 C the contact function and its derivative.
3682 c           r0ij=1.02D0*rpp(iteli,itelj)
3683 c           r0ij=1.11D0*rpp(iteli,itelj)
3684             r0ij=2.20D0*rpp(iteli,itelj)
3685 c           r0ij=1.55D0*rpp(iteli,itelj)
3686             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3687             if (fcont.gt.0.0D0) then
3688               num_conti=num_conti+1
3689               if (num_conti.gt.maxconts) then
3690                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3691      &                         ' will skip next contacts for this conf.'
3692               else
3693                 jcont_hb(num_conti,i)=j
3694 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3695 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3696                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3697      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3698 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3699 C  terms.
3700                 d_cont(num_conti,i)=rij
3701 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3702 C     --- Electrostatic-interaction matrix ---
3703                 a_chuj(1,1,num_conti,i)=a22
3704                 a_chuj(1,2,num_conti,i)=a23
3705                 a_chuj(2,1,num_conti,i)=a32
3706                 a_chuj(2,2,num_conti,i)=a33
3707 C     --- Gradient of rij
3708                 do kkk=1,3
3709                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3710                 enddo
3711                 kkll=0
3712                 do k=1,2
3713                   do l=1,2
3714                     kkll=kkll+1
3715                     do m=1,3
3716                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3717                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3718                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3719                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3720                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3721                     enddo
3722                   enddo
3723                 enddo
3724                 ENDIF
3725                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3726 C Calculate contact energies
3727                 cosa4=4.0D0*cosa
3728                 wij=cosa-3.0D0*cosb*cosg
3729                 cosbg1=cosb+cosg
3730                 cosbg2=cosb-cosg
3731 c               fac3=dsqrt(-ael6i)/r0ij**3
3732                 fac3=dsqrt(-ael6i)*r3ij
3733 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3734                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3735                 if (ees0tmp.gt.0) then
3736                   ees0pij=dsqrt(ees0tmp)
3737                 else
3738                   ees0pij=0
3739                 endif
3740 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3741                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3742                 if (ees0tmp.gt.0) then
3743                   ees0mij=dsqrt(ees0tmp)
3744                 else
3745                   ees0mij=0
3746                 endif
3747 c               ees0mij=0.0D0
3748                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3749                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3750 C Diagnostics. Comment out or remove after debugging!
3751 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3752 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3753 c               ees0m(num_conti,i)=0.0D0
3754 C End diagnostics.
3755 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3756 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3757 C Angular derivatives of the contact function
3758                 ees0pij1=fac3/ees0pij
3759                 ees0mij1=fac3/ees0mij
3760                 fac3p=-3.0D0*fac3*rrmij
3761                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3762                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3763 c               ees0mij1=0.0D0
3764                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3765                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3766                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3767                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3768                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3769                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3770                 ecosap=ecosa1+ecosa2
3771                 ecosbp=ecosb1+ecosb2
3772                 ecosgp=ecosg1+ecosg2
3773                 ecosam=ecosa1-ecosa2
3774                 ecosbm=ecosb1-ecosb2
3775                 ecosgm=ecosg1-ecosg2
3776 C Diagnostics
3777 c               ecosap=ecosa1
3778 c               ecosbp=ecosb1
3779 c               ecosgp=ecosg1
3780 c               ecosam=0.0D0
3781 c               ecosbm=0.0D0
3782 c               ecosgm=0.0D0
3783 C End diagnostics
3784                 facont_hb(num_conti,i)=fcont
3785                 fprimcont=fprimcont/rij
3786 cd              facont_hb(num_conti,i)=1.0D0
3787 C Following line is for diagnostics.
3788 cd              fprimcont=0.0D0
3789                 do k=1,3
3790                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3791                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3792                 enddo
3793                 do k=1,3
3794                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3795                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3796                 enddo
3797                 gggp(1)=gggp(1)+ees0pijp*xj
3798                 gggp(2)=gggp(2)+ees0pijp*yj
3799                 gggp(3)=gggp(3)+ees0pijp*zj
3800                 gggm(1)=gggm(1)+ees0mijp*xj
3801                 gggm(2)=gggm(2)+ees0mijp*yj
3802                 gggm(3)=gggm(3)+ees0mijp*zj
3803 C Derivatives due to the contact function
3804                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3805                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3806                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3807                 do k=1,3
3808 c
3809 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3810 c          following the change of gradient-summation algorithm.
3811 c
3812 cgrad                  ghalfp=0.5D0*gggp(k)
3813 cgrad                  ghalfm=0.5D0*gggm(k)
3814                   gacontp_hb1(k,num_conti,i)=!ghalfp
3815      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3816      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3817                   gacontp_hb2(k,num_conti,i)=!ghalfp
3818      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3819      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3820                   gacontp_hb3(k,num_conti,i)=gggp(k)
3821                   gacontm_hb1(k,num_conti,i)=!ghalfm
3822      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3823      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3824                   gacontm_hb2(k,num_conti,i)=!ghalfm
3825      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3826      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3827                   gacontm_hb3(k,num_conti,i)=gggm(k)
3828                 enddo
3829 C Diagnostics. Comment out or remove after debugging!
3830 cdiag           do k=1,3
3831 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3832 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3833 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3834 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3835 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3836 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3837 cdiag           enddo
3838               ENDIF ! wcorr
3839               endif  ! num_conti.le.maxconts
3840             endif  ! fcont.gt.0
3841           endif    ! j.gt.i+1
3842           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3843             do k=1,4
3844               do l=1,3
3845                 ghalf=0.5d0*agg(l,k)
3846                 aggi(l,k)=aggi(l,k)+ghalf
3847                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3848                 aggj(l,k)=aggj(l,k)+ghalf
3849               enddo
3850             enddo
3851             if (j.eq.nres-1 .and. i.lt.j-2) then
3852               do k=1,4
3853                 do l=1,3
3854                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3855                 enddo
3856               enddo
3857             endif
3858           endif
3859 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3860       return
3861       end
3862 C-----------------------------------------------------------------------------
3863       subroutine eturn3(i,eello_turn3)
3864 C Third- and fourth-order contributions from turns
3865       implicit real*8 (a-h,o-z)
3866       include 'DIMENSIONS'
3867       include 'COMMON.IOUNITS'
3868       include 'COMMON.GEO'
3869       include 'COMMON.VAR'
3870       include 'COMMON.LOCAL'
3871       include 'COMMON.CHAIN'
3872       include 'COMMON.DERIV'
3873       include 'COMMON.INTERACT'
3874       include 'COMMON.CONTACTS'
3875       include 'COMMON.TORSION'
3876       include 'COMMON.VECTORS'
3877       include 'COMMON.FFIELD'
3878       include 'COMMON.CONTROL'
3879       dimension ggg(3)
3880       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3881      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3882      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3883       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3884      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3885       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3886      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3887      &    num_conti,j1,j2
3888       j=i+2
3889 c      write (iout,*) "eturn3",i,j,j1,j2
3890       a_temp(1,1)=a22
3891       a_temp(1,2)=a23
3892       a_temp(2,1)=a32
3893       a_temp(2,2)=a33
3894 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3895 C
3896 C               Third-order contributions
3897 C
3898 C                 (i+2)o----(i+3)
3899 C                      | |
3900 C                      | |
3901 C                 (i+1)o----i
3902 C
3903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3904 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3905         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3906         call transpose2(auxmat(1,1),auxmat1(1,1))
3907         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3908         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3909         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3910      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3911 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3912 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3913 cd     &    ' eello_turn3_num',4*eello_turn3_num
3914 C Derivatives in gamma(i)
3915         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3916         call transpose2(auxmat2(1,1),auxmat3(1,1))
3917         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3918         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3919 C Derivatives in gamma(i+1)
3920         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3921         call transpose2(auxmat2(1,1),auxmat3(1,1))
3922         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3923         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3924      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3925 C Cartesian derivatives
3926         do l=1,3
3927 c            ghalf1=0.5d0*agg(l,1)
3928 c            ghalf2=0.5d0*agg(l,2)
3929 c            ghalf3=0.5d0*agg(l,3)
3930 c            ghalf4=0.5d0*agg(l,4)
3931           a_temp(1,1)=aggi(l,1)!+ghalf1
3932           a_temp(1,2)=aggi(l,2)!+ghalf2
3933           a_temp(2,1)=aggi(l,3)!+ghalf3
3934           a_temp(2,2)=aggi(l,4)!+ghalf4
3935           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3936           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3937      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3938           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3939           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3940           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3941           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3942           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3943           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3944      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3945           a_temp(1,1)=aggj(l,1)!+ghalf1
3946           a_temp(1,2)=aggj(l,2)!+ghalf2
3947           a_temp(2,1)=aggj(l,3)!+ghalf3
3948           a_temp(2,2)=aggj(l,4)!+ghalf4
3949           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3950           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3951      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3952           a_temp(1,1)=aggj1(l,1)
3953           a_temp(1,2)=aggj1(l,2)
3954           a_temp(2,1)=aggj1(l,3)
3955           a_temp(2,2)=aggj1(l,4)
3956           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3957           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3958      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3959         enddo
3960       return
3961       end
3962 C-------------------------------------------------------------------------------
3963       subroutine eturn4(i,eello_turn4)
3964 C Third- and fourth-order contributions from turns
3965       implicit real*8 (a-h,o-z)
3966       include 'DIMENSIONS'
3967       include 'COMMON.IOUNITS'
3968       include 'COMMON.GEO'
3969       include 'COMMON.VAR'
3970       include 'COMMON.LOCAL'
3971       include 'COMMON.CHAIN'
3972       include 'COMMON.DERIV'
3973       include 'COMMON.INTERACT'
3974       include 'COMMON.CONTACTS'
3975       include 'COMMON.TORSION'
3976       include 'COMMON.VECTORS'
3977       include 'COMMON.FFIELD'
3978       include 'COMMON.CONTROL'
3979       dimension ggg(3)
3980       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3981      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3982      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3983       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3984      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3985       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3986      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3987      &    num_conti,j1,j2
3988       j=i+3
3989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3990 C
3991 C               Fourth-order contributions
3992 C
3993 C                 (i+3)o----(i+4)
3994 C                     /  |
3995 C               (i+2)o   |
3996 C                     \  |
3997 C                 (i+1)o----i
3998 C
3999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4000 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4001 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4002         a_temp(1,1)=a22
4003         a_temp(1,2)=a23
4004         a_temp(2,1)=a32
4005         a_temp(2,2)=a33
4006         iti1=itortyp(itype(i+1))
4007         iti2=itortyp(itype(i+2))
4008         iti3=itortyp(itype(i+3))
4009 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4010         call transpose2(EUg(1,1,i+1),e1t(1,1))
4011         call transpose2(Eug(1,1,i+2),e2t(1,1))
4012         call transpose2(Eug(1,1,i+3),e3t(1,1))
4013         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4014         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4015         s1=scalar2(b1(1,iti2),auxvec(1))
4016         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4017         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4018         s2=scalar2(b1(1,iti1),auxvec(1))
4019         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4020         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4021         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4022         eello_turn4=eello_turn4-(s1+s2+s3)
4023 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4024         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4025      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4026 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4027 cd     &    ' eello_turn4_num',8*eello_turn4_num
4028 C Derivatives in gamma(i)
4029         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4030         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4031         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4032         s1=scalar2(b1(1,iti2),auxvec(1))
4033         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4034         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4035         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4036 C Derivatives in gamma(i+1)
4037         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4038         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4039         s2=scalar2(b1(1,iti1),auxvec(1))
4040         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4041         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4042         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4043         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4044 C Derivatives in gamma(i+2)
4045         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4046         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4047         s1=scalar2(b1(1,iti2),auxvec(1))
4048         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4049         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4050         s2=scalar2(b1(1,iti1),auxvec(1))
4051         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4052         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4053         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4054         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4055 C Cartesian derivatives
4056 C Derivatives of this turn contributions in DC(i+2)
4057         if (j.lt.nres-1) then
4058           do l=1,3
4059             a_temp(1,1)=agg(l,1)
4060             a_temp(1,2)=agg(l,2)
4061             a_temp(2,1)=agg(l,3)
4062             a_temp(2,2)=agg(l,4)
4063             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4064             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4065             s1=scalar2(b1(1,iti2),auxvec(1))
4066             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4067             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4068             s2=scalar2(b1(1,iti1),auxvec(1))
4069             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4070             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4071             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4072             ggg(l)=-(s1+s2+s3)
4073             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4074           enddo
4075         endif
4076 C Remaining derivatives of this turn contribution
4077         do l=1,3
4078           a_temp(1,1)=aggi(l,1)
4079           a_temp(1,2)=aggi(l,2)
4080           a_temp(2,1)=aggi(l,3)
4081           a_temp(2,2)=aggi(l,4)
4082           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4083           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4084           s1=scalar2(b1(1,iti2),auxvec(1))
4085           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4086           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4087           s2=scalar2(b1(1,iti1),auxvec(1))
4088           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4089           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4090           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4091           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4092           a_temp(1,1)=aggi1(l,1)
4093           a_temp(1,2)=aggi1(l,2)
4094           a_temp(2,1)=aggi1(l,3)
4095           a_temp(2,2)=aggi1(l,4)
4096           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4097           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4098           s1=scalar2(b1(1,iti2),auxvec(1))
4099           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4100           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4101           s2=scalar2(b1(1,iti1),auxvec(1))
4102           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4103           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4104           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4105           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4106           a_temp(1,1)=aggj(l,1)
4107           a_temp(1,2)=aggj(l,2)
4108           a_temp(2,1)=aggj(l,3)
4109           a_temp(2,2)=aggj(l,4)
4110           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4111           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4112           s1=scalar2(b1(1,iti2),auxvec(1))
4113           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4114           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4115           s2=scalar2(b1(1,iti1),auxvec(1))
4116           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4117           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4118           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4119           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4120           a_temp(1,1)=aggj1(l,1)
4121           a_temp(1,2)=aggj1(l,2)
4122           a_temp(2,1)=aggj1(l,3)
4123           a_temp(2,2)=aggj1(l,4)
4124           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4125           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4126           s1=scalar2(b1(1,iti2),auxvec(1))
4127           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4128           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4129           s2=scalar2(b1(1,iti1),auxvec(1))
4130           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4131           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4132           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4133 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4134           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4135         enddo
4136       return
4137       end
4138 C-----------------------------------------------------------------------------
4139       subroutine vecpr(u,v,w)
4140       implicit real*8(a-h,o-z)
4141       dimension u(3),v(3),w(3)
4142       w(1)=u(2)*v(3)-u(3)*v(2)
4143       w(2)=-u(1)*v(3)+u(3)*v(1)
4144       w(3)=u(1)*v(2)-u(2)*v(1)
4145       return
4146       end
4147 C-----------------------------------------------------------------------------
4148       subroutine unormderiv(u,ugrad,unorm,ungrad)
4149 C This subroutine computes the derivatives of a normalized vector u, given
4150 C the derivatives computed without normalization conditions, ugrad. Returns
4151 C ungrad.
4152       implicit none
4153       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4154       double precision vec(3)
4155       double precision scalar
4156       integer i,j
4157 c      write (2,*) 'ugrad',ugrad
4158 c      write (2,*) 'u',u
4159       do i=1,3
4160         vec(i)=scalar(ugrad(1,i),u(1))
4161       enddo
4162 c      write (2,*) 'vec',vec
4163       do i=1,3
4164         do j=1,3
4165           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4166         enddo
4167       enddo
4168 c      write (2,*) 'ungrad',ungrad
4169       return
4170       end
4171 C-----------------------------------------------------------------------------
4172       subroutine escp_soft_sphere(evdw2,evdw2_14)
4173 C
4174 C This subroutine calculates the excluded-volume interaction energy between
4175 C peptide-group centers and side chains and its gradient in virtual-bond and
4176 C side-chain vectors.
4177 C
4178       implicit real*8 (a-h,o-z)
4179       include 'DIMENSIONS'
4180       include 'COMMON.GEO'
4181       include 'COMMON.VAR'
4182       include 'COMMON.LOCAL'
4183       include 'COMMON.CHAIN'
4184       include 'COMMON.DERIV'
4185       include 'COMMON.INTERACT'
4186       include 'COMMON.FFIELD'
4187       include 'COMMON.IOUNITS'
4188       include 'COMMON.CONTROL'
4189       dimension ggg(3)
4190       evdw2=0.0D0
4191       evdw2_14=0.0d0
4192       r0_scp=4.5d0
4193 cd    print '(a)','Enter ESCP'
4194 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4195 C      do xshift=-1,1
4196 C      do yshift=-1,1
4197 C      do zshift=-1,1
4198       do i=iatscp_s,iatscp_e
4199         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4200         iteli=itel(i)
4201         xi=0.5D0*(c(1,i)+c(1,i+1))
4202         yi=0.5D0*(c(2,i)+c(2,i+1))
4203         zi=0.5D0*(c(3,i)+c(3,i+1))
4204 C Return atom into box, boxxsize is size of box in x dimension
4205 c  134   continue
4206 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4207 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4208 C Condition for being inside the proper box
4209 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4210 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4211 c        go to 134
4212 c        endif
4213 c  135   continue
4214 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4215 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4216 C Condition for being inside the proper box
4217 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4218 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4219 c        go to 135
4220 c c       endif
4221 c  136   continue
4222 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4223 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4224 cC Condition for being inside the proper box
4225 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4226 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4227 c        go to 136
4228 c        endif
4229           xi=mod(xi,boxxsize)
4230           if (xi.lt.0) xi=xi+boxxsize
4231           yi=mod(yi,boxysize)
4232           if (yi.lt.0) yi=yi+boxysize
4233           zi=mod(zi,boxzsize)
4234           if (zi.lt.0) zi=zi+boxzsize
4235 C          xi=xi+xshift*boxxsize
4236 C          yi=yi+yshift*boxysize
4237 C          zi=zi+zshift*boxzsize
4238         do iint=1,nscp_gr(i)
4239
4240         do j=iscpstart(i,iint),iscpend(i,iint)
4241           if (itype(j).eq.ntyp1) cycle
4242           itypj=iabs(itype(j))
4243 C Uncomment following three lines for SC-p interactions
4244 c         xj=c(1,nres+j)-xi
4245 c         yj=c(2,nres+j)-yi
4246 c         zj=c(3,nres+j)-zi
4247 C Uncomment following three lines for Ca-p interactions
4248           xj=c(1,j)
4249           yj=c(2,j)
4250           zj=c(3,j)
4251 c  174   continue
4252 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4253 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4254 C Condition for being inside the proper box
4255 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4256 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4257 c        go to 174
4258 c        endif
4259 c  175   continue
4260 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4261 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4262 cC Condition for being inside the proper box
4263 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4264 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4265 c        go to 175
4266 c        endif
4267 c  176   continue
4268 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4269 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4270 C Condition for being inside the proper box
4271 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4272 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4273 c        go to 176
4274           xj=mod(xj,boxxsize)
4275           if (xj.lt.0) xj=xj+boxxsize
4276           yj=mod(yj,boxysize)
4277           if (yj.lt.0) yj=yj+boxysize
4278           zj=mod(zj,boxzsize)
4279           if (zj.lt.0) zj=zj+boxzsize
4280       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4281       xj_safe=xj
4282       yj_safe=yj
4283       zj_safe=zj
4284       subchap=0
4285       do xshift=-1,1
4286       do yshift=-1,1
4287       do zshift=-1,1
4288           xj=xj_safe+xshift*boxxsize
4289           yj=yj_safe+yshift*boxysize
4290           zj=zj_safe+zshift*boxzsize
4291           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4292           if(dist_temp.lt.dist_init) then
4293             dist_init=dist_temp
4294             xj_temp=xj
4295             yj_temp=yj
4296             zj_temp=zj
4297             subchap=1
4298           endif
4299        enddo
4300        enddo
4301        enddo
4302        if (subchap.eq.1) then
4303           xj=xj_temp-xi
4304           yj=yj_temp-yi
4305           zj=zj_temp-zi
4306        else
4307           xj=xj_safe-xi
4308           yj=yj_safe-yi
4309           zj=zj_safe-zi
4310        endif
4311 c c       endif
4312 C          xj=xj-xi
4313 C          yj=yj-yi
4314 C          zj=zj-zi
4315           rij=xj*xj+yj*yj+zj*zj
4316
4317           r0ij=r0_scp
4318           r0ijsq=r0ij*r0ij
4319           if (rij.lt.r0ijsq) then
4320             evdwij=0.25d0*(rij-r0ijsq)**2
4321             fac=rij-r0ijsq
4322           else
4323             evdwij=0.0d0
4324             fac=0.0d0
4325           endif
4326           evdw2=evdw2+evdwij
4327 C
4328 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4329 C
4330           ggg(1)=xj*fac
4331           ggg(2)=yj*fac
4332           ggg(3)=zj*fac
4333 cgrad          if (j.lt.i) then
4334 cd          write (iout,*) 'j<i'
4335 C Uncomment following three lines for SC-p interactions
4336 c           do k=1,3
4337 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4338 c           enddo
4339 cgrad          else
4340 cd          write (iout,*) 'j>i'
4341 cgrad            do k=1,3
4342 cgrad              ggg(k)=-ggg(k)
4343 C Uncomment following line for SC-p interactions
4344 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4345 cgrad            enddo
4346 cgrad          endif
4347 cgrad          do k=1,3
4348 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4349 cgrad          enddo
4350 cgrad          kstart=min0(i+1,j)
4351 cgrad          kend=max0(i-1,j-1)
4352 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4353 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4354 cgrad          do k=kstart,kend
4355 cgrad            do l=1,3
4356 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4357 cgrad            enddo
4358 cgrad          enddo
4359           do k=1,3
4360             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4361             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4362           enddo
4363         enddo
4364
4365         enddo ! iint
4366       enddo ! i
4367 C      enddo !zshift
4368 C      enddo !yshift
4369 C      enddo !xshift
4370       return
4371       end
4372 C-----------------------------------------------------------------------------
4373       subroutine escp(evdw2,evdw2_14)
4374 C
4375 C This subroutine calculates the excluded-volume interaction energy between
4376 C peptide-group centers and side chains and its gradient in virtual-bond and
4377 C side-chain vectors.
4378 C
4379       implicit real*8 (a-h,o-z)
4380       include 'DIMENSIONS'
4381       include 'COMMON.GEO'
4382       include 'COMMON.VAR'
4383       include 'COMMON.LOCAL'
4384       include 'COMMON.CHAIN'
4385       include 'COMMON.DERIV'
4386       include 'COMMON.INTERACT'
4387       include 'COMMON.FFIELD'
4388       include 'COMMON.IOUNITS'
4389       include 'COMMON.CONTROL'
4390       include 'COMMON.SPLITELE'
4391       dimension ggg(3)
4392       evdw2=0.0D0
4393       evdw2_14=0.0d0
4394 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4395 cd    print '(a)','Enter ESCP'
4396 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4397 C      do xshift=-1,1
4398 C      do yshift=-1,1
4399 C      do zshift=-1,1
4400       do i=iatscp_s,iatscp_e
4401         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4402         iteli=itel(i)
4403         xi=0.5D0*(c(1,i)+c(1,i+1))
4404         yi=0.5D0*(c(2,i)+c(2,i+1))
4405         zi=0.5D0*(c(3,i)+c(3,i+1))
4406           xi=mod(xi,boxxsize)
4407           if (xi.lt.0) xi=xi+boxxsize
4408           yi=mod(yi,boxysize)
4409           if (yi.lt.0) yi=yi+boxysize
4410           zi=mod(zi,boxzsize)
4411           if (zi.lt.0) zi=zi+boxzsize
4412 c          xi=xi+xshift*boxxsize
4413 c          yi=yi+yshift*boxysize
4414 c          zi=zi+zshift*boxzsize
4415 c        print *,xi,yi,zi,'polozenie i'
4416 C Return atom into box, boxxsize is size of box in x dimension
4417 c  134   continue
4418 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4419 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4420 C Condition for being inside the proper box
4421 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4422 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4423 c        go to 134
4424 c        endif
4425 c  135   continue
4426 c          print *,xi,boxxsize,"pierwszy"
4427
4428 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4429 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4430 C Condition for being inside the proper box
4431 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4432 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4433 c        go to 135
4434 c        endif
4435 c  136   continue
4436 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4437 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4438 C Condition for being inside the proper box
4439 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4440 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4441 c        go to 136
4442 c        endif
4443         do iint=1,nscp_gr(i)
4444
4445         do j=iscpstart(i,iint),iscpend(i,iint)
4446           itypj=iabs(itype(j))
4447           if (itypj.eq.ntyp1) cycle
4448 C Uncomment following three lines for SC-p interactions
4449 c         xj=c(1,nres+j)-xi
4450 c         yj=c(2,nres+j)-yi
4451 c         zj=c(3,nres+j)-zi
4452 C Uncomment following three lines for Ca-p interactions
4453           xj=c(1,j)
4454           yj=c(2,j)
4455           zj=c(3,j)
4456           xj=mod(xj,boxxsize)
4457           if (xj.lt.0) xj=xj+boxxsize
4458           yj=mod(yj,boxysize)
4459           if (yj.lt.0) yj=yj+boxysize
4460           zj=mod(zj,boxzsize)
4461           if (zj.lt.0) zj=zj+boxzsize
4462 c  174   continue
4463 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4464 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4465 C Condition for being inside the proper box
4466 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4467 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4468 c        go to 174
4469 c        endif
4470 c  175   continue
4471 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4472 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4473 cC Condition for being inside the proper box
4474 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4475 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4476 c        go to 175
4477 c        endif
4478 c  176   continue
4479 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4480 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4481 C Condition for being inside the proper box
4482 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4483 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4484 c        go to 176
4485 c        endif
4486 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4487       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4488       xj_safe=xj
4489       yj_safe=yj
4490       zj_safe=zj
4491       subchap=0
4492       do xshift=-1,1
4493       do yshift=-1,1
4494       do zshift=-1,1
4495           xj=xj_safe+xshift*boxxsize
4496           yj=yj_safe+yshift*boxysize
4497           zj=zj_safe+zshift*boxzsize
4498           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4499           if(dist_temp.lt.dist_init) then
4500             dist_init=dist_temp
4501             xj_temp=xj
4502             yj_temp=yj
4503             zj_temp=zj
4504             subchap=1
4505           endif
4506        enddo
4507        enddo
4508        enddo
4509        if (subchap.eq.1) then
4510           xj=xj_temp-xi
4511           yj=yj_temp-yi
4512           zj=zj_temp-zi
4513        else
4514           xj=xj_safe-xi
4515           yj=yj_safe-yi
4516           zj=zj_safe-zi
4517        endif
4518 c          print *,xj,yj,zj,'polozenie j'
4519           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4520 c          print *,rrij
4521           sss=sscale(1.0d0/(dsqrt(rrij)))
4522 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4523 c          if (sss.eq.0) print *,'czasem jest OK'
4524           if (sss.le.0.0d0) cycle
4525           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4526           fac=rrij**expon2
4527           e1=fac*fac*aad(itypj,iteli)
4528           e2=fac*bad(itypj,iteli)
4529           if (iabs(j-i) .le. 2) then
4530             e1=scal14*e1
4531             e2=scal14*e2
4532             evdw2_14=evdw2_14+(e1+e2)*sss
4533           endif
4534           evdwij=e1+e2
4535           evdw2=evdw2+evdwij*sss
4536           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4537      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4538      &       bad(itypj,iteli)
4539 C
4540 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4541 C
4542           fac=-(evdwij+e1)*rrij*sss
4543           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4544           ggg(1)=xj*fac
4545           ggg(2)=yj*fac
4546           ggg(3)=zj*fac
4547 cgrad          if (j.lt.i) then
4548 cd          write (iout,*) 'j<i'
4549 C Uncomment following three lines for SC-p interactions
4550 c           do k=1,3
4551 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4552 c           enddo
4553 cgrad          else
4554 cd          write (iout,*) 'j>i'
4555 cgrad            do k=1,3
4556 cgrad              ggg(k)=-ggg(k)
4557 C Uncomment following line for SC-p interactions
4558 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4559 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4560 cgrad            enddo
4561 cgrad          endif
4562 cgrad          do k=1,3
4563 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4564 cgrad          enddo
4565 cgrad          kstart=min0(i+1,j)
4566 cgrad          kend=max0(i-1,j-1)
4567 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4568 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4569 cgrad          do k=kstart,kend
4570 cgrad            do l=1,3
4571 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4572 cgrad            enddo
4573 cgrad          enddo
4574           do k=1,3
4575             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4576             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4577           enddo
4578 c        endif !endif for sscale cutoff
4579         enddo ! j
4580
4581         enddo ! iint
4582       enddo ! i
4583 c      enddo !zshift
4584 c      enddo !yshift
4585 c      enddo !xshift
4586       do i=1,nct
4587         do j=1,3
4588           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4589           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4590           gradx_scp(j,i)=expon*gradx_scp(j,i)
4591         enddo
4592       enddo
4593 C******************************************************************************
4594 C
4595 C                              N O T E !!!
4596 C
4597 C To save time the factor EXPON has been extracted from ALL components
4598 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4599 C use!
4600 C
4601 C******************************************************************************
4602       return
4603       end
4604 C--------------------------------------------------------------------------
4605       subroutine edis(ehpb)
4606 C
4607 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4608 C
4609       implicit real*8 (a-h,o-z)
4610       include 'DIMENSIONS'
4611       include 'COMMON.SBRIDGE'
4612       include 'COMMON.CHAIN'
4613       include 'COMMON.DERIV'
4614       include 'COMMON.VAR'
4615       include 'COMMON.INTERACT'
4616       include 'COMMON.IOUNITS'
4617       dimension ggg(3)
4618       ehpb=0.0D0
4619 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4620 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4621       if (link_end.eq.0) return
4622       do i=link_start,link_end
4623 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4624 C CA-CA distance used in regularization of structure.
4625         ii=ihpb(i)
4626         jj=jhpb(i)
4627 C iii and jjj point to the residues for which the distance is assigned.
4628         if (ii.gt.nres) then
4629           iii=ii-nres
4630           jjj=jj-nres
4631         else
4632           iii=ii
4633           jjj=jj
4634         endif
4635 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4636 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4637 C    distance and angle dependent SS bond potential.
4638         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4639      & iabs(itype(jjj)).eq.1) then
4640           call ssbond_ene(iii,jjj,eij)
4641           ehpb=ehpb+2*eij
4642 cd          write (iout,*) "eij",eij
4643         else
4644 C Calculate the distance between the two points and its difference from the
4645 C target distance.
4646         dd=dist(ii,jj)
4647         rdis=dd-dhpb(i)
4648 C Get the force constant corresponding to this distance.
4649         waga=forcon(i)
4650 C Calculate the contribution to energy.
4651         ehpb=ehpb+waga*rdis*rdis
4652 C
4653 C Evaluate gradient.
4654 C
4655         fac=waga*rdis/dd
4656 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4657 cd   &   ' waga=',waga,' fac=',fac
4658         do j=1,3
4659           ggg(j)=fac*(c(j,jj)-c(j,ii))
4660         enddo
4661 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4662 C If this is a SC-SC distance, we need to calculate the contributions to the
4663 C Cartesian gradient in the SC vectors (ghpbx).
4664         if (iii.lt.ii) then
4665           do j=1,3
4666             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4667             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4668           enddo
4669         endif
4670 cgrad        do j=iii,jjj-1
4671 cgrad          do k=1,3
4672 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4673 cgrad          enddo
4674 cgrad        enddo
4675         do k=1,3
4676           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4677           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4678         enddo
4679         endif
4680       enddo
4681       ehpb=0.5D0*ehpb
4682       return
4683       end
4684 C--------------------------------------------------------------------------
4685       subroutine ssbond_ene(i,j,eij)
4686 C
4687 C Calculate the distance and angle dependent SS-bond potential energy
4688 C using a free-energy function derived based on RHF/6-31G** ab initio
4689 C calculations of diethyl disulfide.
4690 C
4691 C A. Liwo and U. Kozlowska, 11/24/03
4692 C
4693       implicit real*8 (a-h,o-z)
4694       include 'DIMENSIONS'
4695       include 'COMMON.SBRIDGE'
4696       include 'COMMON.CHAIN'
4697       include 'COMMON.DERIV'
4698       include 'COMMON.LOCAL'
4699       include 'COMMON.INTERACT'
4700       include 'COMMON.VAR'
4701       include 'COMMON.IOUNITS'
4702       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4703       itypi=iabs(itype(i))
4704       xi=c(1,nres+i)
4705       yi=c(2,nres+i)
4706       zi=c(3,nres+i)
4707       dxi=dc_norm(1,nres+i)
4708       dyi=dc_norm(2,nres+i)
4709       dzi=dc_norm(3,nres+i)
4710 c      dsci_inv=dsc_inv(itypi)
4711       dsci_inv=vbld_inv(nres+i)
4712       itypj=iabs(itype(j))
4713 c      dscj_inv=dsc_inv(itypj)
4714       dscj_inv=vbld_inv(nres+j)
4715       xj=c(1,nres+j)-xi
4716       yj=c(2,nres+j)-yi
4717       zj=c(3,nres+j)-zi
4718       dxj=dc_norm(1,nres+j)
4719       dyj=dc_norm(2,nres+j)
4720       dzj=dc_norm(3,nres+j)
4721       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4722       rij=dsqrt(rrij)
4723       erij(1)=xj*rij
4724       erij(2)=yj*rij
4725       erij(3)=zj*rij
4726       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4727       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4728       om12=dxi*dxj+dyi*dyj+dzi*dzj
4729       do k=1,3
4730         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4731         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4732       enddo
4733       rij=1.0d0/rij
4734       deltad=rij-d0cm
4735       deltat1=1.0d0-om1
4736       deltat2=1.0d0+om2
4737       deltat12=om2-om1+2.0d0
4738       cosphi=om12-om1*om2
4739       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4740      &  +akct*deltad*deltat12
4741      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4742 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4743 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4744 c     &  " deltat12",deltat12," eij",eij
4745       ed=2*akcm*deltad+akct*deltat12
4746       pom1=akct*deltad
4747       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4748       eom1=-2*akth*deltat1-pom1-om2*pom2
4749       eom2= 2*akth*deltat2+pom1-om1*pom2
4750       eom12=pom2
4751       do k=1,3
4752         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4753         ghpbx(k,i)=ghpbx(k,i)-ggk
4754      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4755      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4756         ghpbx(k,j)=ghpbx(k,j)+ggk
4757      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4758      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4759         ghpbc(k,i)=ghpbc(k,i)-ggk
4760         ghpbc(k,j)=ghpbc(k,j)+ggk
4761       enddo
4762 C
4763 C Calculate the components of the gradient in DC and X
4764 C
4765 cgrad      do k=i,j-1
4766 cgrad        do l=1,3
4767 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4768 cgrad        enddo
4769 cgrad      enddo
4770       return
4771       end
4772 C--------------------------------------------------------------------------
4773       subroutine ebond(estr)
4774 c
4775 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4776 c
4777       implicit real*8 (a-h,o-z)
4778       include 'DIMENSIONS'
4779       include 'COMMON.LOCAL'
4780       include 'COMMON.GEO'
4781       include 'COMMON.INTERACT'
4782       include 'COMMON.DERIV'
4783       include 'COMMON.VAR'
4784       include 'COMMON.CHAIN'
4785       include 'COMMON.IOUNITS'
4786       include 'COMMON.NAMES'
4787       include 'COMMON.FFIELD'
4788       include 'COMMON.CONTROL'
4789       include 'COMMON.SETUP'
4790       double precision u(3),ud(3)
4791       estr=0.0d0
4792       estr1=0.0d0
4793       do i=ibondp_start,ibondp_end
4794         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4795 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4796 c          do j=1,3
4797 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4798 c     &      *dc(j,i-1)/vbld(i)
4799 c          enddo
4800 c          if (energy_dec) write(iout,*)
4801 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4802 c        else
4803 C       Checking if it involves dummy (NH3+ or COO-) group
4804          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4805 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4806         diff = vbld(i)-vbldpDUM
4807          else
4808 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4809         diff = vbld(i)-vbldp0
4810          endif
4811         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4812      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4813         estr=estr+diff*diff
4814         do j=1,3
4815           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4816         enddo
4817 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4818 c        endif
4819       enddo
4820       estr=0.5d0*AKP*estr+estr1
4821 c
4822 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4823 c
4824       do i=ibond_start,ibond_end
4825         iti=iabs(itype(i))
4826         if (iti.ne.10 .and. iti.ne.ntyp1) then
4827           nbi=nbondterm(iti)
4828           if (nbi.eq.1) then
4829             diff=vbld(i+nres)-vbldsc0(1,iti)
4830             if (energy_dec)  write (iout,*)
4831      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4832      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4833             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4834             do j=1,3
4835               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4836             enddo
4837           else
4838             do j=1,nbi
4839               diff=vbld(i+nres)-vbldsc0(j,iti)
4840               ud(j)=aksc(j,iti)*diff
4841               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4842             enddo
4843             uprod=u(1)
4844             do j=2,nbi
4845               uprod=uprod*u(j)
4846             enddo
4847             usum=0.0d0
4848             usumsqder=0.0d0
4849             do j=1,nbi
4850               uprod1=1.0d0
4851               uprod2=1.0d0
4852               do k=1,nbi
4853                 if (k.ne.j) then
4854                   uprod1=uprod1*u(k)
4855                   uprod2=uprod2*u(k)*u(k)
4856                 endif
4857               enddo
4858               usum=usum+uprod1
4859               usumsqder=usumsqder+ud(j)*uprod2
4860             enddo
4861             estr=estr+uprod/usum
4862             do j=1,3
4863              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4864             enddo
4865           endif
4866         endif
4867       enddo
4868       return
4869       end
4870 #ifdef CRYST_THETA
4871 C--------------------------------------------------------------------------
4872       subroutine ebend(etheta)
4873 C
4874 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4875 C angles gamma and its derivatives in consecutive thetas and gammas.
4876 C
4877       implicit real*8 (a-h,o-z)
4878       include 'DIMENSIONS'
4879       include 'COMMON.LOCAL'
4880       include 'COMMON.GEO'
4881       include 'COMMON.INTERACT'
4882       include 'COMMON.DERIV'
4883       include 'COMMON.VAR'
4884       include 'COMMON.CHAIN'
4885       include 'COMMON.IOUNITS'
4886       include 'COMMON.NAMES'
4887       include 'COMMON.FFIELD'
4888       include 'COMMON.CONTROL'
4889       common /calcthet/ term1,term2,termm,diffak,ratak,
4890      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4891      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4892       double precision y(2),z(2)
4893       delta=0.02d0*pi
4894 c      time11=dexp(-2*time)
4895 c      time12=1.0d0
4896       etheta=0.0D0
4897 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4898       do i=ithet_start,ithet_end
4899         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4900      &  .or.itype(i).eq.ntyp1) cycle
4901 C Zero the energy function and its derivative at 0 or pi.
4902         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4903         it=itype(i-1)
4904         ichir1=isign(1,itype(i-2))
4905         ichir2=isign(1,itype(i))
4906          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4907          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4908          if (itype(i-1).eq.10) then
4909           itype1=isign(10,itype(i-2))
4910           ichir11=isign(1,itype(i-2))
4911           ichir12=isign(1,itype(i-2))
4912           itype2=isign(10,itype(i))
4913           ichir21=isign(1,itype(i))
4914           ichir22=isign(1,itype(i))
4915          endif
4916
4917         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4918 #ifdef OSF
4919           phii=phi(i)
4920           if (phii.ne.phii) phii=150.0
4921 #else
4922           phii=phi(i)
4923 #endif
4924           y(1)=dcos(phii)
4925           y(2)=dsin(phii)
4926         else
4927           y(1)=0.0D0
4928           y(2)=0.0D0
4929         endif
4930         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4931 #ifdef OSF
4932           phii1=phi(i+1)
4933           if (phii1.ne.phii1) phii1=150.0
4934           phii1=pinorm(phii1)
4935           z(1)=cos(phii1)
4936 #else
4937           phii1=phi(i+1)
4938 #endif
4939           z(1)=dcos(phii1)
4940           z(2)=dsin(phii1)
4941         else
4942           z(1)=0.0D0
4943           z(2)=0.0D0
4944         endif
4945 C Calculate the "mean" value of theta from the part of the distribution
4946 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4947 C In following comments this theta will be referred to as t_c.
4948         thet_pred_mean=0.0d0
4949         do k=1,2
4950             athetk=athet(k,it,ichir1,ichir2)
4951             bthetk=bthet(k,it,ichir1,ichir2)
4952           if (it.eq.10) then
4953              athetk=athet(k,itype1,ichir11,ichir12)
4954              bthetk=bthet(k,itype2,ichir21,ichir22)
4955           endif
4956          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4957 c         write(iout,*) 'chuj tu', y(k),z(k)
4958         enddo
4959         dthett=thet_pred_mean*ssd
4960         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4961 C Derivatives of the "mean" values in gamma1 and gamma2.
4962         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4963      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4964          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4965      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4966          if (it.eq.10) then
4967       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4968      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4969         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4970      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4971          endif
4972         if (theta(i).gt.pi-delta) then
4973           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4974      &         E_tc0)
4975           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4976           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4977           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4978      &        E_theta)
4979           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4980      &        E_tc)
4981         else if (theta(i).lt.delta) then
4982           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4983           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4984           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4985      &        E_theta)
4986           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4987           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4988      &        E_tc)
4989         else
4990           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4991      &        E_theta,E_tc)
4992         endif
4993         etheta=etheta+ethetai
4994         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4995      &      'ebend',i,ethetai,theta(i),itype(i)
4996         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4997         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4998         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4999       enddo
5000 C Ufff.... We've done all this!!!
5001       return
5002       end
5003 C---------------------------------------------------------------------------
5004       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5005      &     E_tc)
5006       implicit real*8 (a-h,o-z)
5007       include 'DIMENSIONS'
5008       include 'COMMON.LOCAL'
5009       include 'COMMON.IOUNITS'
5010       common /calcthet/ term1,term2,termm,diffak,ratak,
5011      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5012      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5013 C Calculate the contributions to both Gaussian lobes.
5014 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5015 C The "polynomial part" of the "standard deviation" of this part of
5016 C the distributioni.
5017 ccc        write (iout,*) thetai,thet_pred_mean
5018         sig=polthet(3,it)
5019         do j=2,0,-1
5020           sig=sig*thet_pred_mean+polthet(j,it)
5021         enddo
5022 C Derivative of the "interior part" of the "standard deviation of the"
5023 C gamma-dependent Gaussian lobe in t_c.
5024         sigtc=3*polthet(3,it)
5025         do j=2,1,-1
5026           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5027         enddo
5028         sigtc=sig*sigtc
5029 C Set the parameters of both Gaussian lobes of the distribution.
5030 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5031         fac=sig*sig+sigc0(it)
5032         sigcsq=fac+fac
5033         sigc=1.0D0/sigcsq
5034 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5035         sigsqtc=-4.0D0*sigcsq*sigtc
5036 c       print *,i,sig,sigtc,sigsqtc
5037 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5038         sigtc=-sigtc/(fac*fac)
5039 C Following variable is sigma(t_c)**(-2)
5040         sigcsq=sigcsq*sigcsq
5041         sig0i=sig0(it)
5042         sig0inv=1.0D0/sig0i**2
5043         delthec=thetai-thet_pred_mean
5044         delthe0=thetai-theta0i
5045         term1=-0.5D0*sigcsq*delthec*delthec
5046         term2=-0.5D0*sig0inv*delthe0*delthe0
5047 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5048 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5049 C NaNs in taking the logarithm. We extract the largest exponent which is added
5050 C to the energy (this being the log of the distribution) at the end of energy
5051 C term evaluation for this virtual-bond angle.
5052         if (term1.gt.term2) then
5053           termm=term1
5054           term2=dexp(term2-termm)
5055           term1=1.0d0
5056         else
5057           termm=term2
5058           term1=dexp(term1-termm)
5059           term2=1.0d0
5060         endif
5061 C The ratio between the gamma-independent and gamma-dependent lobes of
5062 C the distribution is a Gaussian function of thet_pred_mean too.
5063         diffak=gthet(2,it)-thet_pred_mean
5064         ratak=diffak/gthet(3,it)**2
5065         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5066 C Let's differentiate it in thet_pred_mean NOW.
5067         aktc=ak*ratak
5068 C Now put together the distribution terms to make complete distribution.
5069         termexp=term1+ak*term2
5070         termpre=sigc+ak*sig0i
5071 C Contribution of the bending energy from this theta is just the -log of
5072 C the sum of the contributions from the two lobes and the pre-exponential
5073 C factor. Simple enough, isn't it?
5074         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5075 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5076 C NOW the derivatives!!!
5077 C 6/6/97 Take into account the deformation.
5078         E_theta=(delthec*sigcsq*term1
5079      &       +ak*delthe0*sig0inv*term2)/termexp
5080         E_tc=((sigtc+aktc*sig0i)/termpre
5081      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5082      &       aktc*term2)/termexp)
5083       return
5084       end
5085 c-----------------------------------------------------------------------------
5086       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5087       implicit real*8 (a-h,o-z)
5088       include 'DIMENSIONS'
5089       include 'COMMON.LOCAL'
5090       include 'COMMON.IOUNITS'
5091       common /calcthet/ term1,term2,termm,diffak,ratak,
5092      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5093      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5094       delthec=thetai-thet_pred_mean
5095       delthe0=thetai-theta0i
5096 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5097       t3 = thetai-thet_pred_mean
5098       t6 = t3**2
5099       t9 = term1
5100       t12 = t3*sigcsq
5101       t14 = t12+t6*sigsqtc
5102       t16 = 1.0d0
5103       t21 = thetai-theta0i
5104       t23 = t21**2
5105       t26 = term2
5106       t27 = t21*t26
5107       t32 = termexp
5108       t40 = t32**2
5109       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5110      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5111      & *(-t12*t9-ak*sig0inv*t27)
5112       return
5113       end
5114 #else
5115 C--------------------------------------------------------------------------
5116       subroutine ebend(etheta)
5117 C
5118 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5119 C angles gamma and its derivatives in consecutive thetas and gammas.
5120 C ab initio-derived potentials from
5121 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5122 C
5123       implicit real*8 (a-h,o-z)
5124       include 'DIMENSIONS'
5125       include 'COMMON.LOCAL'
5126       include 'COMMON.GEO'
5127       include 'COMMON.INTERACT'
5128       include 'COMMON.DERIV'
5129       include 'COMMON.VAR'
5130       include 'COMMON.CHAIN'
5131       include 'COMMON.IOUNITS'
5132       include 'COMMON.NAMES'
5133       include 'COMMON.FFIELD'
5134       include 'COMMON.CONTROL'
5135       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5136      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5137      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5138      & sinph1ph2(maxdouble,maxdouble)
5139       logical lprn /.false./, lprn1 /.false./
5140       etheta=0.0D0
5141       do i=ithet_start,ithet_end
5142 c        print *,i,itype(i-1),itype(i),itype(i-2)
5143         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5144      &  .or.itype(i).eq.ntyp1) cycle
5145 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5146
5147         if (iabs(itype(i+1)).eq.20) iblock=2
5148         if (iabs(itype(i+1)).ne.20) iblock=1
5149         dethetai=0.0d0
5150         dephii=0.0d0
5151         dephii1=0.0d0
5152         theti2=0.5d0*theta(i)
5153         ityp2=ithetyp((itype(i-1)))
5154         do k=1,nntheterm
5155           coskt(k)=dcos(k*theti2)
5156           sinkt(k)=dsin(k*theti2)
5157         enddo
5158         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5159 #ifdef OSF
5160           phii=phi(i)
5161           if (phii.ne.phii) phii=150.0
5162 #else
5163           phii=phi(i)
5164 #endif
5165           ityp1=ithetyp((itype(i-2)))
5166 C propagation of chirality for glycine type
5167           do k=1,nsingle
5168             cosph1(k)=dcos(k*phii)
5169             sinph1(k)=dsin(k*phii)
5170           enddo
5171         else
5172           phii=0.0d0
5173           ityp1=nthetyp+1
5174           do k=1,nsingle
5175             cosph1(k)=0.0d0
5176             sinph1(k)=0.0d0
5177           enddo
5178         endif
5179         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5180 #ifdef OSF
5181           phii1=phi(i+1)
5182           if (phii1.ne.phii1) phii1=150.0
5183           phii1=pinorm(phii1)
5184 #else
5185           phii1=phi(i+1)
5186 #endif
5187           ityp3=ithetyp((itype(i)))
5188           do k=1,nsingle
5189             cosph2(k)=dcos(k*phii1)
5190             sinph2(k)=dsin(k*phii1)
5191           enddo
5192         else
5193           phii1=0.0d0
5194           ityp3=nthetyp+1
5195           do k=1,nsingle
5196             cosph2(k)=0.0d0
5197             sinph2(k)=0.0d0
5198           enddo
5199         endif
5200         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5201         do k=1,ndouble
5202           do l=1,k-1
5203             ccl=cosph1(l)*cosph2(k-l)
5204             ssl=sinph1(l)*sinph2(k-l)
5205             scl=sinph1(l)*cosph2(k-l)
5206             csl=cosph1(l)*sinph2(k-l)
5207             cosph1ph2(l,k)=ccl-ssl
5208             cosph1ph2(k,l)=ccl+ssl
5209             sinph1ph2(l,k)=scl+csl
5210             sinph1ph2(k,l)=scl-csl
5211           enddo
5212         enddo
5213         if (lprn) then
5214         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5215      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5216         write (iout,*) "coskt and sinkt"
5217         do k=1,nntheterm
5218           write (iout,*) k,coskt(k),sinkt(k)
5219         enddo
5220         endif
5221         do k=1,ntheterm
5222           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5223           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5224      &      *coskt(k)
5225           if (lprn)
5226      &    write (iout,*) "k",k,"
5227      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5228      &     " ethetai",ethetai
5229         enddo
5230         if (lprn) then
5231         write (iout,*) "cosph and sinph"
5232         do k=1,nsingle
5233           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5234         enddo
5235         write (iout,*) "cosph1ph2 and sinph2ph2"
5236         do k=2,ndouble
5237           do l=1,k-1
5238             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5239      &         sinph1ph2(l,k),sinph1ph2(k,l)
5240           enddo
5241         enddo
5242         write(iout,*) "ethetai",ethetai
5243         endif
5244         do m=1,ntheterm2
5245           do k=1,nsingle
5246             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5247      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5248      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5249      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5250             ethetai=ethetai+sinkt(m)*aux
5251             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5252             dephii=dephii+k*sinkt(m)*(
5253      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5254      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5255             dephii1=dephii1+k*sinkt(m)*(
5256      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5257      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5258             if (lprn)
5259      &      write (iout,*) "m",m," k",k," bbthet",
5260      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5261      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5262      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5263      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5264           enddo
5265         enddo
5266         if (lprn)
5267      &  write(iout,*) "ethetai",ethetai
5268         do m=1,ntheterm3
5269           do k=2,ndouble
5270             do l=1,k-1
5271               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5272      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5273      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5274      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5275               ethetai=ethetai+sinkt(m)*aux
5276               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5277               dephii=dephii+l*sinkt(m)*(
5278      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5279      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5280      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5281      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5282               dephii1=dephii1+(k-l)*sinkt(m)*(
5283      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5284      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5285      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5286      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5287               if (lprn) then
5288               write (iout,*) "m",m," k",k," l",l," ffthet",
5289      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5290      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5291      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5292      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5293      &            " ethetai",ethetai
5294               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5295      &            cosph1ph2(k,l)*sinkt(m),
5296      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5297               endif
5298             enddo
5299           enddo
5300         enddo
5301 10      continue
5302 c        lprn1=.true.
5303         if (lprn1)
5304      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5305      &   i,theta(i)*rad2deg,phii*rad2deg,
5306      &   phii1*rad2deg,ethetai
5307 c        lprn1=.false.
5308         etheta=etheta+ethetai
5309         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5310         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5311         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5312       enddo
5313       return
5314       end
5315 #endif
5316 #ifdef CRYST_SC
5317 c-----------------------------------------------------------------------------
5318       subroutine esc(escloc)
5319 C Calculate the local energy of a side chain and its derivatives in the
5320 C corresponding virtual-bond valence angles THETA and the spherical angles
5321 C ALPHA and OMEGA.
5322       implicit real*8 (a-h,o-z)
5323       include 'DIMENSIONS'
5324       include 'COMMON.GEO'
5325       include 'COMMON.LOCAL'
5326       include 'COMMON.VAR'
5327       include 'COMMON.INTERACT'
5328       include 'COMMON.DERIV'
5329       include 'COMMON.CHAIN'
5330       include 'COMMON.IOUNITS'
5331       include 'COMMON.NAMES'
5332       include 'COMMON.FFIELD'
5333       include 'COMMON.CONTROL'
5334       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5335      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5336       common /sccalc/ time11,time12,time112,theti,it,nlobit
5337       delta=0.02d0*pi
5338       escloc=0.0D0
5339 c     write (iout,'(a)') 'ESC'
5340       do i=loc_start,loc_end
5341         it=itype(i)
5342         if (it.eq.ntyp1) cycle
5343         if (it.eq.10) goto 1
5344         nlobit=nlob(iabs(it))
5345 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5346 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5347         theti=theta(i+1)-pipol
5348         x(1)=dtan(theti)
5349         x(2)=alph(i)
5350         x(3)=omeg(i)
5351
5352         if (x(2).gt.pi-delta) then
5353           xtemp(1)=x(1)
5354           xtemp(2)=pi-delta
5355           xtemp(3)=x(3)
5356           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5357           xtemp(2)=pi
5358           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5359           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5360      &        escloci,dersc(2))
5361           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5362      &        ddersc0(1),dersc(1))
5363           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5364      &        ddersc0(3),dersc(3))
5365           xtemp(2)=pi-delta
5366           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5367           xtemp(2)=pi
5368           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5369           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5370      &            dersc0(2),esclocbi,dersc02)
5371           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5372      &            dersc12,dersc01)
5373           call splinthet(x(2),0.5d0*delta,ss,ssd)
5374           dersc0(1)=dersc01
5375           dersc0(2)=dersc02
5376           dersc0(3)=0.0d0
5377           do k=1,3
5378             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5379           enddo
5380           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5381 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5382 c    &             esclocbi,ss,ssd
5383           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5384 c         escloci=esclocbi
5385 c         write (iout,*) escloci
5386         else if (x(2).lt.delta) then
5387           xtemp(1)=x(1)
5388           xtemp(2)=delta
5389           xtemp(3)=x(3)
5390           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5391           xtemp(2)=0.0d0
5392           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5393           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5394      &        escloci,dersc(2))
5395           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5396      &        ddersc0(1),dersc(1))
5397           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5398      &        ddersc0(3),dersc(3))
5399           xtemp(2)=delta
5400           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5401           xtemp(2)=0.0d0
5402           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5403           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5404      &            dersc0(2),esclocbi,dersc02)
5405           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5406      &            dersc12,dersc01)
5407           dersc0(1)=dersc01
5408           dersc0(2)=dersc02
5409           dersc0(3)=0.0d0
5410           call splinthet(x(2),0.5d0*delta,ss,ssd)
5411           do k=1,3
5412             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5413           enddo
5414           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5415 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5416 c    &             esclocbi,ss,ssd
5417           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5418 c         write (iout,*) escloci
5419         else
5420           call enesc(x,escloci,dersc,ddummy,.false.)
5421         endif
5422
5423         escloc=escloc+escloci
5424         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5425      &     'escloc',i,escloci
5426 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5427
5428         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5429      &   wscloc*dersc(1)
5430         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5431         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5432     1   continue
5433       enddo
5434       return
5435       end
5436 C---------------------------------------------------------------------------
5437       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5438       implicit real*8 (a-h,o-z)
5439       include 'DIMENSIONS'
5440       include 'COMMON.GEO'
5441       include 'COMMON.LOCAL'
5442       include 'COMMON.IOUNITS'
5443       common /sccalc/ time11,time12,time112,theti,it,nlobit
5444       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5445       double precision contr(maxlob,-1:1)
5446       logical mixed
5447 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5448         escloc_i=0.0D0
5449         do j=1,3
5450           dersc(j)=0.0D0
5451           if (mixed) ddersc(j)=0.0d0
5452         enddo
5453         x3=x(3)
5454
5455 C Because of periodicity of the dependence of the SC energy in omega we have
5456 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5457 C To avoid underflows, first compute & store the exponents.
5458
5459         do iii=-1,1
5460
5461           x(3)=x3+iii*dwapi
5462
5463           do j=1,nlobit
5464             do k=1,3
5465               z(k)=x(k)-censc(k,j,it)
5466             enddo
5467             do k=1,3
5468               Axk=0.0D0
5469               do l=1,3
5470                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5471               enddo
5472               Ax(k,j,iii)=Axk
5473             enddo
5474             expfac=0.0D0
5475             do k=1,3
5476               expfac=expfac+Ax(k,j,iii)*z(k)
5477             enddo
5478             contr(j,iii)=expfac
5479           enddo ! j
5480
5481         enddo ! iii
5482
5483         x(3)=x3
5484 C As in the case of ebend, we want to avoid underflows in exponentiation and
5485 C subsequent NaNs and INFs in energy calculation.
5486 C Find the largest exponent
5487         emin=contr(1,-1)
5488         do iii=-1,1
5489           do j=1,nlobit
5490             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5491           enddo
5492         enddo
5493         emin=0.5D0*emin
5494 cd      print *,'it=',it,' emin=',emin
5495
5496 C Compute the contribution to SC energy and derivatives
5497         do iii=-1,1
5498
5499           do j=1,nlobit
5500 #ifdef OSF
5501             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5502             if(adexp.ne.adexp) adexp=1.0
5503             expfac=dexp(adexp)
5504 #else
5505             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5506 #endif
5507 cd          print *,'j=',j,' expfac=',expfac
5508             escloc_i=escloc_i+expfac
5509             do k=1,3
5510               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5511             enddo
5512             if (mixed) then
5513               do k=1,3,2
5514                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5515      &            +gaussc(k,2,j,it))*expfac
5516               enddo
5517             endif
5518           enddo
5519
5520         enddo ! iii
5521
5522         dersc(1)=dersc(1)/cos(theti)**2
5523         ddersc(1)=ddersc(1)/cos(theti)**2
5524         ddersc(3)=ddersc(3)
5525
5526         escloci=-(dlog(escloc_i)-emin)
5527         do j=1,3
5528           dersc(j)=dersc(j)/escloc_i
5529         enddo
5530         if (mixed) then
5531           do j=1,3,2
5532             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5533           enddo
5534         endif
5535       return
5536       end
5537 C------------------------------------------------------------------------------
5538       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5539       implicit real*8 (a-h,o-z)
5540       include 'DIMENSIONS'
5541       include 'COMMON.GEO'
5542       include 'COMMON.LOCAL'
5543       include 'COMMON.IOUNITS'
5544       common /sccalc/ time11,time12,time112,theti,it,nlobit
5545       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5546       double precision contr(maxlob)
5547       logical mixed
5548
5549       escloc_i=0.0D0
5550
5551       do j=1,3
5552         dersc(j)=0.0D0
5553       enddo
5554
5555       do j=1,nlobit
5556         do k=1,2
5557           z(k)=x(k)-censc(k,j,it)
5558         enddo
5559         z(3)=dwapi
5560         do k=1,3
5561           Axk=0.0D0
5562           do l=1,3
5563             Axk=Axk+gaussc(l,k,j,it)*z(l)
5564           enddo
5565           Ax(k,j)=Axk
5566         enddo
5567         expfac=0.0D0
5568         do k=1,3
5569           expfac=expfac+Ax(k,j)*z(k)
5570         enddo
5571         contr(j)=expfac
5572       enddo ! j
5573
5574 C As in the case of ebend, we want to avoid underflows in exponentiation and
5575 C subsequent NaNs and INFs in energy calculation.
5576 C Find the largest exponent
5577       emin=contr(1)
5578       do j=1,nlobit
5579         if (emin.gt.contr(j)) emin=contr(j)
5580       enddo
5581       emin=0.5D0*emin
5582
5583 C Compute the contribution to SC energy and derivatives
5584
5585       dersc12=0.0d0
5586       do j=1,nlobit
5587         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5588         escloc_i=escloc_i+expfac
5589         do k=1,2
5590           dersc(k)=dersc(k)+Ax(k,j)*expfac
5591         enddo
5592         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5593      &            +gaussc(1,2,j,it))*expfac
5594         dersc(3)=0.0d0
5595       enddo
5596
5597       dersc(1)=dersc(1)/cos(theti)**2
5598       dersc12=dersc12/cos(theti)**2
5599       escloci=-(dlog(escloc_i)-emin)
5600       do j=1,2
5601         dersc(j)=dersc(j)/escloc_i
5602       enddo
5603       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5604       return
5605       end
5606 #else
5607 c----------------------------------------------------------------------------------
5608       subroutine esc(escloc)
5609 C Calculate the local energy of a side chain and its derivatives in the
5610 C corresponding virtual-bond valence angles THETA and the spherical angles
5611 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5612 C added by Urszula Kozlowska. 07/11/2007
5613 C
5614       implicit real*8 (a-h,o-z)
5615       include 'DIMENSIONS'
5616       include 'COMMON.GEO'
5617       include 'COMMON.LOCAL'
5618       include 'COMMON.VAR'
5619       include 'COMMON.SCROT'
5620       include 'COMMON.INTERACT'
5621       include 'COMMON.DERIV'
5622       include 'COMMON.CHAIN'
5623       include 'COMMON.IOUNITS'
5624       include 'COMMON.NAMES'
5625       include 'COMMON.FFIELD'
5626       include 'COMMON.CONTROL'
5627       include 'COMMON.VECTORS'
5628       double precision x_prime(3),y_prime(3),z_prime(3)
5629      &    , sumene,dsc_i,dp2_i,x(65),
5630      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5631      &    de_dxx,de_dyy,de_dzz,de_dt
5632       double precision s1_t,s1_6_t,s2_t,s2_6_t
5633       double precision
5634      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5635      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5636      & dt_dCi(3),dt_dCi1(3)
5637       common /sccalc/ time11,time12,time112,theti,it,nlobit
5638       delta=0.02d0*pi
5639       escloc=0.0D0
5640       do i=loc_start,loc_end
5641         if (itype(i).eq.ntyp1) cycle
5642         costtab(i+1) =dcos(theta(i+1))
5643         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5644         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5645         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5646         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5647         cosfac=dsqrt(cosfac2)
5648         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5649         sinfac=dsqrt(sinfac2)
5650         it=iabs(itype(i))
5651         if (it.eq.10) goto 1
5652 c
5653 C  Compute the axes of tghe local cartesian coordinates system; store in
5654 c   x_prime, y_prime and z_prime
5655 c
5656         do j=1,3
5657           x_prime(j) = 0.00
5658           y_prime(j) = 0.00
5659           z_prime(j) = 0.00
5660         enddo
5661 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5662 C     &   dc_norm(3,i+nres)
5663         do j = 1,3
5664           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5665           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5666         enddo
5667         do j = 1,3
5668           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5669         enddo
5670 c       write (2,*) "i",i
5671 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5672 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5673 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5674 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5675 c      & " xy",scalar(x_prime(1),y_prime(1)),
5676 c      & " xz",scalar(x_prime(1),z_prime(1)),
5677 c      & " yy",scalar(y_prime(1),y_prime(1)),
5678 c      & " yz",scalar(y_prime(1),z_prime(1)),
5679 c      & " zz",scalar(z_prime(1),z_prime(1))
5680 c
5681 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5682 C to local coordinate system. Store in xx, yy, zz.
5683 c
5684         xx=0.0d0
5685         yy=0.0d0
5686         zz=0.0d0
5687         do j = 1,3
5688           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5689           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5690           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5691         enddo
5692
5693         xxtab(i)=xx
5694         yytab(i)=yy
5695         zztab(i)=zz
5696 C
5697 C Compute the energy of the ith side cbain
5698 C
5699 c        write (2,*) "xx",xx," yy",yy," zz",zz
5700         it=iabs(itype(i))
5701         do j = 1,65
5702           x(j) = sc_parmin(j,it)
5703         enddo
5704 #ifdef CHECK_COORD
5705 Cc diagnostics - remove later
5706         xx1 = dcos(alph(2))
5707         yy1 = dsin(alph(2))*dcos(omeg(2))
5708         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5709         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5710      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5711      &    xx1,yy1,zz1
5712 C,"  --- ", xx_w,yy_w,zz_w
5713 c end diagnostics
5714 #endif
5715         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5716      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5717      &   + x(10)*yy*zz
5718         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5719      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5720      & + x(20)*yy*zz
5721         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5722      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5723      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5724      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5725      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5726      &  +x(40)*xx*yy*zz
5727         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5728      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5729      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5730      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5731      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5732      &  +x(60)*xx*yy*zz
5733         dsc_i   = 0.743d0+x(61)
5734         dp2_i   = 1.9d0+x(62)
5735         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5736      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5737         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5738      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5739         s1=(1+x(63))/(0.1d0 + dscp1)
5740         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5741         s2=(1+x(65))/(0.1d0 + dscp2)
5742         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5743         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5744      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5745 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5746 c     &   sumene4,
5747 c     &   dscp1,dscp2,sumene
5748 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5749         escloc = escloc + sumene
5750 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5751 c     & ,zz,xx,yy
5752 c#define DEBUG
5753 #ifdef DEBUG
5754 C
5755 C This section to check the numerical derivatives of the energy of ith side
5756 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5757 C #define DEBUG in the code to turn it on.
5758 C
5759         write (2,*) "sumene               =",sumene
5760         aincr=1.0d-7
5761         xxsave=xx
5762         xx=xx+aincr
5763         write (2,*) xx,yy,zz
5764         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5765         de_dxx_num=(sumenep-sumene)/aincr
5766         xx=xxsave
5767         write (2,*) "xx+ sumene from enesc=",sumenep
5768         yysave=yy
5769         yy=yy+aincr
5770         write (2,*) xx,yy,zz
5771         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5772         de_dyy_num=(sumenep-sumene)/aincr
5773         yy=yysave
5774         write (2,*) "yy+ sumene from enesc=",sumenep
5775         zzsave=zz
5776         zz=zz+aincr
5777         write (2,*) xx,yy,zz
5778         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5779         de_dzz_num=(sumenep-sumene)/aincr
5780         zz=zzsave
5781         write (2,*) "zz+ sumene from enesc=",sumenep
5782         costsave=cost2tab(i+1)
5783         sintsave=sint2tab(i+1)
5784         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5785         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5786         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5787         de_dt_num=(sumenep-sumene)/aincr
5788         write (2,*) " t+ sumene from enesc=",sumenep
5789         cost2tab(i+1)=costsave
5790         sint2tab(i+1)=sintsave
5791 C End of diagnostics section.
5792 #endif
5793 C
5794 C Compute the gradient of esc
5795 C
5796 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5797         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5798         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5799         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5800         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5801         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5802         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5803         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5804         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5805         pom1=(sumene3*sint2tab(i+1)+sumene1)
5806      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5807         pom2=(sumene4*cost2tab(i+1)+sumene2)
5808      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5809         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5810         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5811      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5812      &  +x(40)*yy*zz
5813         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5814         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5815      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5816      &  +x(60)*yy*zz
5817         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5818      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5819      &        +(pom1+pom2)*pom_dx
5820 #ifdef DEBUG
5821         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5822 #endif
5823 C
5824         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5825         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5826      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5827      &  +x(40)*xx*zz
5828         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5829         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5830      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5831      &  +x(59)*zz**2 +x(60)*xx*zz
5832         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5833      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5834      &        +(pom1-pom2)*pom_dy
5835 #ifdef DEBUG
5836         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5837 #endif
5838 C
5839         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5840      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5841      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5842      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5843      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5844      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5845      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5846      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5847 #ifdef DEBUG
5848         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5849 #endif
5850 C
5851         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5852      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5853      &  +pom1*pom_dt1+pom2*pom_dt2
5854 #ifdef DEBUG
5855         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5856 #endif
5857 c#undef DEBUG
5858 c
5859 C
5860        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5861        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5862        cosfac2xx=cosfac2*xx
5863        sinfac2yy=sinfac2*yy
5864        do k = 1,3
5865          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5866      &      vbld_inv(i+1)
5867          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5868      &      vbld_inv(i)
5869          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5870          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5871 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5872 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5873 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5874 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5875          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5876          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5877          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5878          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5879          dZZ_Ci1(k)=0.0d0
5880          dZZ_Ci(k)=0.0d0
5881          do j=1,3
5882            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5883      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5884            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5885      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5886          enddo
5887
5888          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5889          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5890          dZZ_XYZ(k)=vbld_inv(i+nres)*
5891      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5892 c
5893          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5894          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5895        enddo
5896
5897        do k=1,3
5898          dXX_Ctab(k,i)=dXX_Ci(k)
5899          dXX_C1tab(k,i)=dXX_Ci1(k)
5900          dYY_Ctab(k,i)=dYY_Ci(k)
5901          dYY_C1tab(k,i)=dYY_Ci1(k)
5902          dZZ_Ctab(k,i)=dZZ_Ci(k)
5903          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5904          dXX_XYZtab(k,i)=dXX_XYZ(k)
5905          dYY_XYZtab(k,i)=dYY_XYZ(k)
5906          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5907        enddo
5908
5909        do k = 1,3
5910 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5911 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5912 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5913 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5914 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5915 c     &    dt_dci(k)
5916 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5917 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5918          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5919      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5920          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5921      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5922          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5923      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5924        enddo
5925 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5926 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5927
5928 C to check gradient call subroutine check_grad
5929
5930     1 continue
5931       enddo
5932       return
5933       end
5934 c------------------------------------------------------------------------------
5935       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5936       implicit none
5937       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5938      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5939       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5940      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5941      &   + x(10)*yy*zz
5942       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5943      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5944      & + x(20)*yy*zz
5945       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5946      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5947      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5948      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5949      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5950      &  +x(40)*xx*yy*zz
5951       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5952      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5953      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5954      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5955      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5956      &  +x(60)*xx*yy*zz
5957       dsc_i   = 0.743d0+x(61)
5958       dp2_i   = 1.9d0+x(62)
5959       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5960      &          *(xx*cost2+yy*sint2))
5961       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5962      &          *(xx*cost2-yy*sint2))
5963       s1=(1+x(63))/(0.1d0 + dscp1)
5964       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5965       s2=(1+x(65))/(0.1d0 + dscp2)
5966       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5967       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5968      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5969       enesc=sumene
5970       return
5971       end
5972 #endif
5973 c------------------------------------------------------------------------------
5974       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5975 C
5976 C This procedure calculates two-body contact function g(rij) and its derivative:
5977 C
5978 C           eps0ij                                     !       x < -1
5979 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5980 C            0                                         !       x > 1
5981 C
5982 C where x=(rij-r0ij)/delta
5983 C
5984 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5985 C
5986       implicit none
5987       double precision rij,r0ij,eps0ij,fcont,fprimcont
5988       double precision x,x2,x4,delta
5989 c     delta=0.02D0*r0ij
5990 c      delta=0.2D0*r0ij
5991       x=(rij-r0ij)/delta
5992       if (x.lt.-1.0D0) then
5993         fcont=eps0ij
5994         fprimcont=0.0D0
5995       else if (x.le.1.0D0) then
5996         x2=x*x
5997         x4=x2*x2
5998         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5999         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6000       else
6001         fcont=0.0D0
6002         fprimcont=0.0D0
6003       endif
6004       return
6005       end
6006 c------------------------------------------------------------------------------
6007       subroutine splinthet(theti,delta,ss,ssder)
6008       implicit real*8 (a-h,o-z)
6009       include 'DIMENSIONS'
6010       include 'COMMON.VAR'
6011       include 'COMMON.GEO'
6012       thetup=pi-delta
6013       thetlow=delta
6014       if (theti.gt.pipol) then
6015         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6016       else
6017         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6018         ssder=-ssder
6019       endif
6020       return
6021       end
6022 c------------------------------------------------------------------------------
6023       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6024       implicit none
6025       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6026       double precision ksi,ksi2,ksi3,a1,a2,a3
6027       a1=fprim0*delta/(f1-f0)
6028       a2=3.0d0-2.0d0*a1
6029       a3=a1-2.0d0
6030       ksi=(x-x0)/delta
6031       ksi2=ksi*ksi
6032       ksi3=ksi2*ksi
6033       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6034       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6035       return
6036       end
6037 c------------------------------------------------------------------------------
6038       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6039       implicit none
6040       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6041       double precision ksi,ksi2,ksi3,a1,a2,a3
6042       ksi=(x-x0)/delta
6043       ksi2=ksi*ksi
6044       ksi3=ksi2*ksi
6045       a1=fprim0x*delta
6046       a2=3*(f1x-f0x)-2*fprim0x*delta
6047       a3=fprim0x*delta-2*(f1x-f0x)
6048       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6049       return
6050       end
6051 C-----------------------------------------------------------------------------
6052 #ifdef CRYST_TOR
6053 C-----------------------------------------------------------------------------
6054       subroutine etor(etors,edihcnstr)
6055       implicit real*8 (a-h,o-z)
6056       include 'DIMENSIONS'
6057       include 'COMMON.VAR'
6058       include 'COMMON.GEO'
6059       include 'COMMON.LOCAL'
6060       include 'COMMON.TORSION'
6061       include 'COMMON.INTERACT'
6062       include 'COMMON.DERIV'
6063       include 'COMMON.CHAIN'
6064       include 'COMMON.NAMES'
6065       include 'COMMON.IOUNITS'
6066       include 'COMMON.FFIELD'
6067       include 'COMMON.TORCNSTR'
6068       include 'COMMON.CONTROL'
6069       logical lprn
6070 C Set lprn=.true. for debugging
6071       lprn=.false.
6072 c      lprn=.true.
6073       etors=0.0D0
6074       do i=iphi_start,iphi_end
6075       etors_ii=0.0D0
6076         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6077      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6078         itori=itortyp(itype(i-2))
6079         itori1=itortyp(itype(i-1))
6080         phii=phi(i)
6081         gloci=0.0D0
6082 C Proline-Proline pair is a special case...
6083         if (itori.eq.3 .and. itori1.eq.3) then
6084           if (phii.gt.-dwapi3) then
6085             cosphi=dcos(3*phii)
6086             fac=1.0D0/(1.0D0-cosphi)
6087             etorsi=v1(1,3,3)*fac
6088             etorsi=etorsi+etorsi
6089             etors=etors+etorsi-v1(1,3,3)
6090             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6091             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6092           endif
6093           do j=1,3
6094             v1ij=v1(j+1,itori,itori1)
6095             v2ij=v2(j+1,itori,itori1)
6096             cosphi=dcos(j*phii)
6097             sinphi=dsin(j*phii)
6098             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6099             if (energy_dec) etors_ii=etors_ii+
6100      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6101             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6102           enddo
6103         else
6104           do j=1,nterm_old
6105             v1ij=v1(j,itori,itori1)
6106             v2ij=v2(j,itori,itori1)
6107             cosphi=dcos(j*phii)
6108             sinphi=dsin(j*phii)
6109             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6110             if (energy_dec) etors_ii=etors_ii+
6111      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6112             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6113           enddo
6114         endif
6115         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6116              'etor',i,etors_ii
6117         if (lprn)
6118      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6119      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6120      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6121         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6122 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6123       enddo
6124 ! 6/20/98 - dihedral angle constraints
6125       edihcnstr=0.0d0
6126       do i=1,ndih_constr
6127         itori=idih_constr(i)
6128         phii=phi(itori)
6129         difi=phii-phi0(i)
6130         if (difi.gt.drange(i)) then
6131           difi=difi-drange(i)
6132           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6133           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6134         else if (difi.lt.-drange(i)) then
6135           difi=difi+drange(i)
6136           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6137           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6138         endif
6139 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6140 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6141       enddo
6142 !      write (iout,*) 'edihcnstr',edihcnstr
6143       return
6144       end
6145 c------------------------------------------------------------------------------
6146       subroutine etor_d(etors_d)
6147       etors_d=0.0d0
6148       return
6149       end
6150 c----------------------------------------------------------------------------
6151 #else
6152       subroutine etor(etors,edihcnstr)
6153       implicit real*8 (a-h,o-z)
6154       include 'DIMENSIONS'
6155       include 'COMMON.VAR'
6156       include 'COMMON.GEO'
6157       include 'COMMON.LOCAL'
6158       include 'COMMON.TORSION'
6159       include 'COMMON.INTERACT'
6160       include 'COMMON.DERIV'
6161       include 'COMMON.CHAIN'
6162       include 'COMMON.NAMES'
6163       include 'COMMON.IOUNITS'
6164       include 'COMMON.FFIELD'
6165       include 'COMMON.TORCNSTR'
6166       include 'COMMON.CONTROL'
6167       logical lprn
6168 C Set lprn=.true. for debugging
6169       lprn=.false.
6170 c     lprn=.true.
6171       etors=0.0D0
6172       do i=iphi_start,iphi_end
6173 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6174 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6175 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6176 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6177         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6178      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6179 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6180 C For introducing the NH3+ and COO- group please check the etor_d for reference
6181 C and guidance
6182         etors_ii=0.0D0
6183          if (iabs(itype(i)).eq.20) then
6184          iblock=2
6185          else
6186          iblock=1
6187          endif
6188         itori=itortyp(itype(i-2))
6189         itori1=itortyp(itype(i-1))
6190         phii=phi(i)
6191         gloci=0.0D0
6192 C Regular cosine and sine terms
6193         do j=1,nterm(itori,itori1,iblock)
6194           v1ij=v1(j,itori,itori1,iblock)
6195           v2ij=v2(j,itori,itori1,iblock)
6196           cosphi=dcos(j*phii)
6197           sinphi=dsin(j*phii)
6198           etors=etors+v1ij*cosphi+v2ij*sinphi
6199           if (energy_dec) etors_ii=etors_ii+
6200      &                v1ij*cosphi+v2ij*sinphi
6201           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6202         enddo
6203 C Lorentz terms
6204 C                         v1
6205 C  E = SUM ----------------------------------- - v1
6206 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6207 C
6208         cosphi=dcos(0.5d0*phii)
6209         sinphi=dsin(0.5d0*phii)
6210         do j=1,nlor(itori,itori1,iblock)
6211           vl1ij=vlor1(j,itori,itori1)
6212           vl2ij=vlor2(j,itori,itori1)
6213           vl3ij=vlor3(j,itori,itori1)
6214           pom=vl2ij*cosphi+vl3ij*sinphi
6215           pom1=1.0d0/(pom*pom+1.0d0)
6216           etors=etors+vl1ij*pom1
6217           if (energy_dec) etors_ii=etors_ii+
6218      &                vl1ij*pom1
6219           pom=-pom*pom1*pom1
6220           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6221         enddo
6222 C Subtract the constant term
6223         etors=etors-v0(itori,itori1,iblock)
6224           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6225      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6226         if (lprn)
6227      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6228      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6229      &  (v1(j,itori,itori1,iblock),j=1,6),
6230      &  (v2(j,itori,itori1,iblock),j=1,6)
6231         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6232 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6233       enddo
6234 ! 6/20/98 - dihedral angle constraints
6235       edihcnstr=0.0d0
6236 c      do i=1,ndih_constr
6237       do i=idihconstr_start,idihconstr_end
6238         itori=idih_constr(i)
6239         phii=phi(itori)
6240         difi=pinorm(phii-phi0(i))
6241         if (difi.gt.drange(i)) then
6242           difi=difi-drange(i)
6243           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6244           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6245         else if (difi.lt.-drange(i)) then
6246           difi=difi+drange(i)
6247           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6248           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6249         else
6250           difi=0.0
6251         endif
6252 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6253 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6254 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6255       enddo
6256 cd       write (iout,*) 'edihcnstr',edihcnstr
6257       return
6258       end
6259 c----------------------------------------------------------------------------
6260       subroutine etor_d(etors_d)
6261 C 6/23/01 Compute double torsional energy
6262       implicit real*8 (a-h,o-z)
6263       include 'DIMENSIONS'
6264       include 'COMMON.VAR'
6265       include 'COMMON.GEO'
6266       include 'COMMON.LOCAL'
6267       include 'COMMON.TORSION'
6268       include 'COMMON.INTERACT'
6269       include 'COMMON.DERIV'
6270       include 'COMMON.CHAIN'
6271       include 'COMMON.NAMES'
6272       include 'COMMON.IOUNITS'
6273       include 'COMMON.FFIELD'
6274       include 'COMMON.TORCNSTR'
6275       logical lprn
6276 C Set lprn=.true. for debugging
6277       lprn=.false.
6278 c     lprn=.true.
6279       etors_d=0.0D0
6280 c      write(iout,*) "a tu??"
6281       do i=iphid_start,iphid_end
6282 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6283 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6284 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6285 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6286 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6287          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6288      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6289      &  (itype(i+1).eq.ntyp1)) cycle
6290 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6291         itori=itortyp(itype(i-2))
6292         itori1=itortyp(itype(i-1))
6293         itori2=itortyp(itype(i))
6294         phii=phi(i)
6295         phii1=phi(i+1)
6296         gloci1=0.0D0
6297         gloci2=0.0D0
6298         iblock=1
6299         if (iabs(itype(i+1)).eq.20) iblock=2
6300 C Iblock=2 Proline type
6301 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6302 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6303 C        if (itype(i+1).eq.ntyp1) iblock=3
6304 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6305 C IS or IS NOT need for this
6306 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6307 C        is (itype(i-3).eq.ntyp1) ntblock=2
6308 C        ntblock is N-terminal blocking group
6309
6310 C Regular cosine and sine terms
6311         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6312 C Example of changes for NH3+ blocking group
6313 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6314 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6315           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6316           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6317           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6318           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6319           cosphi1=dcos(j*phii)
6320           sinphi1=dsin(j*phii)
6321           cosphi2=dcos(j*phii1)
6322           sinphi2=dsin(j*phii1)
6323           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6324      &     v2cij*cosphi2+v2sij*sinphi2
6325           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6326           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6327         enddo
6328         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6329           do l=1,k-1
6330             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6331             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6332             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6333             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6334             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6335             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6336             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6337             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6338             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6339      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6340             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6341      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6342             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6343      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6344           enddo
6345         enddo
6346         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6347         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6348       enddo
6349       return
6350       end
6351 #endif
6352 c------------------------------------------------------------------------------
6353       subroutine eback_sc_corr(esccor)
6354 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6355 c        conformational states; temporarily implemented as differences
6356 c        between UNRES torsional potentials (dependent on three types of
6357 c        residues) and the torsional potentials dependent on all 20 types
6358 c        of residues computed from AM1  energy surfaces of terminally-blocked
6359 c        amino-acid residues.
6360       implicit real*8 (a-h,o-z)
6361       include 'DIMENSIONS'
6362       include 'COMMON.VAR'
6363       include 'COMMON.GEO'
6364       include 'COMMON.LOCAL'
6365       include 'COMMON.TORSION'
6366       include 'COMMON.SCCOR'
6367       include 'COMMON.INTERACT'
6368       include 'COMMON.DERIV'
6369       include 'COMMON.CHAIN'
6370       include 'COMMON.NAMES'
6371       include 'COMMON.IOUNITS'
6372       include 'COMMON.FFIELD'
6373       include 'COMMON.CONTROL'
6374       logical lprn
6375 C Set lprn=.true. for debugging
6376       lprn=.false.
6377 c      lprn=.true.
6378 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6379       esccor=0.0D0
6380       do i=itau_start,itau_end
6381         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6382         esccor_ii=0.0D0
6383         isccori=isccortyp(itype(i-2))
6384         isccori1=isccortyp(itype(i-1))
6385 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6386         phii=phi(i)
6387         do intertyp=1,3 !intertyp
6388 cc Added 09 May 2012 (Adasko)
6389 cc  Intertyp means interaction type of backbone mainchain correlation:
6390 c   1 = SC...Ca...Ca...Ca
6391 c   2 = Ca...Ca...Ca...SC
6392 c   3 = SC...Ca...Ca...SCi
6393         gloci=0.0D0
6394         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6395      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6396      &      (itype(i-1).eq.ntyp1)))
6397      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6398      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6399      &     .or.(itype(i).eq.ntyp1)))
6400      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6401      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6402      &      (itype(i-3).eq.ntyp1)))) cycle
6403         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6404         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6405      & cycle
6406        do j=1,nterm_sccor(isccori,isccori1)
6407           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6408           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6409           cosphi=dcos(j*tauangle(intertyp,i))
6410           sinphi=dsin(j*tauangle(intertyp,i))
6411           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6412           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6413         enddo
6414 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6415         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6416         if (lprn)
6417      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6418      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6419      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6420      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6421         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6422        enddo !intertyp
6423       enddo
6424
6425       return
6426       end
6427 c----------------------------------------------------------------------------
6428       subroutine multibody(ecorr)
6429 C This subroutine calculates multi-body contributions to energy following
6430 C the idea of Skolnick et al. If side chains I and J make a contact and
6431 C at the same time side chains I+1 and J+1 make a contact, an extra
6432 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6433       implicit real*8 (a-h,o-z)
6434       include 'DIMENSIONS'
6435       include 'COMMON.IOUNITS'
6436       include 'COMMON.DERIV'
6437       include 'COMMON.INTERACT'
6438       include 'COMMON.CONTACTS'
6439       double precision gx(3),gx1(3)
6440       logical lprn
6441
6442 C Set lprn=.true. for debugging
6443       lprn=.false.
6444
6445       if (lprn) then
6446         write (iout,'(a)') 'Contact function values:'
6447         do i=nnt,nct-2
6448           write (iout,'(i2,20(1x,i2,f10.5))')
6449      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6450         enddo
6451       endif
6452       ecorr=0.0D0
6453       do i=nnt,nct
6454         do j=1,3
6455           gradcorr(j,i)=0.0D0
6456           gradxorr(j,i)=0.0D0
6457         enddo
6458       enddo
6459       do i=nnt,nct-2
6460
6461         DO ISHIFT = 3,4
6462
6463         i1=i+ishift
6464         num_conti=num_cont(i)
6465         num_conti1=num_cont(i1)
6466         do jj=1,num_conti
6467           j=jcont(jj,i)
6468           do kk=1,num_conti1
6469             j1=jcont(kk,i1)
6470             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6471 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6472 cd   &                   ' ishift=',ishift
6473 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6474 C The system gains extra energy.
6475               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6476             endif   ! j1==j+-ishift
6477           enddo     ! kk
6478         enddo       ! jj
6479
6480         ENDDO ! ISHIFT
6481
6482       enddo         ! i
6483       return
6484       end
6485 c------------------------------------------------------------------------------
6486       double precision function esccorr(i,j,k,l,jj,kk)
6487       implicit real*8 (a-h,o-z)
6488       include 'DIMENSIONS'
6489       include 'COMMON.IOUNITS'
6490       include 'COMMON.DERIV'
6491       include 'COMMON.INTERACT'
6492       include 'COMMON.CONTACTS'
6493       double precision gx(3),gx1(3)
6494       logical lprn
6495       lprn=.false.
6496       eij=facont(jj,i)
6497       ekl=facont(kk,k)
6498 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6499 C Calculate the multi-body contribution to energy.
6500 C Calculate multi-body contributions to the gradient.
6501 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6502 cd   & k,l,(gacont(m,kk,k),m=1,3)
6503       do m=1,3
6504         gx(m) =ekl*gacont(m,jj,i)
6505         gx1(m)=eij*gacont(m,kk,k)
6506         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6507         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6508         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6509         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6510       enddo
6511       do m=i,j-1
6512         do ll=1,3
6513           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6514         enddo
6515       enddo
6516       do m=k,l-1
6517         do ll=1,3
6518           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6519         enddo
6520       enddo
6521       esccorr=-eij*ekl
6522       return
6523       end
6524 c------------------------------------------------------------------------------
6525       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6526 C This subroutine calculates multi-body contributions to hydrogen-bonding
6527       implicit real*8 (a-h,o-z)
6528       include 'DIMENSIONS'
6529       include 'COMMON.IOUNITS'
6530 #ifdef MPI
6531       include "mpif.h"
6532       parameter (max_cont=maxconts)
6533       parameter (max_dim=26)
6534       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6535       double precision zapas(max_dim,maxconts,max_fg_procs),
6536      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6537       common /przechowalnia/ zapas
6538       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6539      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6540 #endif
6541       include 'COMMON.SETUP'
6542       include 'COMMON.FFIELD'
6543       include 'COMMON.DERIV'
6544       include 'COMMON.INTERACT'
6545       include 'COMMON.CONTACTS'
6546       include 'COMMON.CONTROL'
6547       include 'COMMON.LOCAL'
6548       double precision gx(3),gx1(3),time00
6549       logical lprn,ldone
6550
6551 C Set lprn=.true. for debugging
6552       lprn=.false.
6553 #ifdef MPI
6554       n_corr=0
6555       n_corr1=0
6556       if (nfgtasks.le.1) goto 30
6557       if (lprn) then
6558         write (iout,'(a)') 'Contact function values before RECEIVE:'
6559         do i=nnt,nct-2
6560           write (iout,'(2i3,50(1x,i2,f5.2))')
6561      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6562      &    j=1,num_cont_hb(i))
6563         enddo
6564       endif
6565       call flush(iout)
6566       do i=1,ntask_cont_from
6567         ncont_recv(i)=0
6568       enddo
6569       do i=1,ntask_cont_to
6570         ncont_sent(i)=0
6571       enddo
6572 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6573 c     & ntask_cont_to
6574 C Make the list of contacts to send to send to other procesors
6575 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6576 c      call flush(iout)
6577       do i=iturn3_start,iturn3_end
6578 c        write (iout,*) "make contact list turn3",i," num_cont",
6579 c     &    num_cont_hb(i)
6580         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6581       enddo
6582       do i=iturn4_start,iturn4_end
6583 c        write (iout,*) "make contact list turn4",i," num_cont",
6584 c     &   num_cont_hb(i)
6585         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6586       enddo
6587       do ii=1,nat_sent
6588         i=iat_sent(ii)
6589 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6590 c     &    num_cont_hb(i)
6591         do j=1,num_cont_hb(i)
6592         do k=1,4
6593           jjc=jcont_hb(j,i)
6594           iproc=iint_sent_local(k,jjc,ii)
6595 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6596           if (iproc.gt.0) then
6597             ncont_sent(iproc)=ncont_sent(iproc)+1
6598             nn=ncont_sent(iproc)
6599             zapas(1,nn,iproc)=i
6600             zapas(2,nn,iproc)=jjc
6601             zapas(3,nn,iproc)=facont_hb(j,i)
6602             zapas(4,nn,iproc)=ees0p(j,i)
6603             zapas(5,nn,iproc)=ees0m(j,i)
6604             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6605             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6606             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6607             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6608             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6609             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6610             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6611             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6612             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6613             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6614             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6615             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6616             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6617             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6618             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6619             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6620             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6621             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6622             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6623             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6624             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6625           endif
6626         enddo
6627         enddo
6628       enddo
6629       if (lprn) then
6630       write (iout,*)
6631      &  "Numbers of contacts to be sent to other processors",
6632      &  (ncont_sent(i),i=1,ntask_cont_to)
6633       write (iout,*) "Contacts sent"
6634       do ii=1,ntask_cont_to
6635         nn=ncont_sent(ii)
6636         iproc=itask_cont_to(ii)
6637         write (iout,*) nn," contacts to processor",iproc,
6638      &   " of CONT_TO_COMM group"
6639         do i=1,nn
6640           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6641         enddo
6642       enddo
6643       call flush(iout)
6644       endif
6645       CorrelType=477
6646       CorrelID=fg_rank+1
6647       CorrelType1=478
6648       CorrelID1=nfgtasks+fg_rank+1
6649       ireq=0
6650 C Receive the numbers of needed contacts from other processors
6651       do ii=1,ntask_cont_from
6652         iproc=itask_cont_from(ii)
6653         ireq=ireq+1
6654         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6655      &    FG_COMM,req(ireq),IERR)
6656       enddo
6657 c      write (iout,*) "IRECV ended"
6658 c      call flush(iout)
6659 C Send the number of contacts needed by other processors
6660       do ii=1,ntask_cont_to
6661         iproc=itask_cont_to(ii)
6662         ireq=ireq+1
6663         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6664      &    FG_COMM,req(ireq),IERR)
6665       enddo
6666 c      write (iout,*) "ISEND ended"
6667 c      write (iout,*) "number of requests (nn)",ireq
6668       call flush(iout)
6669       if (ireq.gt.0)
6670      &  call MPI_Waitall(ireq,req,status_array,ierr)
6671 c      write (iout,*)
6672 c     &  "Numbers of contacts to be received from other processors",
6673 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6674 c      call flush(iout)
6675 C Receive contacts
6676       ireq=0
6677       do ii=1,ntask_cont_from
6678         iproc=itask_cont_from(ii)
6679         nn=ncont_recv(ii)
6680 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6681 c     &   " of CONT_TO_COMM group"
6682         call flush(iout)
6683         if (nn.gt.0) then
6684           ireq=ireq+1
6685           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6686      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6687 c          write (iout,*) "ireq,req",ireq,req(ireq)
6688         endif
6689       enddo
6690 C Send the contacts to processors that need them
6691       do ii=1,ntask_cont_to
6692         iproc=itask_cont_to(ii)
6693         nn=ncont_sent(ii)
6694 c        write (iout,*) nn," contacts to processor",iproc,
6695 c     &   " of CONT_TO_COMM group"
6696         if (nn.gt.0) then
6697           ireq=ireq+1
6698           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6699      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6700 c          write (iout,*) "ireq,req",ireq,req(ireq)
6701 c          do i=1,nn
6702 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6703 c          enddo
6704         endif
6705       enddo
6706 c      write (iout,*) "number of requests (contacts)",ireq
6707 c      write (iout,*) "req",(req(i),i=1,4)
6708 c      call flush(iout)
6709       if (ireq.gt.0)
6710      & call MPI_Waitall(ireq,req,status_array,ierr)
6711       do iii=1,ntask_cont_from
6712         iproc=itask_cont_from(iii)
6713         nn=ncont_recv(iii)
6714         if (lprn) then
6715         write (iout,*) "Received",nn," contacts from processor",iproc,
6716      &   " of CONT_FROM_COMM group"
6717         call flush(iout)
6718         do i=1,nn
6719           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6720         enddo
6721         call flush(iout)
6722         endif
6723         do i=1,nn
6724           ii=zapas_recv(1,i,iii)
6725 c Flag the received contacts to prevent double-counting
6726           jj=-zapas_recv(2,i,iii)
6727 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6728 c          call flush(iout)
6729           nnn=num_cont_hb(ii)+1
6730           num_cont_hb(ii)=nnn
6731           jcont_hb(nnn,ii)=jj
6732           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6733           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6734           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6735           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6736           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6737           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6738           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6739           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6740           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6741           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6742           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6743           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6744           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6745           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6746           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6747           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6748           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6749           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6750           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6751           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6752           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6753           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6754           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6755           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6756         enddo
6757       enddo
6758       call flush(iout)
6759       if (lprn) then
6760         write (iout,'(a)') 'Contact function values after receive:'
6761         do i=nnt,nct-2
6762           write (iout,'(2i3,50(1x,i3,f5.2))')
6763      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6764      &    j=1,num_cont_hb(i))
6765         enddo
6766         call flush(iout)
6767       endif
6768    30 continue
6769 #endif
6770       if (lprn) then
6771         write (iout,'(a)') 'Contact function values:'
6772         do i=nnt,nct-2
6773           write (iout,'(2i3,50(1x,i3,f5.2))')
6774      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6775      &    j=1,num_cont_hb(i))
6776         enddo
6777       endif
6778       ecorr=0.0D0
6779 C Remove the loop below after debugging !!!
6780       do i=nnt,nct
6781         do j=1,3
6782           gradcorr(j,i)=0.0D0
6783           gradxorr(j,i)=0.0D0
6784         enddo
6785       enddo
6786 C Calculate the local-electrostatic correlation terms
6787       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6788         i1=i+1
6789         num_conti=num_cont_hb(i)
6790         num_conti1=num_cont_hb(i+1)
6791         do jj=1,num_conti
6792           j=jcont_hb(jj,i)
6793           jp=iabs(j)
6794           do kk=1,num_conti1
6795             j1=jcont_hb(kk,i1)
6796             jp1=iabs(j1)
6797 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6798 c     &         ' jj=',jj,' kk=',kk
6799             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6800      &          .or. j.lt.0 .and. j1.gt.0) .and.
6801      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6802 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6803 C The system gains extra energy.
6804               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6805               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6806      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6807               n_corr=n_corr+1
6808             else if (j1.eq.j) then
6809 C Contacts I-J and I-(J+1) occur simultaneously.
6810 C The system loses extra energy.
6811 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6812             endif
6813           enddo ! kk
6814           do kk=1,num_conti
6815             j1=jcont_hb(kk,i)
6816 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6817 c    &         ' jj=',jj,' kk=',kk
6818             if (j1.eq.j+1) then
6819 C Contacts I-J and (I+1)-J occur simultaneously.
6820 C The system loses extra energy.
6821 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6822             endif ! j1==j+1
6823           enddo ! kk
6824         enddo ! jj
6825       enddo ! i
6826       return
6827       end
6828 c------------------------------------------------------------------------------
6829       subroutine add_hb_contact(ii,jj,itask)
6830       implicit real*8 (a-h,o-z)
6831       include "DIMENSIONS"
6832       include "COMMON.IOUNITS"
6833       integer max_cont
6834       integer max_dim
6835       parameter (max_cont=maxconts)
6836       parameter (max_dim=26)
6837       include "COMMON.CONTACTS"
6838       double precision zapas(max_dim,maxconts,max_fg_procs),
6839      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6840       common /przechowalnia/ zapas
6841       integer i,j,ii,jj,iproc,itask(4),nn
6842 c      write (iout,*) "itask",itask
6843       do i=1,2
6844         iproc=itask(i)
6845         if (iproc.gt.0) then
6846           do j=1,num_cont_hb(ii)
6847             jjc=jcont_hb(j,ii)
6848 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6849             if (jjc.eq.jj) then
6850               ncont_sent(iproc)=ncont_sent(iproc)+1
6851               nn=ncont_sent(iproc)
6852               zapas(1,nn,iproc)=ii
6853               zapas(2,nn,iproc)=jjc
6854               zapas(3,nn,iproc)=facont_hb(j,ii)
6855               zapas(4,nn,iproc)=ees0p(j,ii)
6856               zapas(5,nn,iproc)=ees0m(j,ii)
6857               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6858               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6859               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6860               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6861               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6862               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6863               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6864               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6865               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6866               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6867               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6868               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6869               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6870               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6871               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6872               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6873               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6874               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6875               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6876               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6877               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6878               exit
6879             endif
6880           enddo
6881         endif
6882       enddo
6883       return
6884       end
6885 c------------------------------------------------------------------------------
6886       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6887      &  n_corr1)
6888 C This subroutine calculates multi-body contributions to hydrogen-bonding
6889       implicit real*8 (a-h,o-z)
6890       include 'DIMENSIONS'
6891       include 'COMMON.IOUNITS'
6892 #ifdef MPI
6893       include "mpif.h"
6894       parameter (max_cont=maxconts)
6895       parameter (max_dim=70)
6896       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6897       double precision zapas(max_dim,maxconts,max_fg_procs),
6898      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6899       common /przechowalnia/ zapas
6900       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6901      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6902 #endif
6903       include 'COMMON.SETUP'
6904       include 'COMMON.FFIELD'
6905       include 'COMMON.DERIV'
6906       include 'COMMON.LOCAL'
6907       include 'COMMON.INTERACT'
6908       include 'COMMON.CONTACTS'
6909       include 'COMMON.CHAIN'
6910       include 'COMMON.CONTROL'
6911       double precision gx(3),gx1(3)
6912       integer num_cont_hb_old(maxres)
6913       logical lprn,ldone
6914       double precision eello4,eello5,eelo6,eello_turn6
6915       external eello4,eello5,eello6,eello_turn6
6916 C Set lprn=.true. for debugging
6917       lprn=.false.
6918       eturn6=0.0d0
6919 #ifdef MPI
6920       do i=1,nres
6921         num_cont_hb_old(i)=num_cont_hb(i)
6922       enddo
6923       n_corr=0
6924       n_corr1=0
6925       if (nfgtasks.le.1) goto 30
6926       if (lprn) then
6927         write (iout,'(a)') 'Contact function values before RECEIVE:'
6928         do i=nnt,nct-2
6929           write (iout,'(2i3,50(1x,i2,f5.2))')
6930      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6931      &    j=1,num_cont_hb(i))
6932         enddo
6933       endif
6934       call flush(iout)
6935       do i=1,ntask_cont_from
6936         ncont_recv(i)=0
6937       enddo
6938       do i=1,ntask_cont_to
6939         ncont_sent(i)=0
6940       enddo
6941 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6942 c     & ntask_cont_to
6943 C Make the list of contacts to send to send to other procesors
6944       do i=iturn3_start,iturn3_end
6945 c        write (iout,*) "make contact list turn3",i," num_cont",
6946 c     &    num_cont_hb(i)
6947         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6948       enddo
6949       do i=iturn4_start,iturn4_end
6950 c        write (iout,*) "make contact list turn4",i," num_cont",
6951 c     &   num_cont_hb(i)
6952         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6953       enddo
6954       do ii=1,nat_sent
6955         i=iat_sent(ii)
6956 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6957 c     &    num_cont_hb(i)
6958         do j=1,num_cont_hb(i)
6959         do k=1,4
6960           jjc=jcont_hb(j,i)
6961           iproc=iint_sent_local(k,jjc,ii)
6962 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6963           if (iproc.ne.0) then
6964             ncont_sent(iproc)=ncont_sent(iproc)+1
6965             nn=ncont_sent(iproc)
6966             zapas(1,nn,iproc)=i
6967             zapas(2,nn,iproc)=jjc
6968             zapas(3,nn,iproc)=d_cont(j,i)
6969             ind=3
6970             do kk=1,3
6971               ind=ind+1
6972               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6973             enddo
6974             do kk=1,2
6975               do ll=1,2
6976                 ind=ind+1
6977                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6978               enddo
6979             enddo
6980             do jj=1,5
6981               do kk=1,3
6982                 do ll=1,2
6983                   do mm=1,2
6984                     ind=ind+1
6985                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6986                   enddo
6987                 enddo
6988               enddo
6989             enddo
6990           endif
6991         enddo
6992         enddo
6993       enddo
6994       if (lprn) then
6995       write (iout,*)
6996      &  "Numbers of contacts to be sent to other processors",
6997      &  (ncont_sent(i),i=1,ntask_cont_to)
6998       write (iout,*) "Contacts sent"
6999       do ii=1,ntask_cont_to
7000         nn=ncont_sent(ii)
7001         iproc=itask_cont_to(ii)
7002         write (iout,*) nn," contacts to processor",iproc,
7003      &   " of CONT_TO_COMM group"
7004         do i=1,nn
7005           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7006         enddo
7007       enddo
7008       call flush(iout)
7009       endif
7010       CorrelType=477
7011       CorrelID=fg_rank+1
7012       CorrelType1=478
7013       CorrelID1=nfgtasks+fg_rank+1
7014       ireq=0
7015 C Receive the numbers of needed contacts from other processors
7016       do ii=1,ntask_cont_from
7017         iproc=itask_cont_from(ii)
7018         ireq=ireq+1
7019         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7020      &    FG_COMM,req(ireq),IERR)
7021       enddo
7022 c      write (iout,*) "IRECV ended"
7023 c      call flush(iout)
7024 C Send the number of contacts needed by other processors
7025       do ii=1,ntask_cont_to
7026         iproc=itask_cont_to(ii)
7027         ireq=ireq+1
7028         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7029      &    FG_COMM,req(ireq),IERR)
7030       enddo
7031 c      write (iout,*) "ISEND ended"
7032 c      write (iout,*) "number of requests (nn)",ireq
7033       call flush(iout)
7034       if (ireq.gt.0)
7035      &  call MPI_Waitall(ireq,req,status_array,ierr)
7036 c      write (iout,*)
7037 c     &  "Numbers of contacts to be received from other processors",
7038 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7039 c      call flush(iout)
7040 C Receive contacts
7041       ireq=0
7042       do ii=1,ntask_cont_from
7043         iproc=itask_cont_from(ii)
7044         nn=ncont_recv(ii)
7045 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7046 c     &   " of CONT_TO_COMM group"
7047         call flush(iout)
7048         if (nn.gt.0) then
7049           ireq=ireq+1
7050           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7051      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7052 c          write (iout,*) "ireq,req",ireq,req(ireq)
7053         endif
7054       enddo
7055 C Send the contacts to processors that need them
7056       do ii=1,ntask_cont_to
7057         iproc=itask_cont_to(ii)
7058         nn=ncont_sent(ii)
7059 c        write (iout,*) nn," contacts to processor",iproc,
7060 c     &   " of CONT_TO_COMM group"
7061         if (nn.gt.0) then
7062           ireq=ireq+1
7063           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7064      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7065 c          write (iout,*) "ireq,req",ireq,req(ireq)
7066 c          do i=1,nn
7067 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7068 c          enddo
7069         endif
7070       enddo
7071 c      write (iout,*) "number of requests (contacts)",ireq
7072 c      write (iout,*) "req",(req(i),i=1,4)
7073 c      call flush(iout)
7074       if (ireq.gt.0)
7075      & call MPI_Waitall(ireq,req,status_array,ierr)
7076       do iii=1,ntask_cont_from
7077         iproc=itask_cont_from(iii)
7078         nn=ncont_recv(iii)
7079         if (lprn) then
7080         write (iout,*) "Received",nn," contacts from processor",iproc,
7081      &   " of CONT_FROM_COMM group"
7082         call flush(iout)
7083         do i=1,nn
7084           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7085         enddo
7086         call flush(iout)
7087         endif
7088         do i=1,nn
7089           ii=zapas_recv(1,i,iii)
7090 c Flag the received contacts to prevent double-counting
7091           jj=-zapas_recv(2,i,iii)
7092 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7093 c          call flush(iout)
7094           nnn=num_cont_hb(ii)+1
7095           num_cont_hb(ii)=nnn
7096           jcont_hb(nnn,ii)=jj
7097           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7098           ind=3
7099           do kk=1,3
7100             ind=ind+1
7101             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7102           enddo
7103           do kk=1,2
7104             do ll=1,2
7105               ind=ind+1
7106               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7107             enddo
7108           enddo
7109           do jj=1,5
7110             do kk=1,3
7111               do ll=1,2
7112                 do mm=1,2
7113                   ind=ind+1
7114                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7115                 enddo
7116               enddo
7117             enddo
7118           enddo
7119         enddo
7120       enddo
7121       call flush(iout)
7122       if (lprn) then
7123         write (iout,'(a)') 'Contact function values after receive:'
7124         do i=nnt,nct-2
7125           write (iout,'(2i3,50(1x,i3,5f6.3))')
7126      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7127      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7128         enddo
7129         call flush(iout)
7130       endif
7131    30 continue
7132 #endif
7133       if (lprn) then
7134         write (iout,'(a)') 'Contact function values:'
7135         do i=nnt,nct-2
7136           write (iout,'(2i3,50(1x,i2,5f6.3))')
7137      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7138      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7139         enddo
7140       endif
7141       ecorr=0.0D0
7142       ecorr5=0.0d0
7143       ecorr6=0.0d0
7144 C Remove the loop below after debugging !!!
7145       do i=nnt,nct
7146         do j=1,3
7147           gradcorr(j,i)=0.0D0
7148           gradxorr(j,i)=0.0D0
7149         enddo
7150       enddo
7151 C Calculate the dipole-dipole interaction energies
7152       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7153       do i=iatel_s,iatel_e+1
7154         num_conti=num_cont_hb(i)
7155         do jj=1,num_conti
7156           j=jcont_hb(jj,i)
7157 #ifdef MOMENT
7158           call dipole(i,j,jj)
7159 #endif
7160         enddo
7161       enddo
7162       endif
7163 C Calculate the local-electrostatic correlation terms
7164 c                write (iout,*) "gradcorr5 in eello5 before loop"
7165 c                do iii=1,nres
7166 c                  write (iout,'(i5,3f10.5)')
7167 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7168 c                enddo
7169       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7170 c        write (iout,*) "corr loop i",i
7171         i1=i+1
7172         num_conti=num_cont_hb(i)
7173         num_conti1=num_cont_hb(i+1)
7174         do jj=1,num_conti
7175           j=jcont_hb(jj,i)
7176           jp=iabs(j)
7177           do kk=1,num_conti1
7178             j1=jcont_hb(kk,i1)
7179             jp1=iabs(j1)
7180 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7181 c     &         ' jj=',jj,' kk=',kk
7182 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7183             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7184      &          .or. j.lt.0 .and. j1.gt.0) .and.
7185      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7186 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7187 C The system gains extra energy.
7188               n_corr=n_corr+1
7189               sqd1=dsqrt(d_cont(jj,i))
7190               sqd2=dsqrt(d_cont(kk,i1))
7191               sred_geom = sqd1*sqd2
7192               IF (sred_geom.lt.cutoff_corr) THEN
7193                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7194      &            ekont,fprimcont)
7195 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7196 cd     &         ' jj=',jj,' kk=',kk
7197                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7198                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7199                 do l=1,3
7200                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7201                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7202                 enddo
7203                 n_corr1=n_corr1+1
7204 cd               write (iout,*) 'sred_geom=',sred_geom,
7205 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7206 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7207 cd               write (iout,*) "g_contij",g_contij
7208 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7209 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7210                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7211                 if (wcorr4.gt.0.0d0)
7212      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7213                   if (energy_dec.and.wcorr4.gt.0.0d0)
7214      1                 write (iout,'(a6,4i5,0pf7.3)')
7215      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7216 c                write (iout,*) "gradcorr5 before eello5"
7217 c                do iii=1,nres
7218 c                  write (iout,'(i5,3f10.5)')
7219 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7220 c                enddo
7221                 if (wcorr5.gt.0.0d0)
7222      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7223 c                write (iout,*) "gradcorr5 after eello5"
7224 c                do iii=1,nres
7225 c                  write (iout,'(i5,3f10.5)')
7226 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7227 c                enddo
7228                   if (energy_dec.and.wcorr5.gt.0.0d0)
7229      1                 write (iout,'(a6,4i5,0pf7.3)')
7230      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7231 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7232 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7233                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7234      &               .or. wturn6.eq.0.0d0))then
7235 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7236                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7237                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7238      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7239 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7240 cd     &            'ecorr6=',ecorr6
7241 cd                write (iout,'(4e15.5)') sred_geom,
7242 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7243 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7244 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7245                 else if (wturn6.gt.0.0d0
7246      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7247 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7248                   eturn6=eturn6+eello_turn6(i,jj,kk)
7249                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7250      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7251 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7252                 endif
7253               ENDIF
7254 1111          continue
7255             endif
7256           enddo ! kk
7257         enddo ! jj
7258       enddo ! i
7259       do i=1,nres
7260         num_cont_hb(i)=num_cont_hb_old(i)
7261       enddo
7262 c                write (iout,*) "gradcorr5 in eello5"
7263 c                do iii=1,nres
7264 c                  write (iout,'(i5,3f10.5)')
7265 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7266 c                enddo
7267       return
7268       end
7269 c------------------------------------------------------------------------------
7270       subroutine add_hb_contact_eello(ii,jj,itask)
7271       implicit real*8 (a-h,o-z)
7272       include "DIMENSIONS"
7273       include "COMMON.IOUNITS"
7274       integer max_cont
7275       integer max_dim
7276       parameter (max_cont=maxconts)
7277       parameter (max_dim=70)
7278       include "COMMON.CONTACTS"
7279       double precision zapas(max_dim,maxconts,max_fg_procs),
7280      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7281       common /przechowalnia/ zapas
7282       integer i,j,ii,jj,iproc,itask(4),nn
7283 c      write (iout,*) "itask",itask
7284       do i=1,2
7285         iproc=itask(i)
7286         if (iproc.gt.0) then
7287           do j=1,num_cont_hb(ii)
7288             jjc=jcont_hb(j,ii)
7289 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7290             if (jjc.eq.jj) then
7291               ncont_sent(iproc)=ncont_sent(iproc)+1
7292               nn=ncont_sent(iproc)
7293               zapas(1,nn,iproc)=ii
7294               zapas(2,nn,iproc)=jjc
7295               zapas(3,nn,iproc)=d_cont(j,ii)
7296               ind=3
7297               do kk=1,3
7298                 ind=ind+1
7299                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7300               enddo
7301               do kk=1,2
7302                 do ll=1,2
7303                   ind=ind+1
7304                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7305                 enddo
7306               enddo
7307               do jj=1,5
7308                 do kk=1,3
7309                   do ll=1,2
7310                     do mm=1,2
7311                       ind=ind+1
7312                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7313                     enddo
7314                   enddo
7315                 enddo
7316               enddo
7317               exit
7318             endif
7319           enddo
7320         endif
7321       enddo
7322       return
7323       end
7324 c------------------------------------------------------------------------------
7325       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7326       implicit real*8 (a-h,o-z)
7327       include 'DIMENSIONS'
7328       include 'COMMON.IOUNITS'
7329       include 'COMMON.DERIV'
7330       include 'COMMON.INTERACT'
7331       include 'COMMON.CONTACTS'
7332       double precision gx(3),gx1(3)
7333       logical lprn
7334       lprn=.false.
7335       eij=facont_hb(jj,i)
7336       ekl=facont_hb(kk,k)
7337       ees0pij=ees0p(jj,i)
7338       ees0pkl=ees0p(kk,k)
7339       ees0mij=ees0m(jj,i)
7340       ees0mkl=ees0m(kk,k)
7341       ekont=eij*ekl
7342       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7343 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7344 C Following 4 lines for diagnostics.
7345 cd    ees0pkl=0.0D0
7346 cd    ees0pij=1.0D0
7347 cd    ees0mkl=0.0D0
7348 cd    ees0mij=1.0D0
7349 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7350 c     & 'Contacts ',i,j,
7351 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7352 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7353 c     & 'gradcorr_long'
7354 C Calculate the multi-body contribution to energy.
7355 c      ecorr=ecorr+ekont*ees
7356 C Calculate multi-body contributions to the gradient.
7357       coeffpees0pij=coeffp*ees0pij
7358       coeffmees0mij=coeffm*ees0mij
7359       coeffpees0pkl=coeffp*ees0pkl
7360       coeffmees0mkl=coeffm*ees0mkl
7361       do ll=1,3
7362 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7363         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7364      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7365      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7366         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7367      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7368      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7369 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7370         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7371      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7372      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7373         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7374      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7375      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7376         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7377      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7378      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7379         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7380         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7381         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7382      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7383      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7384         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7385         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7386 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7387       enddo
7388 c      write (iout,*)
7389 cgrad      do m=i+1,j-1
7390 cgrad        do ll=1,3
7391 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7392 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7393 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7394 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7395 cgrad        enddo
7396 cgrad      enddo
7397 cgrad      do m=k+1,l-1
7398 cgrad        do ll=1,3
7399 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7400 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7401 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7402 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7403 cgrad        enddo
7404 cgrad      enddo
7405 c      write (iout,*) "ehbcorr",ekont*ees
7406       ehbcorr=ekont*ees
7407       return
7408       end
7409 #ifdef MOMENT
7410 C---------------------------------------------------------------------------
7411       subroutine dipole(i,j,jj)
7412       implicit real*8 (a-h,o-z)
7413       include 'DIMENSIONS'
7414       include 'COMMON.IOUNITS'
7415       include 'COMMON.CHAIN'
7416       include 'COMMON.FFIELD'
7417       include 'COMMON.DERIV'
7418       include 'COMMON.INTERACT'
7419       include 'COMMON.CONTACTS'
7420       include 'COMMON.TORSION'
7421       include 'COMMON.VAR'
7422       include 'COMMON.GEO'
7423       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7424      &  auxmat(2,2)
7425       iti1 = itortyp(itype(i+1))
7426       if (j.lt.nres-1) then
7427         itj1 = itortyp(itype(j+1))
7428       else
7429         itj1=ntortyp
7430       endif
7431       do iii=1,2
7432         dipi(iii,1)=Ub2(iii,i)
7433         dipderi(iii)=Ub2der(iii,i)
7434         dipi(iii,2)=b1(iii,iti1)
7435         dipj(iii,1)=Ub2(iii,j)
7436         dipderj(iii)=Ub2der(iii,j)
7437         dipj(iii,2)=b1(iii,itj1)
7438       enddo
7439       kkk=0
7440       do iii=1,2
7441         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7442         do jjj=1,2
7443           kkk=kkk+1
7444           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7445         enddo
7446       enddo
7447       do kkk=1,5
7448         do lll=1,3
7449           mmm=0
7450           do iii=1,2
7451             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7452      &        auxvec(1))
7453             do jjj=1,2
7454               mmm=mmm+1
7455               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7456             enddo
7457           enddo
7458         enddo
7459       enddo
7460       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7461       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7462       do iii=1,2
7463         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7464       enddo
7465       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7466       do iii=1,2
7467         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7468       enddo
7469       return
7470       end
7471 #endif
7472 C---------------------------------------------------------------------------
7473       subroutine calc_eello(i,j,k,l,jj,kk)
7474 C
7475 C This subroutine computes matrices and vectors needed to calculate
7476 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7477 C
7478       implicit real*8 (a-h,o-z)
7479       include 'DIMENSIONS'
7480       include 'COMMON.IOUNITS'
7481       include 'COMMON.CHAIN'
7482       include 'COMMON.DERIV'
7483       include 'COMMON.INTERACT'
7484       include 'COMMON.CONTACTS'
7485       include 'COMMON.TORSION'
7486       include 'COMMON.VAR'
7487       include 'COMMON.GEO'
7488       include 'COMMON.FFIELD'
7489       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7490      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7491       logical lprn
7492       common /kutas/ lprn
7493 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7494 cd     & ' jj=',jj,' kk=',kk
7495 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7496 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7497 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7498       do iii=1,2
7499         do jjj=1,2
7500           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7501           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7502         enddo
7503       enddo
7504       call transpose2(aa1(1,1),aa1t(1,1))
7505       call transpose2(aa2(1,1),aa2t(1,1))
7506       do kkk=1,5
7507         do lll=1,3
7508           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7509      &      aa1tder(1,1,lll,kkk))
7510           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7511      &      aa2tder(1,1,lll,kkk))
7512         enddo
7513       enddo
7514       if (l.eq.j+1) then
7515 C parallel orientation of the two CA-CA-CA frames.
7516         if (i.gt.1) then
7517           iti=itortyp(itype(i))
7518         else
7519           iti=ntortyp
7520         endif
7521         itk1=itortyp(itype(k+1))
7522         itj=itortyp(itype(j))
7523         if (l.lt.nres-1) then
7524           itl1=itortyp(itype(l+1))
7525         else
7526           itl1=ntortyp
7527         endif
7528 C A1 kernel(j+1) A2T
7529 cd        do iii=1,2
7530 cd          write (iout,'(3f10.5,5x,3f10.5)')
7531 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7532 cd        enddo
7533         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7534      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7535      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7536 C Following matrices are needed only for 6-th order cumulants
7537         IF (wcorr6.gt.0.0d0) THEN
7538         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7539      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7540      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7541         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7542      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7543      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7544      &   ADtEAderx(1,1,1,1,1,1))
7545         lprn=.false.
7546         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7547      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7548      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7549      &   ADtEA1derx(1,1,1,1,1,1))
7550         ENDIF
7551 C End 6-th order cumulants
7552 cd        lprn=.false.
7553 cd        if (lprn) then
7554 cd        write (2,*) 'In calc_eello6'
7555 cd        do iii=1,2
7556 cd          write (2,*) 'iii=',iii
7557 cd          do kkk=1,5
7558 cd            write (2,*) 'kkk=',kkk
7559 cd            do jjj=1,2
7560 cd              write (2,'(3(2f10.5),5x)')
7561 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7562 cd            enddo
7563 cd          enddo
7564 cd        enddo
7565 cd        endif
7566         call transpose2(EUgder(1,1,k),auxmat(1,1))
7567         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7568         call transpose2(EUg(1,1,k),auxmat(1,1))
7569         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7570         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7571         do iii=1,2
7572           do kkk=1,5
7573             do lll=1,3
7574               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7575      &          EAEAderx(1,1,lll,kkk,iii,1))
7576             enddo
7577           enddo
7578         enddo
7579 C A1T kernel(i+1) A2
7580         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7581      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7582      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7583 C Following matrices are needed only for 6-th order cumulants
7584         IF (wcorr6.gt.0.0d0) THEN
7585         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7586      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7587      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7588         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7589      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7590      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7591      &   ADtEAderx(1,1,1,1,1,2))
7592         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7593      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7594      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7595      &   ADtEA1derx(1,1,1,1,1,2))
7596         ENDIF
7597 C End 6-th order cumulants
7598         call transpose2(EUgder(1,1,l),auxmat(1,1))
7599         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7600         call transpose2(EUg(1,1,l),auxmat(1,1))
7601         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7602         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7603         do iii=1,2
7604           do kkk=1,5
7605             do lll=1,3
7606               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7607      &          EAEAderx(1,1,lll,kkk,iii,2))
7608             enddo
7609           enddo
7610         enddo
7611 C AEAb1 and AEAb2
7612 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7613 C They are needed only when the fifth- or the sixth-order cumulants are
7614 C indluded.
7615         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7616         call transpose2(AEA(1,1,1),auxmat(1,1))
7617         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7618         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7619         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7620         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7621         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7622         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7623         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7624         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7625         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7626         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7627         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7628         call transpose2(AEA(1,1,2),auxmat(1,1))
7629         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7630         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7631         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7632         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7633         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7634         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7635         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7636         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7637         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7638         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7639         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7640 C Calculate the Cartesian derivatives of the vectors.
7641         do iii=1,2
7642           do kkk=1,5
7643             do lll=1,3
7644               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7645               call matvec2(auxmat(1,1),b1(1,iti),
7646      &          AEAb1derx(1,lll,kkk,iii,1,1))
7647               call matvec2(auxmat(1,1),Ub2(1,i),
7648      &          AEAb2derx(1,lll,kkk,iii,1,1))
7649               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7650      &          AEAb1derx(1,lll,kkk,iii,2,1))
7651               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7652      &          AEAb2derx(1,lll,kkk,iii,2,1))
7653               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7654               call matvec2(auxmat(1,1),b1(1,itj),
7655      &          AEAb1derx(1,lll,kkk,iii,1,2))
7656               call matvec2(auxmat(1,1),Ub2(1,j),
7657      &          AEAb2derx(1,lll,kkk,iii,1,2))
7658               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7659      &          AEAb1derx(1,lll,kkk,iii,2,2))
7660               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7661      &          AEAb2derx(1,lll,kkk,iii,2,2))
7662             enddo
7663           enddo
7664         enddo
7665         ENDIF
7666 C End vectors
7667       else
7668 C Antiparallel orientation of the two CA-CA-CA frames.
7669         if (i.gt.1) then
7670           iti=itortyp(itype(i))
7671         else
7672           iti=ntortyp
7673         endif
7674         itk1=itortyp(itype(k+1))
7675         itl=itortyp(itype(l))
7676         itj=itortyp(itype(j))
7677         if (j.lt.nres-1) then
7678           itj1=itortyp(itype(j+1))
7679         else
7680           itj1=ntortyp
7681         endif
7682 C A2 kernel(j-1)T A1T
7683         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7684      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7685      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7686 C Following matrices are needed only for 6-th order cumulants
7687         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7688      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7689         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7690      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7691      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7692         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7693      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7694      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7695      &   ADtEAderx(1,1,1,1,1,1))
7696         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7697      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7698      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7699      &   ADtEA1derx(1,1,1,1,1,1))
7700         ENDIF
7701 C End 6-th order cumulants
7702         call transpose2(EUgder(1,1,k),auxmat(1,1))
7703         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7704         call transpose2(EUg(1,1,k),auxmat(1,1))
7705         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7706         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7707         do iii=1,2
7708           do kkk=1,5
7709             do lll=1,3
7710               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7711      &          EAEAderx(1,1,lll,kkk,iii,1))
7712             enddo
7713           enddo
7714         enddo
7715 C A2T kernel(i+1)T A1
7716         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7717      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7718      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7719 C Following matrices are needed only for 6-th order cumulants
7720         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7721      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7722         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7723      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7724      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7725         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7726      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7727      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7728      &   ADtEAderx(1,1,1,1,1,2))
7729         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7730      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7731      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7732      &   ADtEA1derx(1,1,1,1,1,2))
7733         ENDIF
7734 C End 6-th order cumulants
7735         call transpose2(EUgder(1,1,j),auxmat(1,1))
7736         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7737         call transpose2(EUg(1,1,j),auxmat(1,1))
7738         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7739         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7740         do iii=1,2
7741           do kkk=1,5
7742             do lll=1,3
7743               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7744      &          EAEAderx(1,1,lll,kkk,iii,2))
7745             enddo
7746           enddo
7747         enddo
7748 C AEAb1 and AEAb2
7749 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7750 C They are needed only when the fifth- or the sixth-order cumulants are
7751 C indluded.
7752         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7753      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7754         call transpose2(AEA(1,1,1),auxmat(1,1))
7755         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7756         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7757         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7758         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7759         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7760         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7761         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7762         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7763         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7764         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7765         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7766         call transpose2(AEA(1,1,2),auxmat(1,1))
7767         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7768         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7769         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7770         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7771         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7772         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7773         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7774         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7775         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7776         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7777         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7778 C Calculate the Cartesian derivatives of the vectors.
7779         do iii=1,2
7780           do kkk=1,5
7781             do lll=1,3
7782               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7783               call matvec2(auxmat(1,1),b1(1,iti),
7784      &          AEAb1derx(1,lll,kkk,iii,1,1))
7785               call matvec2(auxmat(1,1),Ub2(1,i),
7786      &          AEAb2derx(1,lll,kkk,iii,1,1))
7787               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7788      &          AEAb1derx(1,lll,kkk,iii,2,1))
7789               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7790      &          AEAb2derx(1,lll,kkk,iii,2,1))
7791               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7792               call matvec2(auxmat(1,1),b1(1,itl),
7793      &          AEAb1derx(1,lll,kkk,iii,1,2))
7794               call matvec2(auxmat(1,1),Ub2(1,l),
7795      &          AEAb2derx(1,lll,kkk,iii,1,2))
7796               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7797      &          AEAb1derx(1,lll,kkk,iii,2,2))
7798               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7799      &          AEAb2derx(1,lll,kkk,iii,2,2))
7800             enddo
7801           enddo
7802         enddo
7803         ENDIF
7804 C End vectors
7805       endif
7806       return
7807       end
7808 C---------------------------------------------------------------------------
7809       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7810      &  KK,KKderg,AKA,AKAderg,AKAderx)
7811       implicit none
7812       integer nderg
7813       logical transp
7814       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7815      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7816      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7817       integer iii,kkk,lll
7818       integer jjj,mmm
7819       logical lprn
7820       common /kutas/ lprn
7821       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7822       do iii=1,nderg
7823         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7824      &    AKAderg(1,1,iii))
7825       enddo
7826 cd      if (lprn) write (2,*) 'In kernel'
7827       do kkk=1,5
7828 cd        if (lprn) write (2,*) 'kkk=',kkk
7829         do lll=1,3
7830           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7831      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7832 cd          if (lprn) then
7833 cd            write (2,*) 'lll=',lll
7834 cd            write (2,*) 'iii=1'
7835 cd            do jjj=1,2
7836 cd              write (2,'(3(2f10.5),5x)')
7837 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7838 cd            enddo
7839 cd          endif
7840           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7841      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7842 cd          if (lprn) then
7843 cd            write (2,*) 'lll=',lll
7844 cd            write (2,*) 'iii=2'
7845 cd            do jjj=1,2
7846 cd              write (2,'(3(2f10.5),5x)')
7847 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7848 cd            enddo
7849 cd          endif
7850         enddo
7851       enddo
7852       return
7853       end
7854 C---------------------------------------------------------------------------
7855       double precision function eello4(i,j,k,l,jj,kk)
7856       implicit real*8 (a-h,o-z)
7857       include 'DIMENSIONS'
7858       include 'COMMON.IOUNITS'
7859       include 'COMMON.CHAIN'
7860       include 'COMMON.DERIV'
7861       include 'COMMON.INTERACT'
7862       include 'COMMON.CONTACTS'
7863       include 'COMMON.TORSION'
7864       include 'COMMON.VAR'
7865       include 'COMMON.GEO'
7866       double precision pizda(2,2),ggg1(3),ggg2(3)
7867 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7868 cd        eello4=0.0d0
7869 cd        return
7870 cd      endif
7871 cd      print *,'eello4:',i,j,k,l,jj,kk
7872 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7873 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7874 cold      eij=facont_hb(jj,i)
7875 cold      ekl=facont_hb(kk,k)
7876 cold      ekont=eij*ekl
7877       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7878 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7879       gcorr_loc(k-1)=gcorr_loc(k-1)
7880      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7881       if (l.eq.j+1) then
7882         gcorr_loc(l-1)=gcorr_loc(l-1)
7883      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7884       else
7885         gcorr_loc(j-1)=gcorr_loc(j-1)
7886      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7887       endif
7888       do iii=1,2
7889         do kkk=1,5
7890           do lll=1,3
7891             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7892      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7893 cd            derx(lll,kkk,iii)=0.0d0
7894           enddo
7895         enddo
7896       enddo
7897 cd      gcorr_loc(l-1)=0.0d0
7898 cd      gcorr_loc(j-1)=0.0d0
7899 cd      gcorr_loc(k-1)=0.0d0
7900 cd      eel4=1.0d0
7901 cd      write (iout,*)'Contacts have occurred for peptide groups',
7902 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7903 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7904       if (j.lt.nres-1) then
7905         j1=j+1
7906         j2=j-1
7907       else
7908         j1=j-1
7909         j2=j-2
7910       endif
7911       if (l.lt.nres-1) then
7912         l1=l+1
7913         l2=l-1
7914       else
7915         l1=l-1
7916         l2=l-2
7917       endif
7918       do ll=1,3
7919 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7920 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7921         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7922         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7923 cgrad        ghalf=0.5d0*ggg1(ll)
7924         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7925         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7926         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7927         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7928         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7929         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7930 cgrad        ghalf=0.5d0*ggg2(ll)
7931         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7932         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7933         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7934         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7935         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7936         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7937       enddo
7938 cgrad      do m=i+1,j-1
7939 cgrad        do ll=1,3
7940 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7941 cgrad        enddo
7942 cgrad      enddo
7943 cgrad      do m=k+1,l-1
7944 cgrad        do ll=1,3
7945 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7946 cgrad        enddo
7947 cgrad      enddo
7948 cgrad      do m=i+2,j2
7949 cgrad        do ll=1,3
7950 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7951 cgrad        enddo
7952 cgrad      enddo
7953 cgrad      do m=k+2,l2
7954 cgrad        do ll=1,3
7955 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7956 cgrad        enddo
7957 cgrad      enddo
7958 cd      do iii=1,nres-3
7959 cd        write (2,*) iii,gcorr_loc(iii)
7960 cd      enddo
7961       eello4=ekont*eel4
7962 cd      write (2,*) 'ekont',ekont
7963 cd      write (iout,*) 'eello4',ekont*eel4
7964       return
7965       end
7966 C---------------------------------------------------------------------------
7967       double precision function eello5(i,j,k,l,jj,kk)
7968       implicit real*8 (a-h,o-z)
7969       include 'DIMENSIONS'
7970       include 'COMMON.IOUNITS'
7971       include 'COMMON.CHAIN'
7972       include 'COMMON.DERIV'
7973       include 'COMMON.INTERACT'
7974       include 'COMMON.CONTACTS'
7975       include 'COMMON.TORSION'
7976       include 'COMMON.VAR'
7977       include 'COMMON.GEO'
7978       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7979       double precision ggg1(3),ggg2(3)
7980 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7981 C                                                                              C
7982 C                            Parallel chains                                   C
7983 C                                                                              C
7984 C          o             o                   o             o                   C
7985 C         /l\           / \             \   / \           / \   /              C
7986 C        /   \         /   \             \ /   \         /   \ /               C
7987 C       j| o |l1       | o |              o| o |         | o |o                C
7988 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7989 C      \i/   \         /   \ /             /   \         /   \                 C
7990 C       o    k1             o                                                  C
7991 C         (I)          (II)                (III)          (IV)                 C
7992 C                                                                              C
7993 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7994 C                                                                              C
7995 C                            Antiparallel chains                               C
7996 C                                                                              C
7997 C          o             o                   o             o                   C
7998 C         /j\           / \             \   / \           / \   /              C
7999 C        /   \         /   \             \ /   \         /   \ /               C
8000 C      j1| o |l        | o |              o| o |         | o |o                C
8001 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8002 C      \i/   \         /   \ /             /   \         /   \                 C
8003 C       o     k1            o                                                  C
8004 C         (I)          (II)                (III)          (IV)                 C
8005 C                                                                              C
8006 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8007 C                                                                              C
8008 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8009 C                                                                              C
8010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8011 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8012 cd        eello5=0.0d0
8013 cd        return
8014 cd      endif
8015 cd      write (iout,*)
8016 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8017 cd     &   ' and',k,l
8018       itk=itortyp(itype(k))
8019       itl=itortyp(itype(l))
8020       itj=itortyp(itype(j))
8021       eello5_1=0.0d0
8022       eello5_2=0.0d0
8023       eello5_3=0.0d0
8024       eello5_4=0.0d0
8025 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8026 cd     &   eel5_3_num,eel5_4_num)
8027       do iii=1,2
8028         do kkk=1,5
8029           do lll=1,3
8030             derx(lll,kkk,iii)=0.0d0
8031           enddo
8032         enddo
8033       enddo
8034 cd      eij=facont_hb(jj,i)
8035 cd      ekl=facont_hb(kk,k)
8036 cd      ekont=eij*ekl
8037 cd      write (iout,*)'Contacts have occurred for peptide groups',
8038 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8039 cd      goto 1111
8040 C Contribution from the graph I.
8041 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8042 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8043       call transpose2(EUg(1,1,k),auxmat(1,1))
8044       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8045       vv(1)=pizda(1,1)-pizda(2,2)
8046       vv(2)=pizda(1,2)+pizda(2,1)
8047       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8048      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8049 C Explicit gradient in virtual-dihedral angles.
8050       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8051      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8052      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8053       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8054       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8055       vv(1)=pizda(1,1)-pizda(2,2)
8056       vv(2)=pizda(1,2)+pizda(2,1)
8057       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8058      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8059      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8060       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8061       vv(1)=pizda(1,1)-pizda(2,2)
8062       vv(2)=pizda(1,2)+pizda(2,1)
8063       if (l.eq.j+1) then
8064         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8065      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8066      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8067       else
8068         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8069      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8070      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8071       endif
8072 C Cartesian gradient
8073       do iii=1,2
8074         do kkk=1,5
8075           do lll=1,3
8076             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8077      &        pizda(1,1))
8078             vv(1)=pizda(1,1)-pizda(2,2)
8079             vv(2)=pizda(1,2)+pizda(2,1)
8080             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8081      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8082      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8083           enddo
8084         enddo
8085       enddo
8086 c      goto 1112
8087 c1111  continue
8088 C Contribution from graph II
8089       call transpose2(EE(1,1,itk),auxmat(1,1))
8090       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8091       vv(1)=pizda(1,1)+pizda(2,2)
8092       vv(2)=pizda(2,1)-pizda(1,2)
8093       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8094      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8095 C Explicit gradient in virtual-dihedral angles.
8096       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8097      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8098       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8099       vv(1)=pizda(1,1)+pizda(2,2)
8100       vv(2)=pizda(2,1)-pizda(1,2)
8101       if (l.eq.j+1) then
8102         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8103      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8104      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8105       else
8106         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8107      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8108      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8109       endif
8110 C Cartesian gradient
8111       do iii=1,2
8112         do kkk=1,5
8113           do lll=1,3
8114             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8115      &        pizda(1,1))
8116             vv(1)=pizda(1,1)+pizda(2,2)
8117             vv(2)=pizda(2,1)-pizda(1,2)
8118             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8119      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8120      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8121           enddo
8122         enddo
8123       enddo
8124 cd      goto 1112
8125 cd1111  continue
8126       if (l.eq.j+1) then
8127 cd        goto 1110
8128 C Parallel orientation
8129 C Contribution from graph III
8130         call transpose2(EUg(1,1,l),auxmat(1,1))
8131         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8132         vv(1)=pizda(1,1)-pizda(2,2)
8133         vv(2)=pizda(1,2)+pizda(2,1)
8134         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8135      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8136 C Explicit gradient in virtual-dihedral angles.
8137         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8138      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8139      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8140         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8141         vv(1)=pizda(1,1)-pizda(2,2)
8142         vv(2)=pizda(1,2)+pizda(2,1)
8143         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8144      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8145      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8146         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8147         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8148         vv(1)=pizda(1,1)-pizda(2,2)
8149         vv(2)=pizda(1,2)+pizda(2,1)
8150         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8151      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8152      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8153 C Cartesian gradient
8154         do iii=1,2
8155           do kkk=1,5
8156             do lll=1,3
8157               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8158      &          pizda(1,1))
8159               vv(1)=pizda(1,1)-pizda(2,2)
8160               vv(2)=pizda(1,2)+pizda(2,1)
8161               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8162      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8163      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8164             enddo
8165           enddo
8166         enddo
8167 cd        goto 1112
8168 C Contribution from graph IV
8169 cd1110    continue
8170         call transpose2(EE(1,1,itl),auxmat(1,1))
8171         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8172         vv(1)=pizda(1,1)+pizda(2,2)
8173         vv(2)=pizda(2,1)-pizda(1,2)
8174         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8175      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8176 C Explicit gradient in virtual-dihedral angles.
8177         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8178      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8179         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8180         vv(1)=pizda(1,1)+pizda(2,2)
8181         vv(2)=pizda(2,1)-pizda(1,2)
8182         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8183      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8184      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8185 C Cartesian gradient
8186         do iii=1,2
8187           do kkk=1,5
8188             do lll=1,3
8189               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8190      &          pizda(1,1))
8191               vv(1)=pizda(1,1)+pizda(2,2)
8192               vv(2)=pizda(2,1)-pizda(1,2)
8193               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8194      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8195      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8196             enddo
8197           enddo
8198         enddo
8199       else
8200 C Antiparallel orientation
8201 C Contribution from graph III
8202 c        goto 1110
8203         call transpose2(EUg(1,1,j),auxmat(1,1))
8204         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8205         vv(1)=pizda(1,1)-pizda(2,2)
8206         vv(2)=pizda(1,2)+pizda(2,1)
8207         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8208      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8209 C Explicit gradient in virtual-dihedral angles.
8210         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8211      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8212      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8213         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8214         vv(1)=pizda(1,1)-pizda(2,2)
8215         vv(2)=pizda(1,2)+pizda(2,1)
8216         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8217      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8218      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8219         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8220         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8221         vv(1)=pizda(1,1)-pizda(2,2)
8222         vv(2)=pizda(1,2)+pizda(2,1)
8223         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8224      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8225      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8226 C Cartesian gradient
8227         do iii=1,2
8228           do kkk=1,5
8229             do lll=1,3
8230               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8231      &          pizda(1,1))
8232               vv(1)=pizda(1,1)-pizda(2,2)
8233               vv(2)=pizda(1,2)+pizda(2,1)
8234               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8235      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8236      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8237             enddo
8238           enddo
8239         enddo
8240 cd        goto 1112
8241 C Contribution from graph IV
8242 1110    continue
8243         call transpose2(EE(1,1,itj),auxmat(1,1))
8244         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8245         vv(1)=pizda(1,1)+pizda(2,2)
8246         vv(2)=pizda(2,1)-pizda(1,2)
8247         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8248      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8249 C Explicit gradient in virtual-dihedral angles.
8250         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8251      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8252         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8253         vv(1)=pizda(1,1)+pizda(2,2)
8254         vv(2)=pizda(2,1)-pizda(1,2)
8255         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8256      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8257      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8258 C Cartesian gradient
8259         do iii=1,2
8260           do kkk=1,5
8261             do lll=1,3
8262               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8263      &          pizda(1,1))
8264               vv(1)=pizda(1,1)+pizda(2,2)
8265               vv(2)=pizda(2,1)-pizda(1,2)
8266               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8267      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8268      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8269             enddo
8270           enddo
8271         enddo
8272       endif
8273 1112  continue
8274       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8275 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8276 cd        write (2,*) 'ijkl',i,j,k,l
8277 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8278 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8279 cd      endif
8280 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8281 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8282 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8283 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8284       if (j.lt.nres-1) then
8285         j1=j+1
8286         j2=j-1
8287       else
8288         j1=j-1
8289         j2=j-2
8290       endif
8291       if (l.lt.nres-1) then
8292         l1=l+1
8293         l2=l-1
8294       else
8295         l1=l-1
8296         l2=l-2
8297       endif
8298 cd      eij=1.0d0
8299 cd      ekl=1.0d0
8300 cd      ekont=1.0d0
8301 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8302 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8303 C        summed up outside the subrouine as for the other subroutines
8304 C        handling long-range interactions. The old code is commented out
8305 C        with "cgrad" to keep track of changes.
8306       do ll=1,3
8307 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8308 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8309         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8310         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8311 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8312 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8313 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8314 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8315 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8316 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8317 c     &   gradcorr5ij,
8318 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8319 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8320 cgrad        ghalf=0.5d0*ggg1(ll)
8321 cd        ghalf=0.0d0
8322         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8323         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8324         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8325         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8326         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8327         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8328 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8329 cgrad        ghalf=0.5d0*ggg2(ll)
8330 cd        ghalf=0.0d0
8331         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8332         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8333         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8334         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8335         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8336         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8337       enddo
8338 cd      goto 1112
8339 cgrad      do m=i+1,j-1
8340 cgrad        do ll=1,3
8341 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8342 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8343 cgrad        enddo
8344 cgrad      enddo
8345 cgrad      do m=k+1,l-1
8346 cgrad        do ll=1,3
8347 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8348 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8349 cgrad        enddo
8350 cgrad      enddo
8351 c1112  continue
8352 cgrad      do m=i+2,j2
8353 cgrad        do ll=1,3
8354 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8355 cgrad        enddo
8356 cgrad      enddo
8357 cgrad      do m=k+2,l2
8358 cgrad        do ll=1,3
8359 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8360 cgrad        enddo
8361 cgrad      enddo
8362 cd      do iii=1,nres-3
8363 cd        write (2,*) iii,g_corr5_loc(iii)
8364 cd      enddo
8365       eello5=ekont*eel5
8366 cd      write (2,*) 'ekont',ekont
8367 cd      write (iout,*) 'eello5',ekont*eel5
8368       return
8369       end
8370 c--------------------------------------------------------------------------
8371       double precision function eello6(i,j,k,l,jj,kk)
8372       implicit real*8 (a-h,o-z)
8373       include 'DIMENSIONS'
8374       include 'COMMON.IOUNITS'
8375       include 'COMMON.CHAIN'
8376       include 'COMMON.DERIV'
8377       include 'COMMON.INTERACT'
8378       include 'COMMON.CONTACTS'
8379       include 'COMMON.TORSION'
8380       include 'COMMON.VAR'
8381       include 'COMMON.GEO'
8382       include 'COMMON.FFIELD'
8383       double precision ggg1(3),ggg2(3)
8384 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8385 cd        eello6=0.0d0
8386 cd        return
8387 cd      endif
8388 cd      write (iout,*)
8389 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8390 cd     &   ' and',k,l
8391       eello6_1=0.0d0
8392       eello6_2=0.0d0
8393       eello6_3=0.0d0
8394       eello6_4=0.0d0
8395       eello6_5=0.0d0
8396       eello6_6=0.0d0
8397 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8398 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8399       do iii=1,2
8400         do kkk=1,5
8401           do lll=1,3
8402             derx(lll,kkk,iii)=0.0d0
8403           enddo
8404         enddo
8405       enddo
8406 cd      eij=facont_hb(jj,i)
8407 cd      ekl=facont_hb(kk,k)
8408 cd      ekont=eij*ekl
8409 cd      eij=1.0d0
8410 cd      ekl=1.0d0
8411 cd      ekont=1.0d0
8412       if (l.eq.j+1) then
8413         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8414         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8415         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8416         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8417         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8418         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8419       else
8420         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8421         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8422         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8423         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8424         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8425           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8426         else
8427           eello6_5=0.0d0
8428         endif
8429         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8430       endif
8431 C If turn contributions are considered, they will be handled separately.
8432       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8433 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8434 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8435 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8436 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8437 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8438 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8439 cd      goto 1112
8440       if (j.lt.nres-1) then
8441         j1=j+1
8442         j2=j-1
8443       else
8444         j1=j-1
8445         j2=j-2
8446       endif
8447       if (l.lt.nres-1) then
8448         l1=l+1
8449         l2=l-1
8450       else
8451         l1=l-1
8452         l2=l-2
8453       endif
8454       do ll=1,3
8455 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8456 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8457 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8458 cgrad        ghalf=0.5d0*ggg1(ll)
8459 cd        ghalf=0.0d0
8460         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8461         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8462         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8463         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8464         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8465         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8466         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8467         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8468 cgrad        ghalf=0.5d0*ggg2(ll)
8469 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8470 cd        ghalf=0.0d0
8471         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8472         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8473         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8474         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8475         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8476         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8477       enddo
8478 cd      goto 1112
8479 cgrad      do m=i+1,j-1
8480 cgrad        do ll=1,3
8481 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8482 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8483 cgrad        enddo
8484 cgrad      enddo
8485 cgrad      do m=k+1,l-1
8486 cgrad        do ll=1,3
8487 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8488 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8489 cgrad        enddo
8490 cgrad      enddo
8491 cgrad1112  continue
8492 cgrad      do m=i+2,j2
8493 cgrad        do ll=1,3
8494 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8495 cgrad        enddo
8496 cgrad      enddo
8497 cgrad      do m=k+2,l2
8498 cgrad        do ll=1,3
8499 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8500 cgrad        enddo
8501 cgrad      enddo
8502 cd      do iii=1,nres-3
8503 cd        write (2,*) iii,g_corr6_loc(iii)
8504 cd      enddo
8505       eello6=ekont*eel6
8506 cd      write (2,*) 'ekont',ekont
8507 cd      write (iout,*) 'eello6',ekont*eel6
8508       return
8509       end
8510 c--------------------------------------------------------------------------
8511       double precision function eello6_graph1(i,j,k,l,imat,swap)
8512       implicit real*8 (a-h,o-z)
8513       include 'DIMENSIONS'
8514       include 'COMMON.IOUNITS'
8515       include 'COMMON.CHAIN'
8516       include 'COMMON.DERIV'
8517       include 'COMMON.INTERACT'
8518       include 'COMMON.CONTACTS'
8519       include 'COMMON.TORSION'
8520       include 'COMMON.VAR'
8521       include 'COMMON.GEO'
8522       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8523       logical swap
8524       logical lprn
8525       common /kutas/ lprn
8526 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8527 C                                                                              C
8528 C      Parallel       Antiparallel                                             C
8529 C                                                                              C
8530 C          o             o                                                     C
8531 C         /l\           /j\                                                    C
8532 C        /   \         /   \                                                   C
8533 C       /| o |         | o |\                                                  C
8534 C     \ j|/k\|  /   \  |/k\|l /                                                C
8535 C      \ /   \ /     \ /   \ /                                                 C
8536 C       o     o       o     o                                                  C
8537 C       i             i                                                        C
8538 C                                                                              C
8539 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8540       itk=itortyp(itype(k))
8541       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8542       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8543       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8544       call transpose2(EUgC(1,1,k),auxmat(1,1))
8545       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8546       vv1(1)=pizda1(1,1)-pizda1(2,2)
8547       vv1(2)=pizda1(1,2)+pizda1(2,1)
8548       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8549       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8550       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8551       s5=scalar2(vv(1),Dtobr2(1,i))
8552 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8553       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8554       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8555      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8556      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8557      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8558      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8559      & +scalar2(vv(1),Dtobr2der(1,i)))
8560       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8561       vv1(1)=pizda1(1,1)-pizda1(2,2)
8562       vv1(2)=pizda1(1,2)+pizda1(2,1)
8563       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8564       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8565       if (l.eq.j+1) then
8566         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8567      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8568      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8569      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8570      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8571       else
8572         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8573      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8574      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8575      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8576      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8577       endif
8578       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8579       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8580       vv1(1)=pizda1(1,1)-pizda1(2,2)
8581       vv1(2)=pizda1(1,2)+pizda1(2,1)
8582       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8583      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8584      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8585      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8586       do iii=1,2
8587         if (swap) then
8588           ind=3-iii
8589         else
8590           ind=iii
8591         endif
8592         do kkk=1,5
8593           do lll=1,3
8594             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8595             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8596             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8597             call transpose2(EUgC(1,1,k),auxmat(1,1))
8598             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8599      &        pizda1(1,1))
8600             vv1(1)=pizda1(1,1)-pizda1(2,2)
8601             vv1(2)=pizda1(1,2)+pizda1(2,1)
8602             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8603             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8604      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8605             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8606      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8607             s5=scalar2(vv(1),Dtobr2(1,i))
8608             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8609           enddo
8610         enddo
8611       enddo
8612       return
8613       end
8614 c----------------------------------------------------------------------------
8615       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8616       implicit real*8 (a-h,o-z)
8617       include 'DIMENSIONS'
8618       include 'COMMON.IOUNITS'
8619       include 'COMMON.CHAIN'
8620       include 'COMMON.DERIV'
8621       include 'COMMON.INTERACT'
8622       include 'COMMON.CONTACTS'
8623       include 'COMMON.TORSION'
8624       include 'COMMON.VAR'
8625       include 'COMMON.GEO'
8626       logical swap
8627       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8628      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8629       logical lprn
8630       common /kutas/ lprn
8631 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8632 C                                                                              C
8633 C      Parallel       Antiparallel                                             C
8634 C                                                                              C
8635 C          o             o                                                     C
8636 C     \   /l\           /j\   /                                                C
8637 C      \ /   \         /   \ /                                                 C
8638 C       o| o |         | o |o                                                  C
8639 C     \ j|/k\|      \  |/k\|l                                                  C
8640 C      \ /   \       \ /   \                                                   C
8641 C       o             o                                                        C
8642 C       i             i                                                        C
8643 C                                                                              C
8644 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8645 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8646 C AL 7/4/01 s1 would occur in the sixth-order moment,
8647 C           but not in a cluster cumulant
8648 #ifdef MOMENT
8649       s1=dip(1,jj,i)*dip(1,kk,k)
8650 #endif
8651       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8652       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8653       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8654       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8655       call transpose2(EUg(1,1,k),auxmat(1,1))
8656       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8657       vv(1)=pizda(1,1)-pizda(2,2)
8658       vv(2)=pizda(1,2)+pizda(2,1)
8659       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8660 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8661 #ifdef MOMENT
8662       eello6_graph2=-(s1+s2+s3+s4)
8663 #else
8664       eello6_graph2=-(s2+s3+s4)
8665 #endif
8666 c      eello6_graph2=-s3
8667 C Derivatives in gamma(i-1)
8668       if (i.gt.1) then
8669 #ifdef MOMENT
8670         s1=dipderg(1,jj,i)*dip(1,kk,k)
8671 #endif
8672         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8673         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8674         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8675         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8676 #ifdef MOMENT
8677         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8678 #else
8679         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8680 #endif
8681 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8682       endif
8683 C Derivatives in gamma(k-1)
8684 #ifdef MOMENT
8685       s1=dip(1,jj,i)*dipderg(1,kk,k)
8686 #endif
8687       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8688       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8689       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8690       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8691       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8692       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8693       vv(1)=pizda(1,1)-pizda(2,2)
8694       vv(2)=pizda(1,2)+pizda(2,1)
8695       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8696 #ifdef MOMENT
8697       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8698 #else
8699       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8700 #endif
8701 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8702 C Derivatives in gamma(j-1) or gamma(l-1)
8703       if (j.gt.1) then
8704 #ifdef MOMENT
8705         s1=dipderg(3,jj,i)*dip(1,kk,k)
8706 #endif
8707         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8708         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8709         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8710         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8711         vv(1)=pizda(1,1)-pizda(2,2)
8712         vv(2)=pizda(1,2)+pizda(2,1)
8713         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8714 #ifdef MOMENT
8715         if (swap) then
8716           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8717         else
8718           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8719         endif
8720 #endif
8721         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8722 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8723       endif
8724 C Derivatives in gamma(l-1) or gamma(j-1)
8725       if (l.gt.1) then
8726 #ifdef MOMENT
8727         s1=dip(1,jj,i)*dipderg(3,kk,k)
8728 #endif
8729         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8730         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8731         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8732         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8733         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8734         vv(1)=pizda(1,1)-pizda(2,2)
8735         vv(2)=pizda(1,2)+pizda(2,1)
8736         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8737 #ifdef MOMENT
8738         if (swap) then
8739           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8740         else
8741           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8742         endif
8743 #endif
8744         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8745 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8746       endif
8747 C Cartesian derivatives.
8748       if (lprn) then
8749         write (2,*) 'In eello6_graph2'
8750         do iii=1,2
8751           write (2,*) 'iii=',iii
8752           do kkk=1,5
8753             write (2,*) 'kkk=',kkk
8754             do jjj=1,2
8755               write (2,'(3(2f10.5),5x)')
8756      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8757             enddo
8758           enddo
8759         enddo
8760       endif
8761       do iii=1,2
8762         do kkk=1,5
8763           do lll=1,3
8764 #ifdef MOMENT
8765             if (iii.eq.1) then
8766               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8767             else
8768               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8769             endif
8770 #endif
8771             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8772      &        auxvec(1))
8773             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8774             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8775      &        auxvec(1))
8776             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8777             call transpose2(EUg(1,1,k),auxmat(1,1))
8778             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8779      &        pizda(1,1))
8780             vv(1)=pizda(1,1)-pizda(2,2)
8781             vv(2)=pizda(1,2)+pizda(2,1)
8782             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8783 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8784 #ifdef MOMENT
8785             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8786 #else
8787             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8788 #endif
8789             if (swap) then
8790               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8791             else
8792               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8793             endif
8794           enddo
8795         enddo
8796       enddo
8797       return
8798       end
8799 c----------------------------------------------------------------------------
8800       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8801       implicit real*8 (a-h,o-z)
8802       include 'DIMENSIONS'
8803       include 'COMMON.IOUNITS'
8804       include 'COMMON.CHAIN'
8805       include 'COMMON.DERIV'
8806       include 'COMMON.INTERACT'
8807       include 'COMMON.CONTACTS'
8808       include 'COMMON.TORSION'
8809       include 'COMMON.VAR'
8810       include 'COMMON.GEO'
8811       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8812       logical swap
8813 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8814 C                                                                              C
8815 C      Parallel       Antiparallel                                             C
8816 C                                                                              C
8817 C          o             o                                                     C
8818 C         /l\   /   \   /j\                                                    C
8819 C        /   \ /     \ /   \                                                   C
8820 C       /| o |o       o| o |\                                                  C
8821 C       j|/k\|  /      |/k\|l /                                                C
8822 C        /   \ /       /   \ /                                                 C
8823 C       /     o       /     o                                                  C
8824 C       i             i                                                        C
8825 C                                                                              C
8826 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8827 C
8828 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8829 C           energy moment and not to the cluster cumulant.
8830       iti=itortyp(itype(i))
8831       if (j.lt.nres-1) then
8832         itj1=itortyp(itype(j+1))
8833       else
8834         itj1=ntortyp
8835       endif
8836       itk=itortyp(itype(k))
8837       itk1=itortyp(itype(k+1))
8838       if (l.lt.nres-1) then
8839         itl1=itortyp(itype(l+1))
8840       else
8841         itl1=ntortyp
8842       endif
8843 #ifdef MOMENT
8844       s1=dip(4,jj,i)*dip(4,kk,k)
8845 #endif
8846       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8847       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8848       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8849       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8850       call transpose2(EE(1,1,itk),auxmat(1,1))
8851       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8852       vv(1)=pizda(1,1)+pizda(2,2)
8853       vv(2)=pizda(2,1)-pizda(1,2)
8854       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8855 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8856 cd     & "sum",-(s2+s3+s4)
8857 #ifdef MOMENT
8858       eello6_graph3=-(s1+s2+s3+s4)
8859 #else
8860       eello6_graph3=-(s2+s3+s4)
8861 #endif
8862 c      eello6_graph3=-s4
8863 C Derivatives in gamma(k-1)
8864       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8865       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8866       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8867       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8868 C Derivatives in gamma(l-1)
8869       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8870       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8871       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8872       vv(1)=pizda(1,1)+pizda(2,2)
8873       vv(2)=pizda(2,1)-pizda(1,2)
8874       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8875       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8876 C Cartesian derivatives.
8877       do iii=1,2
8878         do kkk=1,5
8879           do lll=1,3
8880 #ifdef MOMENT
8881             if (iii.eq.1) then
8882               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8883             else
8884               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8885             endif
8886 #endif
8887             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8888      &        auxvec(1))
8889             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8890             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8891      &        auxvec(1))
8892             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8893             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8894      &        pizda(1,1))
8895             vv(1)=pizda(1,1)+pizda(2,2)
8896             vv(2)=pizda(2,1)-pizda(1,2)
8897             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8898 #ifdef MOMENT
8899             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8900 #else
8901             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8902 #endif
8903             if (swap) then
8904               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8905             else
8906               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8907             endif
8908 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8909           enddo
8910         enddo
8911       enddo
8912       return
8913       end
8914 c----------------------------------------------------------------------------
8915       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8916       implicit real*8 (a-h,o-z)
8917       include 'DIMENSIONS'
8918       include 'COMMON.IOUNITS'
8919       include 'COMMON.CHAIN'
8920       include 'COMMON.DERIV'
8921       include 'COMMON.INTERACT'
8922       include 'COMMON.CONTACTS'
8923       include 'COMMON.TORSION'
8924       include 'COMMON.VAR'
8925       include 'COMMON.GEO'
8926       include 'COMMON.FFIELD'
8927       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8928      & auxvec1(2),auxmat1(2,2)
8929       logical swap
8930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8931 C                                                                              C
8932 C      Parallel       Antiparallel                                             C
8933 C                                                                              C
8934 C          o             o                                                     C
8935 C         /l\   /   \   /j\                                                    C
8936 C        /   \ /     \ /   \                                                   C
8937 C       /| o |o       o| o |\                                                  C
8938 C     \ j|/k\|      \  |/k\|l                                                  C
8939 C      \ /   \       \ /   \                                                   C
8940 C       o     \       o     \                                                  C
8941 C       i             i                                                        C
8942 C                                                                              C
8943 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8944 C
8945 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8946 C           energy moment and not to the cluster cumulant.
8947 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8948       iti=itortyp(itype(i))
8949       itj=itortyp(itype(j))
8950       if (j.lt.nres-1) then
8951         itj1=itortyp(itype(j+1))
8952       else
8953         itj1=ntortyp
8954       endif
8955       itk=itortyp(itype(k))
8956       if (k.lt.nres-1) then
8957         itk1=itortyp(itype(k+1))
8958       else
8959         itk1=ntortyp
8960       endif
8961       itl=itortyp(itype(l))
8962       if (l.lt.nres-1) then
8963         itl1=itortyp(itype(l+1))
8964       else
8965         itl1=ntortyp
8966       endif
8967 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8968 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8969 cd     & ' itl',itl,' itl1',itl1
8970 #ifdef MOMENT
8971       if (imat.eq.1) then
8972         s1=dip(3,jj,i)*dip(3,kk,k)
8973       else
8974         s1=dip(2,jj,j)*dip(2,kk,l)
8975       endif
8976 #endif
8977       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8978       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8979       if (j.eq.l+1) then
8980         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8981         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8982       else
8983         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8984         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8985       endif
8986       call transpose2(EUg(1,1,k),auxmat(1,1))
8987       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8988       vv(1)=pizda(1,1)-pizda(2,2)
8989       vv(2)=pizda(2,1)+pizda(1,2)
8990       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8991 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8992 #ifdef MOMENT
8993       eello6_graph4=-(s1+s2+s3+s4)
8994 #else
8995       eello6_graph4=-(s2+s3+s4)
8996 #endif
8997 C Derivatives in gamma(i-1)
8998       if (i.gt.1) then
8999 #ifdef MOMENT
9000         if (imat.eq.1) then
9001           s1=dipderg(2,jj,i)*dip(3,kk,k)
9002         else
9003           s1=dipderg(4,jj,j)*dip(2,kk,l)
9004         endif
9005 #endif
9006         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9007         if (j.eq.l+1) then
9008           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9009           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9010         else
9011           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9012           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9013         endif
9014         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9015         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9016 cd          write (2,*) 'turn6 derivatives'
9017 #ifdef MOMENT
9018           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9019 #else
9020           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9021 #endif
9022         else
9023 #ifdef MOMENT
9024           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9025 #else
9026           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9027 #endif
9028         endif
9029       endif
9030 C Derivatives in gamma(k-1)
9031 #ifdef MOMENT
9032       if (imat.eq.1) then
9033         s1=dip(3,jj,i)*dipderg(2,kk,k)
9034       else
9035         s1=dip(2,jj,j)*dipderg(4,kk,l)
9036       endif
9037 #endif
9038       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9039       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9040       if (j.eq.l+1) then
9041         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9042         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9043       else
9044         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9045         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9046       endif
9047       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9048       call matmat2(AECA(1,1,imat),auxmat1(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       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9053 #ifdef MOMENT
9054         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9055 #else
9056         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9057 #endif
9058       else
9059 #ifdef MOMENT
9060         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9061 #else
9062         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9063 #endif
9064       endif
9065 C Derivatives in gamma(j-1) or gamma(l-1)
9066       if (l.eq.j+1 .and. l.gt.1) then
9067         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9068         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9069         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9070         vv(1)=pizda(1,1)-pizda(2,2)
9071         vv(2)=pizda(2,1)+pizda(1,2)
9072         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9073         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9074       else if (j.gt.1) then
9075         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9076         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9077         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9078         vv(1)=pizda(1,1)-pizda(2,2)
9079         vv(2)=pizda(2,1)+pizda(1,2)
9080         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9081         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9082           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9083         else
9084           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9085         endif
9086       endif
9087 C Cartesian derivatives.
9088       do iii=1,2
9089         do kkk=1,5
9090           do lll=1,3
9091 #ifdef MOMENT
9092             if (iii.eq.1) then
9093               if (imat.eq.1) then
9094                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9095               else
9096                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9097               endif
9098             else
9099               if (imat.eq.1) then
9100                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9101               else
9102                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9103               endif
9104             endif
9105 #endif
9106             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9107      &        auxvec(1))
9108             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9109             if (j.eq.l+1) then
9110               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9111      &          b1(1,itj1),auxvec(1))
9112               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9113             else
9114               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9115      &          b1(1,itl1),auxvec(1))
9116               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9117             endif
9118             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9119      &        pizda(1,1))
9120             vv(1)=pizda(1,1)-pizda(2,2)
9121             vv(2)=pizda(2,1)+pizda(1,2)
9122             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9123             if (swap) then
9124               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9125 #ifdef MOMENT
9126                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9127      &             -(s1+s2+s4)
9128 #else
9129                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9130      &             -(s2+s4)
9131 #endif
9132                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9133               else
9134 #ifdef MOMENT
9135                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9136 #else
9137                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9138 #endif
9139                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9140               endif
9141             else
9142 #ifdef MOMENT
9143               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9144 #else
9145               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9146 #endif
9147               if (l.eq.j+1) then
9148                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9149               else
9150                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9151               endif
9152             endif
9153           enddo
9154         enddo
9155       enddo
9156       return
9157       end
9158 c----------------------------------------------------------------------------
9159       double precision function eello_turn6(i,jj,kk)
9160       implicit real*8 (a-h,o-z)
9161       include 'DIMENSIONS'
9162       include 'COMMON.IOUNITS'
9163       include 'COMMON.CHAIN'
9164       include 'COMMON.DERIV'
9165       include 'COMMON.INTERACT'
9166       include 'COMMON.CONTACTS'
9167       include 'COMMON.TORSION'
9168       include 'COMMON.VAR'
9169       include 'COMMON.GEO'
9170       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9171      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9172      &  ggg1(3),ggg2(3)
9173       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9174      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9175 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9176 C           the respective energy moment and not to the cluster cumulant.
9177       s1=0.0d0
9178       s8=0.0d0
9179       s13=0.0d0
9180 c
9181       eello_turn6=0.0d0
9182       j=i+4
9183       k=i+1
9184       l=i+3
9185       iti=itortyp(itype(i))
9186       itk=itortyp(itype(k))
9187       itk1=itortyp(itype(k+1))
9188       itl=itortyp(itype(l))
9189       itj=itortyp(itype(j))
9190 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9191 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9192 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9193 cd        eello6=0.0d0
9194 cd        return
9195 cd      endif
9196 cd      write (iout,*)
9197 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9198 cd     &   ' and',k,l
9199 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9200       do iii=1,2
9201         do kkk=1,5
9202           do lll=1,3
9203             derx_turn(lll,kkk,iii)=0.0d0
9204           enddo
9205         enddo
9206       enddo
9207 cd      eij=1.0d0
9208 cd      ekl=1.0d0
9209 cd      ekont=1.0d0
9210       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9211 cd      eello6_5=0.0d0
9212 cd      write (2,*) 'eello6_5',eello6_5
9213 #ifdef MOMENT
9214       call transpose2(AEA(1,1,1),auxmat(1,1))
9215       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9216       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9217       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9218 #endif
9219       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9220       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9221       s2 = scalar2(b1(1,itk),vtemp1(1))
9222 #ifdef MOMENT
9223       call transpose2(AEA(1,1,2),atemp(1,1))
9224       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9225       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9226       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9227 #endif
9228       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9229       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9230       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9231 #ifdef MOMENT
9232       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9233       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9234       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9235       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9236       ss13 = scalar2(b1(1,itk),vtemp4(1))
9237       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9238 #endif
9239 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9240 c      s1=0.0d0
9241 c      s2=0.0d0
9242 c      s8=0.0d0
9243 c      s12=0.0d0
9244 c      s13=0.0d0
9245       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9246 C Derivatives in gamma(i+2)
9247       s1d =0.0d0
9248       s8d =0.0d0
9249 #ifdef MOMENT
9250       call transpose2(AEA(1,1,1),auxmatd(1,1))
9251       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9252       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9253       call transpose2(AEAderg(1,1,2),atempd(1,1))
9254       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9255       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9256 #endif
9257       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9258       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9259       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9260 c      s1d=0.0d0
9261 c      s2d=0.0d0
9262 c      s8d=0.0d0
9263 c      s12d=0.0d0
9264 c      s13d=0.0d0
9265       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9266 C Derivatives in gamma(i+3)
9267 #ifdef MOMENT
9268       call transpose2(AEA(1,1,1),auxmatd(1,1))
9269       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9270       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9271       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9272 #endif
9273       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9274       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9275       s2d = scalar2(b1(1,itk),vtemp1d(1))
9276 #ifdef MOMENT
9277       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9278       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9279 #endif
9280       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9281 #ifdef MOMENT
9282       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9283       call matmat2(gtempd(1,1),EUg(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+1)=gel_loc_turn6(i+1)
9293      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9294 #else
9295       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9296      &               -0.5d0*ekont*(s2d+s12d)
9297 #endif
9298 C Derivatives in gamma(i+4)
9299       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9300       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9301       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9302 #ifdef MOMENT
9303       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9304       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9305       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9306 #endif
9307 c      s1d=0.0d0
9308 c      s2d=0.0d0
9309 c      s8d=0.0d0
9310 C      s12d=0.0d0
9311 c      s13d=0.0d0
9312 #ifdef MOMENT
9313       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9314 #else
9315       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9316 #endif
9317 C Derivatives in gamma(i+5)
9318 #ifdef MOMENT
9319       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9320       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9321       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9322 #endif
9323       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9324       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9325       s2d = scalar2(b1(1,itk),vtemp1d(1))
9326 #ifdef MOMENT
9327       call transpose2(AEA(1,1,2),atempd(1,1))
9328       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9329       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9330 #endif
9331       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9332       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9333 #ifdef MOMENT
9334       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9335       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9336       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9337 #endif
9338 c      s1d=0.0d0
9339 c      s2d=0.0d0
9340 c      s8d=0.0d0
9341 c      s12d=0.0d0
9342 c      s13d=0.0d0
9343 #ifdef MOMENT
9344       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9345      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9346 #else
9347       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9348      &               -0.5d0*ekont*(s2d+s12d)
9349 #endif
9350 C Cartesian derivatives
9351       do iii=1,2
9352         do kkk=1,5
9353           do lll=1,3
9354 #ifdef MOMENT
9355             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9356             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9357             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9358 #endif
9359             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9360             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9361      &          vtemp1d(1))
9362             s2d = scalar2(b1(1,itk),vtemp1d(1))
9363 #ifdef MOMENT
9364             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9365             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9366             s8d = -(atempd(1,1)+atempd(2,2))*
9367      &           scalar2(cc(1,1,itl),vtemp2(1))
9368 #endif
9369             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9370      &           auxmatd(1,1))
9371             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9372             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9373 c      s1d=0.0d0
9374 c      s2d=0.0d0
9375 c      s8d=0.0d0
9376 c      s12d=0.0d0
9377 c      s13d=0.0d0
9378 #ifdef MOMENT
9379             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9380      &        - 0.5d0*(s1d+s2d)
9381 #else
9382             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9383      &        - 0.5d0*s2d
9384 #endif
9385 #ifdef MOMENT
9386             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9387      &        - 0.5d0*(s8d+s12d)
9388 #else
9389             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9390      &        - 0.5d0*s12d
9391 #endif
9392           enddo
9393         enddo
9394       enddo
9395 #ifdef MOMENT
9396       do kkk=1,5
9397         do lll=1,3
9398           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9399      &      achuj_tempd(1,1))
9400           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9401           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9402           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9403           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9404           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9405      &      vtemp4d(1))
9406           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9407           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9408           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9409         enddo
9410       enddo
9411 #endif
9412 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9413 cd     &  16*eel_turn6_num
9414 cd      goto 1112
9415       if (j.lt.nres-1) then
9416         j1=j+1
9417         j2=j-1
9418       else
9419         j1=j-1
9420         j2=j-2
9421       endif
9422       if (l.lt.nres-1) then
9423         l1=l+1
9424         l2=l-1
9425       else
9426         l1=l-1
9427         l2=l-2
9428       endif
9429       do ll=1,3
9430 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9431 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9432 cgrad        ghalf=0.5d0*ggg1(ll)
9433 cd        ghalf=0.0d0
9434         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9435         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9436         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9437      &    +ekont*derx_turn(ll,2,1)
9438         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9439         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9440      &    +ekont*derx_turn(ll,4,1)
9441         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9442         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9443         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9444 cgrad        ghalf=0.5d0*ggg2(ll)
9445 cd        ghalf=0.0d0
9446         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9447      &    +ekont*derx_turn(ll,2,2)
9448         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9449         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9450      &    +ekont*derx_turn(ll,4,2)
9451         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9452         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9453         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9454       enddo
9455 cd      goto 1112
9456 cgrad      do m=i+1,j-1
9457 cgrad        do ll=1,3
9458 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9459 cgrad        enddo
9460 cgrad      enddo
9461 cgrad      do m=k+1,l-1
9462 cgrad        do ll=1,3
9463 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9464 cgrad        enddo
9465 cgrad      enddo
9466 cgrad1112  continue
9467 cgrad      do m=i+2,j2
9468 cgrad        do ll=1,3
9469 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9470 cgrad        enddo
9471 cgrad      enddo
9472 cgrad      do m=k+2,l2
9473 cgrad        do ll=1,3
9474 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9475 cgrad        enddo
9476 cgrad      enddo
9477 cd      do iii=1,nres-3
9478 cd        write (2,*) iii,g_corr6_loc(iii)
9479 cd      enddo
9480       eello_turn6=ekont*eel_turn6
9481 cd      write (2,*) 'ekont',ekont
9482 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9483       return
9484       end
9485
9486 C-----------------------------------------------------------------------------
9487       double precision function scalar(u,v)
9488 !DIR$ INLINEALWAYS scalar
9489 #ifndef OSF
9490 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9491 #endif
9492       implicit none
9493       double precision u(3),v(3)
9494 cd      double precision sc
9495 cd      integer i
9496 cd      sc=0.0d0
9497 cd      do i=1,3
9498 cd        sc=sc+u(i)*v(i)
9499 cd      enddo
9500 cd      scalar=sc
9501
9502       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9503       return
9504       end
9505 crc-------------------------------------------------
9506       SUBROUTINE MATVEC2(A1,V1,V2)
9507 !DIR$ INLINEALWAYS MATVEC2
9508 #ifndef OSF
9509 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9510 #endif
9511       implicit real*8 (a-h,o-z)
9512       include 'DIMENSIONS'
9513       DIMENSION A1(2,2),V1(2),V2(2)
9514 c      DO 1 I=1,2
9515 c        VI=0.0
9516 c        DO 3 K=1,2
9517 c    3     VI=VI+A1(I,K)*V1(K)
9518 c        Vaux(I)=VI
9519 c    1 CONTINUE
9520
9521       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9522       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9523
9524       v2(1)=vaux1
9525       v2(2)=vaux2
9526       END
9527 C---------------------------------------
9528       SUBROUTINE MATMAT2(A1,A2,A3)
9529 #ifndef OSF
9530 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9531 #endif
9532       implicit real*8 (a-h,o-z)
9533       include 'DIMENSIONS'
9534       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9535 c      DIMENSION AI3(2,2)
9536 c        DO  J=1,2
9537 c          A3IJ=0.0
9538 c          DO K=1,2
9539 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9540 c          enddo
9541 c          A3(I,J)=A3IJ
9542 c       enddo
9543 c      enddo
9544
9545       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9546       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9547       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9548       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9549
9550       A3(1,1)=AI3_11
9551       A3(2,1)=AI3_21
9552       A3(1,2)=AI3_12
9553       A3(2,2)=AI3_22
9554       END
9555
9556 c-------------------------------------------------------------------------
9557       double precision function scalar2(u,v)
9558 !DIR$ INLINEALWAYS scalar2
9559       implicit none
9560       double precision u(2),v(2)
9561       double precision sc
9562       integer i
9563       scalar2=u(1)*v(1)+u(2)*v(2)
9564       return
9565       end
9566
9567 C-----------------------------------------------------------------------------
9568
9569       subroutine transpose2(a,at)
9570 !DIR$ INLINEALWAYS transpose2
9571 #ifndef OSF
9572 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9573 #endif
9574       implicit none
9575       double precision a(2,2),at(2,2)
9576       at(1,1)=a(1,1)
9577       at(1,2)=a(2,1)
9578       at(2,1)=a(1,2)
9579       at(2,2)=a(2,2)
9580       return
9581       end
9582 c--------------------------------------------------------------------------
9583       subroutine transpose(n,a,at)
9584       implicit none
9585       integer n,i,j
9586       double precision a(n,n),at(n,n)
9587       do i=1,n
9588         do j=1,n
9589           at(j,i)=a(i,j)
9590         enddo
9591       enddo
9592       return
9593       end
9594 C---------------------------------------------------------------------------
9595       subroutine prodmat3(a1,a2,kk,transp,prod)
9596 !DIR$ INLINEALWAYS prodmat3
9597 #ifndef OSF
9598 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9599 #endif
9600       implicit none
9601       integer i,j
9602       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9603       logical transp
9604 crc      double precision auxmat(2,2),prod_(2,2)
9605
9606       if (transp) then
9607 crc        call transpose2(kk(1,1),auxmat(1,1))
9608 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9609 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9610
9611            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9612      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9613            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9614      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9615            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9616      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9617            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9618      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9619
9620       else
9621 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9622 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9623
9624            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9625      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9626            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9627      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9628            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9629      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9630            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9631      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9632
9633       endif
9634 c      call transpose2(a2(1,1),a2t(1,1))
9635
9636 crc      print *,transp
9637 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9638 crc      print *,((prod(i,j),i=1,2),j=1,2)
9639
9640       return
9641       end
9642