source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 #ifdef TIMING
 265       time_enecalc=time_enecalc+MPI_Wtime()-time00
 266 #endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 #ifdef TIMING
 269       time00=MPI_Wtime()
 270 #endif
 271 c
 272 C Sum the energies
 273 C
 274       energia(1)=evdw
 275 #ifdef SCP14
 276       energia(2)=evdw2-evdw2_14
 277       energia(18)=evdw2_14
 278 #else
 279       energia(2)=evdw2
 280       energia(18)=0.0d0
 281 #endif
 282 #ifdef SPLITELE
 283       energia(3)=ees
 284       energia(16)=evdw1
 285 #else
 286       energia(3)=ees+evdw1
 287       energia(16)=0.0d0
 288 #endif
 289       energia(4)=ecorr
 290       energia(5)=ecorr5
 291       energia(6)=ecorr6
 292       energia(7)=eel_loc
 293       energia(8)=eello_turn3
 294       energia(9)=eello_turn4
 295       energia(10)=eturn6
 296       energia(11)=ebe
 297       energia(12)=escloc
 298       energia(13)=etors
 299       energia(14)=etors_d
 300       energia(15)=ehpb
 301       energia(19)=edihcnstr
 302       energia(17)=estr
 303       energia(20)=Uconst+Uconst_back
 304       energia(21)=esccor
 305 c    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445 #endif
 446       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 447      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,ebr*nss,
 982      &  Uconst,etot
 983    10 format (/'Virtual-chain energies:'//
 984      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 985      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 986      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 987      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #else
1008       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1009      &  estr,wbond,ebe,wang,
1010      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1011      &  ecorr,wcorr,
1012      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1013      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1014      &  ebr*nss,Uconst,etot
1015    10 format (/'Virtual-chain energies:'//
1016      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1017      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1018      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1019      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1020      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1021      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1022      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1023      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1024      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1025      & ' (SS bridges & dist. cnstr.)'/
1026      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1030      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1031      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1032      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1033      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1034      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1035      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1036      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1037      & 'ETOT=  ',1pE16.6,' (total)')
1038 #endif
1039       return
1040       end
1041 C-----------------------------------------------------------------------
1042       subroutine elj(evdw)
1043 C
1044 C This subroutine calculates the interaction energy of nonbonded side chains
1045 C assuming the LJ potential of interaction.
1046 C
1047       implicit real*8 (a-h,o-z)
1048       include 'DIMENSIONS'
1049       parameter (accur=1.0d-10)
1050       include 'COMMON.GEO'
1051       include 'COMMON.VAR'
1052       include 'COMMON.LOCAL'
1053       include 'COMMON.CHAIN'
1054       include 'COMMON.DERIV'
1055       include 'COMMON.INTERACT'
1056       include 'COMMON.TORSION'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.NAMES'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.CONTACTS'
1061       dimension gg(3)
1062 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1063       evdw=0.0D0
1064       do i=iatsc_s,iatsc_e
1065         itypi=iabs(itype(i))
1066         if (itypi.eq.ntyp1) cycle
1067         itypi1=iabs(itype(i+1))
1068         xi=c(1,nres+i)
1069         yi=c(2,nres+i)
1070         zi=c(3,nres+i)
1071 C Change 12/1/95
1072         num_conti=0
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1078 cd   &                  'iend=',iend(i,iint)
1079           do j=istart(i,iint),iend(i,iint)
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             xj=c(1,nres+j)-xi
1083             yj=c(2,nres+j)-yi
1084             zj=c(3,nres+j)-zi
1085 C Change 12/1/95 to calculate four-body interactions
1086             rij=xj*xj+yj*yj+zj*zj
1087             rrij=1.0D0/rij
1088 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1089             eps0ij=eps(itypi,itypj)
1090             fac=rrij**expon2
1091             e1=fac*fac*aa(itypi,itypj)
1092             e2=fac*bb(itypi,itypj)
1093             evdwij=e1+e2
1094 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1097 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1098 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1099 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1100             evdw=evdw+evdwij
1101 C
1102 C Calculate the components of the gradient in DC and X
1103 C
1104             fac=-rrij*(e1+evdwij)
1105             gg(1)=xj*fac
1106             gg(2)=yj*fac
1107             gg(3)=zj*fac
1108             do k=1,3
1109               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1110               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1111               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1112               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1113             enddo
1114 cgrad            do k=i,j-1
1115 cgrad              do l=1,3
1116 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1117 cgrad              enddo
1118 cgrad            enddo
1119 C
1120 C 12/1/95, revised on 5/20/97
1121 C
1122 C Calculate the contact function. The ith column of the array JCONT will
1123 C contain the numbers of atoms that make contacts with the atom I (of numbers
1124 C greater than I). The arrays FACONT and GACONT will contain the values of
1125 C the contact function and its derivative.
1126 C
1127 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1128 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1129 C Uncomment next line, if the correlation interactions are contact function only
1130             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1131               rij=dsqrt(rij)
1132               sigij=sigma(itypi,itypj)
1133               r0ij=rs0(itypi,itypj)
1134 C
1135 C Check whether the SC's are not too far to make a contact.
1136 C
1137               rcut=1.5d0*r0ij
1138               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1139 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1140 C
1141               if (fcont.gt.0.0D0) then
1142 C If the SC-SC distance if close to sigma, apply spline.
1143 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1144 cAdam &             fcont1,fprimcont1)
1145 cAdam           fcont1=1.0d0-fcont1
1146 cAdam           if (fcont1.gt.0.0d0) then
1147 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1148 cAdam             fcont=fcont*fcont1
1149 cAdam           endif
1150 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1151 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1152 cga             do k=1,3
1153 cga               gg(k)=gg(k)*eps0ij
1154 cga             enddo
1155 cga             eps0ij=-evdwij*eps0ij
1156 C Uncomment for AL's type of SC correlation interactions.
1157 cadam           eps0ij=-evdwij
1158                 num_conti=num_conti+1
1159                 jcont(num_conti,i)=j
1160                 facont(num_conti,i)=fcont*eps0ij
1161                 fprimcont=eps0ij*fprimcont/rij
1162                 fcont=expon*fcont
1163 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1164 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1165 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1166 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1167                 gacont(1,num_conti,i)=-fprimcont*xj
1168                 gacont(2,num_conti,i)=-fprimcont*yj
1169                 gacont(3,num_conti,i)=-fprimcont*zj
1170 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1171 cd              write (iout,'(2i3,3f10.5)')
1172 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1173               endif
1174             endif
1175           enddo      ! j
1176         enddo        ! iint
1177 C Change 12/1/95
1178         num_cont(i)=num_conti
1179       enddo          ! i
1180       do i=1,nct
1181         do j=1,3
1182           gvdwc(j,i)=expon*gvdwc(j,i)
1183           gvdwx(j,i)=expon*gvdwx(j,i)
1184         enddo
1185       enddo
1186 C******************************************************************************
1187 C
1188 C                              N O T E !!!
1189 C
1190 C To save time, the factor of EXPON has been extracted from ALL components
1191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1192 C use!
1193 C
1194 C******************************************************************************
1195       return
1196       end
1197 C-----------------------------------------------------------------------------
1198       subroutine eljk(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJK potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       include 'COMMON.GEO'
1206       include 'COMMON.VAR'
1207       include 'COMMON.LOCAL'
1208       include 'COMMON.CHAIN'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       include 'COMMON.IOUNITS'
1212       include 'COMMON.NAMES'
1213       dimension gg(3)
1214       logical scheck
1215 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1216       evdw=0.0D0
1217       do i=iatsc_s,iatsc_e
1218         itypi=iabs(itype(i))
1219         if (itypi.eq.ntyp1) cycle
1220         itypi1=iabs(itype(i+1))
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224 C
1225 C Calculate SC interaction energy.
1226 C
1227         do iint=1,nint_gr(i)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             fac_augm=rrij**expon
1236             e_augm=augm(itypi,itypj)*fac_augm
1237             r_inv_ij=dsqrt(rrij)
1238             rij=1.0D0/r_inv_ij
1239             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1240             fac=r_shift_inv**expon
1241             e1=fac*fac*aa(itypi,itypj)
1242             e2=fac*bb(itypi,itypj)
1243             evdwij=e_augm+e1+e2
1244 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1245 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1246 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1247 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1248 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1249 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1250 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1251             evdw=evdw+evdwij
1252 C
1253 C Calculate the components of the gradient in DC and X
1254 C
1255             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1256             gg(1)=xj*fac
1257             gg(2)=yj*fac
1258             gg(3)=zj*fac
1259             do k=1,3
1260               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1261               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1262               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1263               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1264             enddo
1265 cgrad            do k=i,j-1
1266 cgrad              do l=1,3
1267 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1268 cgrad              enddo
1269 cgrad            enddo
1270           enddo      ! j
1271         enddo        ! iint
1272       enddo          ! i
1273       do i=1,nct
1274         do j=1,3
1275           gvdwc(j,i)=expon*gvdwc(j,i)
1276           gvdwx(j,i)=expon*gvdwx(j,i)
1277         enddo
1278       enddo
1279       return
1280       end
1281 C-----------------------------------------------------------------------------
1282       subroutine ebp(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the Berne-Pechukas potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       include 'COMMON.GEO'
1290       include 'COMMON.VAR'
1291       include 'COMMON.LOCAL'
1292       include 'COMMON.CHAIN'
1293       include 'COMMON.DERIV'
1294       include 'COMMON.NAMES'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.CALC'
1298       common /srutu/ icall
1299 c     double precision rrsave(maxdim)
1300       logical lprn
1301       evdw=0.0D0
1302 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304 c     if (icall.eq.0) then
1305 c       lprn=.true.
1306 c     else
1307         lprn=.false.
1308 c     endif
1309       ind=0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317         dxi=dc_norm(1,nres+i)
1318         dyi=dc_norm(2,nres+i)
1319         dzi=dc_norm(3,nres+i)
1320 c        dsci_inv=dsc_inv(itypi)
1321         dsci_inv=vbld_inv(i+nres)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             ind=ind+1
1328             itypj=iabs(itype(j))
1329             if (itypj.eq.ntyp1) cycle
1330 c            dscj_inv=dsc_inv(itypj)
1331             dscj_inv=vbld_inv(j+nres)
1332             chi1=chi(itypi,itypj)
1333             chi2=chi(itypj,itypi)
1334             chi12=chi1*chi2
1335             chip1=chip(itypi)
1336             chip2=chip(itypj)
1337             chip12=chip1*chip2
1338             alf1=alp(itypi)
1339             alf2=alp(itypj)
1340             alf12=0.5D0*(alf1+alf2)
1341 C For diagnostics only!!!
1342 c           chi1=0.0D0
1343 c           chi2=0.0D0
1344 c           chi12=0.0D0
1345 c           chip1=0.0D0
1346 c           chip2=0.0D0
1347 c           chip12=0.0D0
1348 c           alf1=0.0D0
1349 c           alf2=0.0D0
1350 c           alf12=0.0D0
1351             xj=c(1,nres+j)-xi
1352             yj=c(2,nres+j)-yi
1353             zj=c(3,nres+j)-zi
1354             dxj=dc_norm(1,nres+j)
1355             dyj=dc_norm(2,nres+j)
1356             dzj=dc_norm(3,nres+j)
1357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1358 cd          if (icall.eq.0) then
1359 cd            rrsave(ind)=rrij
1360 cd          else
1361 cd            rrij=rrsave(ind)
1362 cd          endif
1363             rij=dsqrt(rrij)
1364 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1365             call sc_angular
1366 C Calculate whole angle-dependent part of epsilon and contributions
1367 C to its derivatives
1368             fac=(rrij*sigsq)**expon2
1369             e1=fac*fac*aa(itypi,itypj)
1370             e2=fac*bb(itypi,itypj)
1371             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1372             eps2der=evdwij*eps3rt
1373             eps3der=evdwij*eps2rt
1374             evdwij=evdwij*eps2rt*eps3rt
1375             evdw=evdw+evdwij
1376             if (lprn) then
1377             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1378             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1379 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1380 cd     &        restyp(itypi),i,restyp(itypj),j,
1381 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1382 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1383 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1384 cd     &        evdwij
1385             endif
1386 C Calculate gradient components.
1387             e1=e1*eps1*eps2rt**2*eps3rt**2
1388             fac=-expon*(e1+evdwij)
1389             sigder=fac/sigsq
1390             fac=rrij*fac
1391 C Calculate radial part of the gradient
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395 C Calculate the angular part of the gradient and sum add the contributions
1396 C to the appropriate components of the Cartesian gradient.
1397             call sc_grad
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401 c     stop
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine egb(evdw)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Gay-Berne potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       include 'COMMON.CONTROL'
1422       include 'COMMON.SPLITELE'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       integer xshift,yshift,zshift
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1434 C we have the original box)
1435 C      do xshift=-1,1
1436 C      do yshift=-1,1
1437 C      do zshift=-1,1
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445 C Return atom into box, boxxsize is size of box in x dimension
1446 c  134   continue
1447 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1448 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1449 C Condition for being inside the proper box
1450 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1451 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1452 c        go to 134
1453 c        endif
1454 c  135   continue
1455 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1456 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1457 C Condition for being inside the proper box
1458 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1459 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1460 c        go to 135
1461 c        endif
1462 c  136   continue
1463 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1464 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1465 C Condition for being inside the proper box
1466 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1467 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1468 c        go to 136
1469 c        endif
1470           xi=mod(xi,boxxsize)
1471           if (xi.lt.0) xi=xi+boxxsize
1472           yi=mod(yi,boxysize)
1473           if (yi.lt.0) yi=yi+boxysize
1474           zi=mod(zi,boxzsize)
1475           if (zi.lt.0) zi=zi+boxzsize
1476 C          xi=xi+xshift*boxxsize
1477 C          yi=yi+yshift*boxysize
1478 C          zi=zi+zshift*boxzsize
1479
1480         dxi=dc_norm(1,nres+i)
1481         dyi=dc_norm(2,nres+i)
1482         dzi=dc_norm(3,nres+i)
1483 c        dsci_inv=dsc_inv(itypi)
1484         dsci_inv=vbld_inv(i+nres)
1485 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1486 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1487 C
1488 C Calculate SC interaction energy.
1489 C
1490         do iint=1,nint_gr(i)
1491           do j=istart(i,iint),iend(i,iint)
1492             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1493               call dyn_ssbond_ene(i,j,evdwij)
1494               evdw=evdw+evdwij
1495               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1496      &                        'evdw',i,j,evdwij,' ss'
1497             ELSE
1498             ind=ind+1
1499             itypj=iabs(itype(j))
1500             if (itypj.eq.ntyp1) cycle
1501 c            dscj_inv=dsc_inv(itypj)
1502             dscj_inv=vbld_inv(j+nres)
1503 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1504 c     &       1.0d0/vbld(j+nres)
1505 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1506             sig0ij=sigma(itypi,itypj)
1507             chi1=chi(itypi,itypj)
1508             chi2=chi(itypj,itypi)
1509             chi12=chi1*chi2
1510             chip1=chip(itypi)
1511             chip2=chip(itypj)
1512             chip12=chip1*chip2
1513             alf1=alp(itypi)
1514             alf2=alp(itypj)
1515             alf12=0.5D0*(alf1+alf2)
1516 C For diagnostics only!!!
1517 c           chi1=0.0D0
1518 c           chi2=0.0D0
1519 c           chi12=0.0D0
1520 c           chip1=0.0D0
1521 c           chip2=0.0D0
1522 c           chip12=0.0D0
1523 c           alf1=0.0D0
1524 c           alf2=0.0D0
1525 c           alf12=0.0D0
1526             xj=c(1,nres+j)
1527             yj=c(2,nres+j)
1528             zj=c(3,nres+j)
1529 C Return atom J into box the original box
1530 c  137   continue
1531 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1532 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1533 C Condition for being inside the proper box
1534 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1535 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1536 c        go to 137
1537 c        endif
1538 c  138   continue
1539 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1540 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1541 C Condition for being inside the proper box
1542 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1543 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1544 c        go to 138
1545 c        endif
1546 c  139   continue
1547 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1548 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1549 C Condition for being inside the proper box
1550 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1551 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1552 c        go to 139
1553 c        endif
1554           xj=mod(xj,boxxsize)
1555           if (xj.lt.0) xj=xj+boxxsize
1556           yj=mod(yj,boxysize)
1557           if (yj.lt.0) yj=yj+boxysize
1558           zj=mod(zj,boxzsize)
1559           if (zj.lt.0) zj=zj+boxzsize
1560       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1561       xj_safe=xj
1562       yj_safe=yj
1563       zj_safe=zj
1564       subchap=0
1565       do xshift=-1,1
1566       do yshift=-1,1
1567       do zshift=-1,1
1568           xj=xj_safe+xshift*boxxsize
1569           yj=yj_safe+yshift*boxysize
1570           zj=zj_safe+zshift*boxzsize
1571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572           if(dist_temp.lt.dist_init) then
1573             dist_init=dist_temp
1574             xj_temp=xj
1575             yj_temp=yj
1576             zj_temp=zj
1577             subchap=1
1578           endif
1579        enddo
1580        enddo
1581        enddo
1582        if (subchap.eq.1) then
1583           xj=xj_temp-xi
1584           yj=yj_temp-yi
1585           zj=zj_temp-zi
1586        else
1587           xj=xj_safe-xi
1588           yj=yj_safe-yi
1589           zj=zj_safe-zi
1590        endif
1591             dxj=dc_norm(1,nres+j)
1592             dyj=dc_norm(2,nres+j)
1593             dzj=dc_norm(3,nres+j)
1594 C            xj=xj-xi
1595 C            yj=yj-yi
1596 C            zj=zj-zi
1597 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1598 c            write (iout,*) "j",j," dc_norm",
1599 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1600             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1601             rij=dsqrt(rrij)
1602             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1603             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1604
1605 c            write (iout,'(a7,4f8.3)')
1606 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1607             if (sss.gt.0.0d0) then
1608 C Calculate angle-dependent terms of energy and contributions to their
1609 C derivatives.
1610             call sc_angular
1611             sigsq=1.0D0/sigsq
1612             sig=sig0ij*dsqrt(sigsq)
1613             rij_shift=1.0D0/rij-sig+sig0ij
1614 c for diagnostics; uncomment
1615 c            rij_shift=1.2*sig0ij
1616 C I hate to put IF's in the loops, but here don't have another choice!!!!
1617             if (rij_shift.le.0.0D0) then
1618               evdw=1.0D20
1619 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1620 cd     &        restyp(itypi),i,restyp(itypj),j,
1621 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1622               return
1623             endif
1624             sigder=-sig*sigsq
1625 c---------------------------------------------------------------
1626             rij_shift=1.0D0/rij_shift
1627             fac=rij_shift**expon
1628             e1=fac*fac*aa(itypi,itypj)
1629             e2=fac*bb(itypi,itypj)
1630             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1631             eps2der=evdwij*eps3rt
1632             eps3der=evdwij*eps2rt
1633 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1634 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1635             evdwij=evdwij*eps2rt*eps3rt
1636             evdw=evdw+evdwij*sss
1637             if (lprn) then
1638             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1639             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1640             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1641      &        restyp(itypi),i,restyp(itypj),j,
1642      &        epsi,sigm,chi1,chi2,chip1,chip2,
1643      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1644      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1645      &        evdwij
1646             endif
1647
1648             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1649      &                        'evdw',i,j,evdwij
1650
1651 C Calculate gradient components.
1652             e1=e1*eps1*eps2rt**2*eps3rt**2
1653             fac=-expon*(e1+evdwij)*rij_shift
1654             sigder=fac*sigder
1655             fac=rij*fac
1656 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1657 c     &      evdwij,fac,sigma(itypi,itypj),expon
1658             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1659 c            fac=0.0d0
1660 C Calculate the radial part of the gradient
1661             gg(1)=xj*fac
1662             gg(2)=yj*fac
1663             gg(3)=zj*fac
1664 C Calculate angular part of the gradient.
1665             call sc_grad
1666             ENDIF    ! dyn_ss
1667           enddo      ! j
1668         enddo        ! iint
1669       enddo          ! i
1670 C      enddo          ! zshift
1671 C      enddo          ! yshift
1672 C      enddo          ! xshift
1673 c      write (iout,*) "Number of loop steps in EGB:",ind
1674 cccc      energy_dec=.false.
1675       return
1676       end
1677 C-----------------------------------------------------------------------------
1678       subroutine egbv(evdw)
1679 C
1680 C This subroutine calculates the interaction energy of nonbonded side chains
1681 C assuming the Gay-Berne-Vorobjev potential of interaction.
1682 C
1683       implicit real*8 (a-h,o-z)
1684       include 'DIMENSIONS'
1685       include 'COMMON.GEO'
1686       include 'COMMON.VAR'
1687       include 'COMMON.LOCAL'
1688       include 'COMMON.CHAIN'
1689       include 'COMMON.DERIV'
1690       include 'COMMON.NAMES'
1691       include 'COMMON.INTERACT'
1692       include 'COMMON.IOUNITS'
1693       include 'COMMON.CALC'
1694       common /srutu/ icall
1695       logical lprn
1696       evdw=0.0D0
1697 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1698       evdw=0.0D0
1699       lprn=.false.
1700 c     if (icall.eq.0) lprn=.true.
1701       ind=0
1702       do i=iatsc_s,iatsc_e
1703         itypi=iabs(itype(i))
1704         if (itypi.eq.ntyp1) cycle
1705         itypi1=iabs(itype(i+1))
1706         xi=c(1,nres+i)
1707         yi=c(2,nres+i)
1708         zi=c(3,nres+i)
1709         dxi=dc_norm(1,nres+i)
1710         dyi=dc_norm(2,nres+i)
1711         dzi=dc_norm(3,nres+i)
1712 c        dsci_inv=dsc_inv(itypi)
1713         dsci_inv=vbld_inv(i+nres)
1714 C
1715 C Calculate SC interaction energy.
1716 C
1717         do iint=1,nint_gr(i)
1718           do j=istart(i,iint),iend(i,iint)
1719             ind=ind+1
1720             itypj=iabs(itype(j))
1721             if (itypj.eq.ntyp1) cycle
1722 c            dscj_inv=dsc_inv(itypj)
1723             dscj_inv=vbld_inv(j+nres)
1724             sig0ij=sigma(itypi,itypj)
1725             r0ij=r0(itypi,itypj)
1726             chi1=chi(itypi,itypj)
1727             chi2=chi(itypj,itypi)
1728             chi12=chi1*chi2
1729             chip1=chip(itypi)
1730             chip2=chip(itypj)
1731             chip12=chip1*chip2
1732             alf1=alp(itypi)
1733             alf2=alp(itypj)
1734             alf12=0.5D0*(alf1+alf2)
1735 C For diagnostics only!!!
1736 c           chi1=0.0D0
1737 c           chi2=0.0D0
1738 c           chi12=0.0D0
1739 c           chip1=0.0D0
1740 c           chip2=0.0D0
1741 c           chip12=0.0D0
1742 c           alf1=0.0D0
1743 c           alf2=0.0D0
1744 c           alf12=0.0D0
1745             xj=c(1,nres+j)-xi
1746             yj=c(2,nres+j)-yi
1747             zj=c(3,nres+j)-zi
1748             dxj=dc_norm(1,nres+j)
1749             dyj=dc_norm(2,nres+j)
1750             dzj=dc_norm(3,nres+j)
1751             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1752             rij=dsqrt(rrij)
1753 C Calculate angle-dependent terms of energy and contributions to their
1754 C derivatives.
1755             call sc_angular
1756             sigsq=1.0D0/sigsq
1757             sig=sig0ij*dsqrt(sigsq)
1758             rij_shift=1.0D0/rij-sig+r0ij
1759 C I hate to put IF's in the loops, but here don't have another choice!!!!
1760             if (rij_shift.le.0.0D0) then
1761               evdw=1.0D20
1762               return
1763             endif
1764             sigder=-sig*sigsq
1765 c---------------------------------------------------------------
1766             rij_shift=1.0D0/rij_shift
1767             fac=rij_shift**expon
1768             e1=fac*fac*aa(itypi,itypj)
1769             e2=fac*bb(itypi,itypj)
1770             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1771             eps2der=evdwij*eps3rt
1772             eps3der=evdwij*eps2rt
1773             fac_augm=rrij**expon
1774             e_augm=augm(itypi,itypj)*fac_augm
1775             evdwij=evdwij*eps2rt*eps3rt
1776             evdw=evdw+evdwij+e_augm
1777             if (lprn) then
1778             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1779             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1780             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1781      &        restyp(itypi),i,restyp(itypj),j,
1782      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1783      &        chi1,chi2,chip1,chip2,
1784      &        eps1,eps2rt**2,eps3rt**2,
1785      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1786      &        evdwij+e_augm
1787             endif
1788 C Calculate gradient components.
1789             e1=e1*eps1*eps2rt**2*eps3rt**2
1790             fac=-expon*(e1+evdwij)*rij_shift
1791             sigder=fac*sigder
1792             fac=rij*fac-2*expon*rrij*e_augm
1793 C Calculate the radial part of the gradient
1794             gg(1)=xj*fac
1795             gg(2)=yj*fac
1796             gg(3)=zj*fac
1797 C Calculate angular part of the gradient.
1798             call sc_grad
1799           enddo      ! j
1800         enddo        ! iint
1801       enddo          ! i
1802       end
1803 C-----------------------------------------------------------------------------
1804       subroutine sc_angular
1805 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1806 C om12. Called by ebp, egb, and egbv.
1807       implicit none
1808       include 'COMMON.CALC'
1809       include 'COMMON.IOUNITS'
1810       erij(1)=xj*rij
1811       erij(2)=yj*rij
1812       erij(3)=zj*rij
1813       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1814       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1815       om12=dxi*dxj+dyi*dyj+dzi*dzj
1816       chiom12=chi12*om12
1817 C Calculate eps1(om12) and its derivative in om12
1818       faceps1=1.0D0-om12*chiom12
1819       faceps1_inv=1.0D0/faceps1
1820       eps1=dsqrt(faceps1_inv)
1821 C Following variable is eps1*deps1/dom12
1822       eps1_om12=faceps1_inv*chiom12
1823 c diagnostics only
1824 c      faceps1_inv=om12
1825 c      eps1=om12
1826 c      eps1_om12=1.0d0
1827 c      write (iout,*) "om12",om12," eps1",eps1
1828 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1829 C and om12.
1830       om1om2=om1*om2
1831       chiom1=chi1*om1
1832       chiom2=chi2*om2
1833       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1834       sigsq=1.0D0-facsig*faceps1_inv
1835       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1836       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1837       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1838 c diagnostics only
1839 c      sigsq=1.0d0
1840 c      sigsq_om1=0.0d0
1841 c      sigsq_om2=0.0d0
1842 c      sigsq_om12=0.0d0
1843 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1844 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1845 c     &    " eps1",eps1
1846 C Calculate eps2 and its derivatives in om1, om2, and om12.
1847       chipom1=chip1*om1
1848       chipom2=chip2*om2
1849       chipom12=chip12*om12
1850       facp=1.0D0-om12*chipom12
1851       facp_inv=1.0D0/facp
1852       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1853 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1854 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1855 C Following variable is the square root of eps2
1856       eps2rt=1.0D0-facp1*facp_inv
1857 C Following three variables are the derivatives of the square root of eps
1858 C in om1, om2, and om12.
1859       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1860       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1861       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1862 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1863       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1864 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1865 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1866 c     &  " eps2rt_om12",eps2rt_om12
1867 C Calculate whole angle-dependent part of epsilon and contributions
1868 C to its derivatives
1869       return
1870       end
1871 C----------------------------------------------------------------------------
1872       subroutine sc_grad
1873       implicit real*8 (a-h,o-z)
1874       include 'DIMENSIONS'
1875       include 'COMMON.CHAIN'
1876       include 'COMMON.DERIV'
1877       include 'COMMON.CALC'
1878       include 'COMMON.IOUNITS'
1879       double precision dcosom1(3),dcosom2(3)
1880 cc      print *,'sss=',sss
1881       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1882       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1883       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1884      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1885 c diagnostics only
1886 c      eom1=0.0d0
1887 c      eom2=0.0d0
1888 c      eom12=evdwij*eps1_om12
1889 c end diagnostics
1890 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1891 c     &  " sigder",sigder
1892 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1893 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1894       do k=1,3
1895         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1896         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1897       enddo
1898       do k=1,3
1899         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1900       enddo
1901 c      write (iout,*) "gg",(gg(k),k=1,3)
1902       do k=1,3
1903         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1904      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1905      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1906         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1907      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1908      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1909 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1910 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1911 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1912 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1913       enddo
1914 C
1915 C Calculate the components of the gradient in DC and X
1916 C
1917 cgrad      do k=i,j-1
1918 cgrad        do l=1,3
1919 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1920 cgrad        enddo
1921 cgrad      enddo
1922       do l=1,3
1923         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1924         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1925       enddo
1926       return
1927       end
1928 C-----------------------------------------------------------------------
1929       subroutine e_softsphere(evdw)
1930 C
1931 C This subroutine calculates the interaction energy of nonbonded side chains
1932 C assuming the LJ potential of interaction.
1933 C
1934       implicit real*8 (a-h,o-z)
1935       include 'DIMENSIONS'
1936       parameter (accur=1.0d-10)
1937       include 'COMMON.GEO'
1938       include 'COMMON.VAR'
1939       include 'COMMON.LOCAL'
1940       include 'COMMON.CHAIN'
1941       include 'COMMON.DERIV'
1942       include 'COMMON.INTERACT'
1943       include 'COMMON.TORSION'
1944       include 'COMMON.SBRIDGE'
1945       include 'COMMON.NAMES'
1946       include 'COMMON.IOUNITS'
1947       include 'COMMON.CONTACTS'
1948       dimension gg(3)
1949 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1950       evdw=0.0D0
1951       do i=iatsc_s,iatsc_e
1952         itypi=iabs(itype(i))
1953         if (itypi.eq.ntyp1) cycle
1954         itypi1=iabs(itype(i+1))
1955         xi=c(1,nres+i)
1956         yi=c(2,nres+i)
1957         zi=c(3,nres+i)
1958 C
1959 C Calculate SC interaction energy.
1960 C
1961         do iint=1,nint_gr(i)
1962 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1963 cd   &                  'iend=',iend(i,iint)
1964           do j=istart(i,iint),iend(i,iint)
1965             itypj=iabs(itype(j))
1966             if (itypj.eq.ntyp1) cycle
1967             xj=c(1,nres+j)-xi
1968             yj=c(2,nres+j)-yi
1969             zj=c(3,nres+j)-zi
1970             rij=xj*xj+yj*yj+zj*zj
1971 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1972             r0ij=r0(itypi,itypj)
1973             r0ijsq=r0ij*r0ij
1974 c            print *,i,j,r0ij,dsqrt(rij)
1975             if (rij.lt.r0ijsq) then
1976               evdwij=0.25d0*(rij-r0ijsq)**2
1977               fac=rij-r0ijsq
1978             else
1979               evdwij=0.0d0
1980               fac=0.0d0
1981             endif
1982             evdw=evdw+evdwij
1983 C
1984 C Calculate the components of the gradient in DC and X
1985 C
1986             gg(1)=xj*fac
1987             gg(2)=yj*fac
1988             gg(3)=zj*fac
1989             do k=1,3
1990               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1991               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1992               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1993               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1994             enddo
1995 cgrad            do k=i,j-1
1996 cgrad              do l=1,3
1997 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1998 cgrad              enddo
1999 cgrad            enddo
2000           enddo ! j
2001         enddo ! iint
2002       enddo ! i
2003       return
2004       end
2005 C--------------------------------------------------------------------------
2006       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2007      &              eello_turn4)
2008 C
2009 C Soft-sphere potential of p-p interaction
2010 C
2011       implicit real*8 (a-h,o-z)
2012       include 'DIMENSIONS'
2013       include 'COMMON.CONTROL'
2014       include 'COMMON.IOUNITS'
2015       include 'COMMON.GEO'
2016       include 'COMMON.VAR'
2017       include 'COMMON.LOCAL'
2018       include 'COMMON.CHAIN'
2019       include 'COMMON.DERIV'
2020       include 'COMMON.INTERACT'
2021       include 'COMMON.CONTACTS'
2022       include 'COMMON.TORSION'
2023       include 'COMMON.VECTORS'
2024       include 'COMMON.FFIELD'
2025       dimension ggg(3)
2026 C      write(iout,*) 'In EELEC_soft_sphere'
2027       ees=0.0D0
2028       evdw1=0.0D0
2029       eel_loc=0.0d0
2030       eello_turn3=0.0d0
2031       eello_turn4=0.0d0
2032       ind=0
2033       do i=iatel_s,iatel_e
2034         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2035         dxi=dc(1,i)
2036         dyi=dc(2,i)
2037         dzi=dc(3,i)
2038         xmedi=c(1,i)+0.5d0*dxi
2039         ymedi=c(2,i)+0.5d0*dyi
2040         zmedi=c(3,i)+0.5d0*dzi
2041           xmedi=mod(xmedi,boxxsize)
2042           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2043           ymedi=mod(ymedi,boxysize)
2044           if (ymedi.lt.0) ymedi=ymedi+boxysize
2045           zmedi=mod(zmedi,boxzsize)
2046           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2047         num_conti=0
2048 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2049         do j=ielstart(i),ielend(i)
2050           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2051           ind=ind+1
2052           iteli=itel(i)
2053           itelj=itel(j)
2054           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2055           r0ij=rpp(iteli,itelj)
2056           r0ijsq=r0ij*r0ij
2057           dxj=dc(1,j)
2058           dyj=dc(2,j)
2059           dzj=dc(3,j)
2060           xj=c(1,j)+0.5D0*dxj
2061           yj=c(2,j)+0.5D0*dyj
2062           zj=c(3,j)+0.5D0*dzj
2063           xj=mod(xj,boxxsize)
2064           if (xj.lt.0) xj=xj+boxxsize
2065           yj=mod(yj,boxysize)
2066           if (yj.lt.0) yj=yj+boxysize
2067           zj=mod(zj,boxzsize)
2068           if (zj.lt.0) zj=zj+boxzsize
2069       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2070       xj_safe=xj
2071       yj_safe=yj
2072       zj_safe=zj
2073       isubchap=0
2074       do xshift=-1,1
2075       do yshift=-1,1
2076       do zshift=-1,1
2077           xj=xj_safe+xshift*boxxsize
2078           yj=yj_safe+yshift*boxysize
2079           zj=zj_safe+zshift*boxzsize
2080           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2081           if(dist_temp.lt.dist_init) then
2082             dist_init=dist_temp
2083             xj_temp=xj
2084             yj_temp=yj
2085             zj_temp=zj
2086             isubchap=1
2087           endif
2088        enddo
2089        enddo
2090        enddo
2091        if (isubchap.eq.1) then
2092           xj=xj_temp-xmedi
2093           yj=yj_temp-ymedi
2094           zj=zj_temp-zmedi
2095        else
2096           xj=xj_safe-xmedi
2097           yj=yj_safe-ymedi
2098           zj=zj_safe-zmedi
2099        endif
2100           rij=xj*xj+yj*yj+zj*zj
2101             sss=sscale(sqrt(rij))
2102             sssgrad=sscagrad(sqrt(rij))
2103           if (rij.lt.r0ijsq) then
2104             evdw1ij=0.25d0*(rij-r0ijsq)**2
2105             fac=rij-r0ijsq
2106           else
2107             evdw1ij=0.0d0
2108             fac=0.0d0
2109           endif
2110           evdw1=evdw1+evdw1ij*sss
2111 C
2112 C Calculate contributions to the Cartesian gradient.
2113 C
2114           ggg(1)=fac*xj*sssgrad
2115           ggg(2)=fac*yj*sssgrad
2116           ggg(3)=fac*zj*sssgrad
2117           do k=1,3
2118             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2119             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2120           enddo
2121 *
2122 * Loop over residues i+1 thru j-1.
2123 *
2124 cgrad          do k=i+1,j-1
2125 cgrad            do l=1,3
2126 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2127 cgrad            enddo
2128 cgrad          enddo
2129         enddo ! j
2130       enddo   ! i
2131 cgrad      do i=nnt,nct-1
2132 cgrad        do k=1,3
2133 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2134 cgrad        enddo
2135 cgrad        do j=i+1,nct-1
2136 cgrad          do k=1,3
2137 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2138 cgrad          enddo
2139 cgrad        enddo
2140 cgrad      enddo
2141       return
2142       end
2143 c------------------------------------------------------------------------------
2144       subroutine vec_and_deriv
2145       implicit real*8 (a-h,o-z)
2146       include 'DIMENSIONS'
2147 #ifdef MPI
2148       include 'mpif.h'
2149 #endif
2150       include 'COMMON.IOUNITS'
2151       include 'COMMON.GEO'
2152       include 'COMMON.VAR'
2153       include 'COMMON.LOCAL'
2154       include 'COMMON.CHAIN'
2155       include 'COMMON.VECTORS'
2156       include 'COMMON.SETUP'
2157       include 'COMMON.TIME1'
2158       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2159 C Compute the local reference systems. For reference system (i), the
2160 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2161 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2162 #ifdef PARVEC
2163       do i=ivec_start,ivec_end
2164 #else
2165       do i=1,nres-1
2166 #endif
2167           if (i.eq.nres-1) then
2168 C Case of the last full residue
2169 C Compute the Z-axis
2170             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2171             costh=dcos(pi-theta(nres))
2172             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2173             do k=1,3
2174               uz(k,i)=fac*uz(k,i)
2175             enddo
2176 C Compute the derivatives of uz
2177             uzder(1,1,1)= 0.0d0
2178             uzder(2,1,1)=-dc_norm(3,i-1)
2179             uzder(3,1,1)= dc_norm(2,i-1)
2180             uzder(1,2,1)= dc_norm(3,i-1)
2181             uzder(2,2,1)= 0.0d0
2182             uzder(3,2,1)=-dc_norm(1,i-1)
2183             uzder(1,3,1)=-dc_norm(2,i-1)
2184             uzder(2,3,1)= dc_norm(1,i-1)
2185             uzder(3,3,1)= 0.0d0
2186             uzder(1,1,2)= 0.0d0
2187             uzder(2,1,2)= dc_norm(3,i)
2188             uzder(3,1,2)=-dc_norm(2,i)
2189             uzder(1,2,2)=-dc_norm(3,i)
2190             uzder(2,2,2)= 0.0d0
2191             uzder(3,2,2)= dc_norm(1,i)
2192             uzder(1,3,2)= dc_norm(2,i)
2193             uzder(2,3,2)=-dc_norm(1,i)
2194             uzder(3,3,2)= 0.0d0
2195 C Compute the Y-axis
2196             facy=fac
2197             do k=1,3
2198               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2199             enddo
2200 C Compute the derivatives of uy
2201             do j=1,3
2202               do k=1,3
2203                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2204      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2205                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2206               enddo
2207               uyder(j,j,1)=uyder(j,j,1)-costh
2208               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2209             enddo
2210             do j=1,2
2211               do k=1,3
2212                 do l=1,3
2213                   uygrad(l,k,j,i)=uyder(l,k,j)
2214                   uzgrad(l,k,j,i)=uzder(l,k,j)
2215                 enddo
2216               enddo
2217             enddo
2218             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2219             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2220             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2221             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2222           else
2223 C Other residues
2224 C Compute the Z-axis
2225             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2226             costh=dcos(pi-theta(i+2))
2227             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2228             do k=1,3
2229               uz(k,i)=fac*uz(k,i)
2230             enddo
2231 C Compute the derivatives of uz
2232             uzder(1,1,1)= 0.0d0
2233             uzder(2,1,1)=-dc_norm(3,i+1)
2234             uzder(3,1,1)= dc_norm(2,i+1)
2235             uzder(1,2,1)= dc_norm(3,i+1)
2236             uzder(2,2,1)= 0.0d0
2237             uzder(3,2,1)=-dc_norm(1,i+1)
2238             uzder(1,3,1)=-dc_norm(2,i+1)
2239             uzder(2,3,1)= dc_norm(1,i+1)
2240             uzder(3,3,1)= 0.0d0
2241             uzder(1,1,2)= 0.0d0
2242             uzder(2,1,2)= dc_norm(3,i)
2243             uzder(3,1,2)=-dc_norm(2,i)
2244             uzder(1,2,2)=-dc_norm(3,i)
2245             uzder(2,2,2)= 0.0d0
2246             uzder(3,2,2)= dc_norm(1,i)
2247             uzder(1,3,2)= dc_norm(2,i)
2248             uzder(2,3,2)=-dc_norm(1,i)
2249             uzder(3,3,2)= 0.0d0
2250 C Compute the Y-axis
2251             facy=fac
2252             do k=1,3
2253               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2254             enddo
2255 C Compute the derivatives of uy
2256             do j=1,3
2257               do k=1,3
2258                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2259      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2260                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2261               enddo
2262               uyder(j,j,1)=uyder(j,j,1)-costh
2263               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2264             enddo
2265             do j=1,2
2266               do k=1,3
2267                 do l=1,3
2268                   uygrad(l,k,j,i)=uyder(l,k,j)
2269                   uzgrad(l,k,j,i)=uzder(l,k,j)
2270                 enddo
2271               enddo
2272             enddo
2273             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2274             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2275             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2276             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2277           endif
2278       enddo
2279       do i=1,nres-1
2280         vbld_inv_temp(1)=vbld_inv(i+1)
2281         if (i.lt.nres-1) then
2282           vbld_inv_temp(2)=vbld_inv(i+2)
2283           else
2284           vbld_inv_temp(2)=vbld_inv(i)
2285           endif
2286         do j=1,2
2287           do k=1,3
2288             do l=1,3
2289               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2290               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2291             enddo
2292           enddo
2293         enddo
2294       enddo
2295 #if defined(PARVEC) && defined(MPI)
2296       if (nfgtasks1.gt.1) then
2297         time00=MPI_Wtime()
2298 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2299 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2300 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2301         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2302      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2303      &   FG_COMM1,IERR)
2304         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2305      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2306      &   FG_COMM1,IERR)
2307         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2308      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2309      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2310         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2311      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2312      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2313         time_gather=time_gather+MPI_Wtime()-time00
2314       endif
2315 c      if (fg_rank.eq.0) then
2316 c        write (iout,*) "Arrays UY and UZ"
2317 c        do i=1,nres-1
2318 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2319 c     &     (uz(k,i),k=1,3)
2320 c        enddo
2321 c      endif
2322 #endif
2323       return
2324       end
2325 C-----------------------------------------------------------------------------
2326       subroutine check_vecgrad
2327       implicit real*8 (a-h,o-z)
2328       include 'DIMENSIONS'
2329       include 'COMMON.IOUNITS'
2330       include 'COMMON.GEO'
2331       include 'COMMON.VAR'
2332       include 'COMMON.LOCAL'
2333       include 'COMMON.CHAIN'
2334       include 'COMMON.VECTORS'
2335       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2336       dimension uyt(3,maxres),uzt(3,maxres)
2337       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2338       double precision delta /1.0d-7/
2339       call vec_and_deriv
2340 cd      do i=1,nres
2341 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2344 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2345 cd     &     (dc_norm(if90,i),if90=1,3)
2346 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2348 cd          write(iout,'(a)')
2349 cd      enddo
2350       do i=1,nres
2351         do j=1,2
2352           do k=1,3
2353             do l=1,3
2354               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2355               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2356             enddo
2357           enddo
2358         enddo
2359       enddo
2360       call vec_and_deriv
2361       do i=1,nres
2362         do j=1,3
2363           uyt(j,i)=uy(j,i)
2364           uzt(j,i)=uz(j,i)
2365         enddo
2366       enddo
2367       do i=1,nres
2368 cd        write (iout,*) 'i=',i
2369         do k=1,3
2370           erij(k)=dc_norm(k,i)
2371         enddo
2372         do j=1,3
2373           do k=1,3
2374             dc_norm(k,i)=erij(k)
2375           enddo
2376           dc_norm(j,i)=dc_norm(j,i)+delta
2377 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2378 c          do k=1,3
2379 c            dc_norm(k,i)=dc_norm(k,i)/fac
2380 c          enddo
2381 c          write (iout,*) (dc_norm(k,i),k=1,3)
2382 c          write (iout,*) (erij(k),k=1,3)
2383           call vec_and_deriv
2384           do k=1,3
2385             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2386             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2387             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2388             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2389           enddo
2390 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2391 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2392 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2393         enddo
2394         do k=1,3
2395           dc_norm(k,i)=erij(k)
2396         enddo
2397 cd        do k=1,3
2398 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2399 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2400 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2401 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2402 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2403 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2404 cd          write (iout,'(a)')
2405 cd        enddo
2406       enddo
2407       return
2408       end
2409 C--------------------------------------------------------------------------
2410       subroutine set_matrices
2411       implicit real*8 (a-h,o-z)
2412       include 'DIMENSIONS'
2413 #ifdef MPI
2414       include "mpif.h"
2415       include "COMMON.SETUP"
2416       integer IERR
2417       integer status(MPI_STATUS_SIZE)
2418 #endif
2419       include 'COMMON.IOUNITS'
2420       include 'COMMON.GEO'
2421       include 'COMMON.VAR'
2422       include 'COMMON.LOCAL'
2423       include 'COMMON.CHAIN'
2424       include 'COMMON.DERIV'
2425       include 'COMMON.INTERACT'
2426       include 'COMMON.CONTACTS'
2427       include 'COMMON.TORSION'
2428       include 'COMMON.VECTORS'
2429       include 'COMMON.FFIELD'
2430       double precision auxvec(2),auxmat(2,2)
2431 C
2432 C Compute the virtual-bond-torsional-angle dependent quantities needed
2433 C to calculate the el-loc multibody terms of various order.
2434 C
2435 #ifdef PARMAT
2436       do i=ivec_start+2,ivec_end+2
2437 #else
2438       do i=3,nres+1
2439 #endif
2440         if (i .lt. nres+1) then
2441           sin1=dsin(phi(i))
2442           cos1=dcos(phi(i))
2443           sintab(i-2)=sin1
2444           costab(i-2)=cos1
2445           obrot(1,i-2)=cos1
2446           obrot(2,i-2)=sin1
2447           sin2=dsin(2*phi(i))
2448           cos2=dcos(2*phi(i))
2449           sintab2(i-2)=sin2
2450           costab2(i-2)=cos2
2451           obrot2(1,i-2)=cos2
2452           obrot2(2,i-2)=sin2
2453           Ug(1,1,i-2)=-cos1
2454           Ug(1,2,i-2)=-sin1
2455           Ug(2,1,i-2)=-sin1
2456           Ug(2,2,i-2)= cos1
2457           Ug2(1,1,i-2)=-cos2
2458           Ug2(1,2,i-2)=-sin2
2459           Ug2(2,1,i-2)=-sin2
2460           Ug2(2,2,i-2)= cos2
2461         else
2462           costab(i-2)=1.0d0
2463           sintab(i-2)=0.0d0
2464           obrot(1,i-2)=1.0d0
2465           obrot(2,i-2)=0.0d0
2466           obrot2(1,i-2)=0.0d0
2467           obrot2(2,i-2)=0.0d0
2468           Ug(1,1,i-2)=1.0d0
2469           Ug(1,2,i-2)=0.0d0
2470           Ug(2,1,i-2)=0.0d0
2471           Ug(2,2,i-2)=1.0d0
2472           Ug2(1,1,i-2)=0.0d0
2473           Ug2(1,2,i-2)=0.0d0
2474           Ug2(2,1,i-2)=0.0d0
2475           Ug2(2,2,i-2)=0.0d0
2476         endif
2477         if (i .gt. 3 .and. i .lt. nres+1) then
2478           obrot_der(1,i-2)=-sin1
2479           obrot_der(2,i-2)= cos1
2480           Ugder(1,1,i-2)= sin1
2481           Ugder(1,2,i-2)=-cos1
2482           Ugder(2,1,i-2)=-cos1
2483           Ugder(2,2,i-2)=-sin1
2484           dwacos2=cos2+cos2
2485           dwasin2=sin2+sin2
2486           obrot2_der(1,i-2)=-dwasin2
2487           obrot2_der(2,i-2)= dwacos2
2488           Ug2der(1,1,i-2)= dwasin2
2489           Ug2der(1,2,i-2)=-dwacos2
2490           Ug2der(2,1,i-2)=-dwacos2
2491           Ug2der(2,2,i-2)=-dwasin2
2492         else
2493           obrot_der(1,i-2)=0.0d0
2494           obrot_der(2,i-2)=0.0d0
2495           Ugder(1,1,i-2)=0.0d0
2496           Ugder(1,2,i-2)=0.0d0
2497           Ugder(2,1,i-2)=0.0d0
2498           Ugder(2,2,i-2)=0.0d0
2499           obrot2_der(1,i-2)=0.0d0
2500           obrot2_der(2,i-2)=0.0d0
2501           Ug2der(1,1,i-2)=0.0d0
2502           Ug2der(1,2,i-2)=0.0d0
2503           Ug2der(2,1,i-2)=0.0d0
2504           Ug2der(2,2,i-2)=0.0d0
2505         endif
2506 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2507         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2508           iti = itortyp(itype(i-2))
2509         else
2510           iti=ntortyp
2511         endif
2512 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2513         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2514           iti1 = itortyp(itype(i-1))
2515         else
2516           iti1=ntortyp
2517         endif
2518 cd        write (iout,*) '*******i',i,' iti1',iti
2519 cd        write (iout,*) 'b1',b1(:,iti)
2520 cd        write (iout,*) 'b2',b2(:,iti)
2521 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2522 c        if (i .gt. iatel_s+2) then
2523         if (i .gt. nnt+2) then
2524           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2525           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2526           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2527      &    then
2528           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2529           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2530           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2531           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2532           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2533           endif
2534         else
2535           do k=1,2
2536             Ub2(k,i-2)=0.0d0
2537             Ctobr(k,i-2)=0.0d0
2538             Dtobr2(k,i-2)=0.0d0
2539             do l=1,2
2540               EUg(l,k,i-2)=0.0d0
2541               CUg(l,k,i-2)=0.0d0
2542               DUg(l,k,i-2)=0.0d0
2543               DtUg2(l,k,i-2)=0.0d0
2544             enddo
2545           enddo
2546         endif
2547         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2548         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2549         do k=1,2
2550           muder(k,i-2)=Ub2der(k,i-2)
2551         enddo
2552 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2553         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2554           if (itype(i-1).le.ntyp) then
2555             iti1 = itortyp(itype(i-1))
2556           else
2557             iti1=ntortyp
2558           endif
2559         else
2560           iti1=ntortyp
2561         endif
2562         do k=1,2
2563           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2564         enddo
2565 cd        write (iout,*) 'mu ',mu(:,i-2)
2566 cd        write (iout,*) 'mu1',mu1(:,i-2)
2567 cd        write (iout,*) 'mu2',mu2(:,i-2)
2568         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2569      &  then
2570         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2571         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2572         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2573         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2574         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2575 C Vectors and matrices dependent on a single virtual-bond dihedral.
2576         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2577         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2578         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2579         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2580         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2581         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2582         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2583         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2584         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2585         endif
2586       enddo
2587 C Matrices dependent on two consecutive virtual-bond dihedrals.
2588 C The order of matrices is from left to right.
2589       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2590      &then
2591 c      do i=max0(ivec_start,2),ivec_end
2592       do i=2,nres-1
2593         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2594         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2595         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2596         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2597         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2598         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2599         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2600         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2601       enddo
2602       endif
2603 #if defined(MPI) && defined(PARMAT)
2604 #ifdef DEBUG
2605 c      if (fg_rank.eq.0) then
2606         write (iout,*) "Arrays UG and UGDER before GATHER"
2607         do i=1,nres-1
2608           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2609      &     ((ug(l,k,i),l=1,2),k=1,2),
2610      &     ((ugder(l,k,i),l=1,2),k=1,2)
2611         enddo
2612         write (iout,*) "Arrays UG2 and UG2DER"
2613         do i=1,nres-1
2614           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2615      &     ((ug2(l,k,i),l=1,2),k=1,2),
2616      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2617         enddo
2618         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2619         do i=1,nres-1
2620           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2621      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2622      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2623         enddo
2624         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2625         do i=1,nres-1
2626           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2627      &     costab(i),sintab(i),costab2(i),sintab2(i)
2628         enddo
2629         write (iout,*) "Array MUDER"
2630         do i=1,nres-1
2631           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2632         enddo
2633 c      endif
2634 #endif
2635       if (nfgtasks.gt.1) then
2636         time00=MPI_Wtime()
2637 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2638 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2639 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2640 #ifdef MATGATHER
2641         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2642      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2643      &   FG_COMM1,IERR)
2644         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2645      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2646      &   FG_COMM1,IERR)
2647         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2648      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2649      &   FG_COMM1,IERR)
2650         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2651      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2652      &   FG_COMM1,IERR)
2653         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2654      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2655      &   FG_COMM1,IERR)
2656         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2657      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2658      &   FG_COMM1,IERR)
2659         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2660      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2661      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2662         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2663      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2664      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2665         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2666      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2667      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2668         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2669      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2670      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2671         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2672      &  then
2673         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2674      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2675      &   FG_COMM1,IERR)
2676         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2677      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2678      &   FG_COMM1,IERR)
2679         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2680      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2681      &   FG_COMM1,IERR)
2682        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2683      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2684      &   FG_COMM1,IERR)
2685         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2689      &   ivec_count(fg_rank1),
2690      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2691      &   FG_COMM1,IERR)
2692         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2693      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2694      &   FG_COMM1,IERR)
2695         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2696      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2697      &   FG_COMM1,IERR)
2698         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2699      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2700      &   FG_COMM1,IERR)
2701         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2702      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2706      &   FG_COMM1,IERR)
2707         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2712      &   FG_COMM1,IERR)
2713         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2714      &   ivec_count(fg_rank1),
2715      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2716      &   FG_COMM1,IERR)
2717         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2719      &   FG_COMM1,IERR)
2720        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2725      &   FG_COMM1,IERR)
2726        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2730      &   ivec_count(fg_rank1),
2731      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2732      &   FG_COMM1,IERR)
2733         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2734      &   ivec_count(fg_rank1),
2735      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2736      &   FG_COMM1,IERR)
2737         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2738      &   ivec_count(fg_rank1),
2739      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2740      &   MPI_MAT2,FG_COMM1,IERR)
2741         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2742      &   ivec_count(fg_rank1),
2743      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2744      &   MPI_MAT2,FG_COMM1,IERR)
2745         endif
2746 #else
2747 c Passes matrix info through the ring
2748       isend=fg_rank1
2749       irecv=fg_rank1-1
2750       if (irecv.lt.0) irecv=nfgtasks1-1
2751       iprev=irecv
2752       inext=fg_rank1+1
2753       if (inext.ge.nfgtasks1) inext=0
2754       do i=1,nfgtasks1-1
2755 c        write (iout,*) "isend",isend," irecv",irecv
2756 c        call flush(iout)
2757         lensend=lentyp(isend)
2758         lenrecv=lentyp(irecv)
2759 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2760 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2761 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2762 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2763 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2764 c        write (iout,*) "Gather ROTAT1"
2765 c        call flush(iout)
2766 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2767 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2768 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2769 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2770 c        write (iout,*) "Gather ROTAT2"
2771 c        call flush(iout)
2772         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2773      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2774      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2775      &   iprev,4400+irecv,FG_COMM,status,IERR)
2776 c        write (iout,*) "Gather ROTAT_OLD"
2777 c        call flush(iout)
2778         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2779      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2780      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2781      &   iprev,5500+irecv,FG_COMM,status,IERR)
2782 c        write (iout,*) "Gather PRECOMP11"
2783 c        call flush(iout)
2784         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2785      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2786      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2787      &   iprev,6600+irecv,FG_COMM,status,IERR)
2788 c        write (iout,*) "Gather PRECOMP12"
2789 c        call flush(iout)
2790         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2791      &  then
2792         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2793      &   MPI_ROTAT2(lensend),inext,7700+isend,
2794      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2795      &   iprev,7700+irecv,FG_COMM,status,IERR)
2796 c        write (iout,*) "Gather PRECOMP21"
2797 c        call flush(iout)
2798         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2799      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2800      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2801      &   iprev,8800+irecv,FG_COMM,status,IERR)
2802 c        write (iout,*) "Gather PRECOMP22"
2803 c        call flush(iout)
2804         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2805      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2806      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2807      &   MPI_PRECOMP23(lenrecv),
2808      &   iprev,9900+irecv,FG_COMM,status,IERR)
2809 c        write (iout,*) "Gather PRECOMP23"
2810 c        call flush(iout)
2811         endif
2812         isend=irecv
2813         irecv=irecv-1
2814         if (irecv.lt.0) irecv=nfgtasks1-1
2815       enddo
2816 #endif
2817         time_gather=time_gather+MPI_Wtime()-time00
2818       endif
2819 #ifdef DEBUG
2820 c      if (fg_rank.eq.0) then
2821         write (iout,*) "Arrays UG and UGDER"
2822         do i=1,nres-1
2823           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2824      &     ((ug(l,k,i),l=1,2),k=1,2),
2825      &     ((ugder(l,k,i),l=1,2),k=1,2)
2826         enddo
2827         write (iout,*) "Arrays UG2 and UG2DER"
2828         do i=1,nres-1
2829           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2830      &     ((ug2(l,k,i),l=1,2),k=1,2),
2831      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2832         enddo
2833         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2834         do i=1,nres-1
2835           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2836      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2837      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2838         enddo
2839         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2840         do i=1,nres-1
2841           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2842      &     costab(i),sintab(i),costab2(i),sintab2(i)
2843         enddo
2844         write (iout,*) "Array MUDER"
2845         do i=1,nres-1
2846           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2847         enddo
2848 c      endif
2849 #endif
2850 #endif
2851 cd      do i=1,nres
2852 cd        iti = itortyp(itype(i))
2853 cd        write (iout,*) i
2854 cd        do j=1,2
2855 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2856 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2857 cd        enddo
2858 cd      enddo
2859       return
2860       end
2861 C--------------------------------------------------------------------------
2862       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2863 C
2864 C This subroutine calculates the average interaction energy and its gradient
2865 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2866 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2867 C The potential depends both on the distance of peptide-group centers and on
2868 C the orientation of the CA-CA virtual bonds.
2869 C
2870       implicit real*8 (a-h,o-z)
2871 #ifdef MPI
2872       include 'mpif.h'
2873 #endif
2874       include 'DIMENSIONS'
2875       include 'COMMON.CONTROL'
2876       include 'COMMON.SETUP'
2877       include 'COMMON.IOUNITS'
2878       include 'COMMON.GEO'
2879       include 'COMMON.VAR'
2880       include 'COMMON.LOCAL'
2881       include 'COMMON.CHAIN'
2882       include 'COMMON.DERIV'
2883       include 'COMMON.INTERACT'
2884       include 'COMMON.CONTACTS'
2885       include 'COMMON.TORSION'
2886       include 'COMMON.VECTORS'
2887       include 'COMMON.FFIELD'
2888       include 'COMMON.TIME1'
2889       include 'COMMON.SPLITELE'
2890       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2891      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2892       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2893      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2894       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2895      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2896      &    num_conti,j1,j2
2897 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2898 #ifdef MOMENT
2899       double precision scal_el /1.0d0/
2900 #else
2901       double precision scal_el /0.5d0/
2902 #endif
2903 C 12/13/98
2904 C 13-go grudnia roku pamietnego...
2905       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2906      &                   0.0d0,1.0d0,0.0d0,
2907      &                   0.0d0,0.0d0,1.0d0/
2908 cd      write(iout,*) 'In EELEC'
2909 cd      do i=1,nloctyp
2910 cd        write(iout,*) 'Type',i
2911 cd        write(iout,*) 'B1',B1(:,i)
2912 cd        write(iout,*) 'B2',B2(:,i)
2913 cd        write(iout,*) 'CC',CC(:,:,i)
2914 cd        write(iout,*) 'DD',DD(:,:,i)
2915 cd        write(iout,*) 'EE',EE(:,:,i)
2916 cd      enddo
2917 cd      call check_vecgrad
2918 cd      stop
2919       if (icheckgrad.eq.1) then
2920         do i=1,nres-1
2921           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2922           do k=1,3
2923             dc_norm(k,i)=dc(k,i)*fac
2924           enddo
2925 c          write (iout,*) 'i',i,' fac',fac
2926         enddo
2927       endif
2928       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2929      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2930      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2931 c        call vec_and_deriv
2932 #ifdef TIMING
2933         time01=MPI_Wtime()
2934 #endif
2935         call set_matrices
2936 #ifdef TIMING
2937         time_mat=time_mat+MPI_Wtime()-time01
2938 #endif
2939       endif
2940 cd      do i=1,nres-1
2941 cd        write (iout,*) 'i=',i
2942 cd        do k=1,3
2943 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2944 cd        enddo
2945 cd        do k=1,3
2946 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2947 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2948 cd        enddo
2949 cd      enddo
2950       t_eelecij=0.0d0
2951       ees=0.0D0
2952       evdw1=0.0D0
2953       eel_loc=0.0d0
2954       eello_turn3=0.0d0
2955       eello_turn4=0.0d0
2956       ind=0
2957       do i=1,nres
2958         num_cont_hb(i)=0
2959       enddo
2960 cd      print '(a)','Enter EELEC'
2961 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2962       do i=1,nres
2963         gel_loc_loc(i)=0.0d0
2964         gcorr_loc(i)=0.0d0
2965       enddo
2966 c
2967 c
2968 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2969 C
2970 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2971 C
2972 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2973       do i=iturn3_start,iturn3_end
2974         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2975      &  .or. itype(i+2).eq.ntyp1
2976      &  .or. itype(i+3).eq.ntyp1
2977      &  .or. itype(i-1).eq.ntyp1
2978      &  .or. itype(i+4).eq.ntyp1
2979      &  ) cycle
2980         dxi=dc(1,i)
2981         dyi=dc(2,i)
2982         dzi=dc(3,i)
2983         dx_normi=dc_norm(1,i)
2984         dy_normi=dc_norm(2,i)
2985         dz_normi=dc_norm(3,i)
2986         xmedi=c(1,i)+0.5d0*dxi
2987         ymedi=c(2,i)+0.5d0*dyi
2988         zmedi=c(3,i)+0.5d0*dzi
2989           xmedi=mod(xmedi,boxxsize)
2990           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2991           ymedi=mod(ymedi,boxysize)
2992           if (ymedi.lt.0) ymedi=ymedi+boxysize
2993           zmedi=mod(zmedi,boxzsize)
2994           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2995         num_conti=0
2996         call eelecij(i,i+2,ees,evdw1,eel_loc)
2997         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2998         num_cont_hb(i)=num_conti
2999       enddo
3000       do i=iturn4_start,iturn4_end
3001         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3002      &    .or. itype(i+3).eq.ntyp1
3003      &    .or. itype(i+4).eq.ntyp1
3004      &    .or. itype(i+5).eq.ntyp1
3005      &    .or. itype(i).eq.ntyp1
3006      &    .or. itype(i-1).eq.ntyp1
3007      &                             ) cycle
3008         dxi=dc(1,i)
3009         dyi=dc(2,i)
3010         dzi=dc(3,i)
3011         dx_normi=dc_norm(1,i)
3012         dy_normi=dc_norm(2,i)
3013         dz_normi=dc_norm(3,i)
3014         xmedi=c(1,i)+0.5d0*dxi
3015         ymedi=c(2,i)+0.5d0*dyi
3016         zmedi=c(3,i)+0.5d0*dzi
3017 C Return atom into box, boxxsize is size of box in x dimension
3018 c  194   continue
3019 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3020 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3021 C Condition for being inside the proper box
3022 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3023 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3024 c        go to 194
3025 c        endif
3026 c  195   continue
3027 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3028 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3029 C Condition for being inside the proper box
3030 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3031 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3032 c        go to 195
3033 c        endif
3034 c  196   continue
3035 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3036 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3037 C Condition for being inside the proper box
3038 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3039 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3040 c        go to 196
3041 c        endif
3042           xmedi=mod(xmedi,boxxsize)
3043           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3044           ymedi=mod(ymedi,boxysize)
3045           if (ymedi.lt.0) ymedi=ymedi+boxysize
3046           zmedi=mod(zmedi,boxzsize)
3047           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3048
3049         num_conti=num_cont_hb(i)
3050         call eelecij(i,i+3,ees,evdw1,eel_loc)
3051         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3052      &   call eturn4(i,eello_turn4)
3053         num_cont_hb(i)=num_conti
3054       enddo   ! i
3055 C Loop over all neighbouring boxes
3056 C      do xshift=-1,1
3057 C      do yshift=-1,1
3058 C      do zshift=-1,1
3059 c
3060 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3061 c
3062       do i=iatel_s,iatel_e
3063         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3064      &  .or. itype(i+2).eq.ntyp1
3065      &  .or. itype(i-1).eq.ntyp1
3066      &                ) cycle
3067         dxi=dc(1,i)
3068         dyi=dc(2,i)
3069         dzi=dc(3,i)
3070         dx_normi=dc_norm(1,i)
3071         dy_normi=dc_norm(2,i)
3072         dz_normi=dc_norm(3,i)
3073         xmedi=c(1,i)+0.5d0*dxi
3074         ymedi=c(2,i)+0.5d0*dyi
3075         zmedi=c(3,i)+0.5d0*dzi
3076           xmedi=mod(xmedi,boxxsize)
3077           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3078           ymedi=mod(ymedi,boxysize)
3079           if (ymedi.lt.0) ymedi=ymedi+boxysize
3080           zmedi=mod(zmedi,boxzsize)
3081           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3082 C          xmedi=xmedi+xshift*boxxsize
3083 C          ymedi=ymedi+yshift*boxysize
3084 C          zmedi=zmedi+zshift*boxzsize
3085
3086 C Return tom into box, boxxsize is size of box in x dimension
3087 c  164   continue
3088 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3089 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3090 C Condition for being inside the proper box
3091 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3092 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3093 c        go to 164
3094 c        endif
3095 c  165   continue
3096 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3097 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3098 C Condition for being inside the proper box
3099 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3100 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3101 c        go to 165
3102 c        endif
3103 c  166   continue
3104 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3105 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3106 cC Condition for being inside the proper box
3107 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3108 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3109 c        go to 166
3110 c        endif
3111
3112 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3113         num_conti=num_cont_hb(i)
3114         do j=ielstart(i),ielend(i)
3115 c          write (iout,*) i,j,itype(i),itype(j)
3116           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3117      & .or.itype(j+2).eq.ntyp1
3118      & .or.itype(j-1).eq.ntyp1
3119      &) cycle
3120           call eelecij(i,j,ees,evdw1,eel_loc)
3121         enddo ! j
3122         num_cont_hb(i)=num_conti
3123       enddo   ! i
3124 C     enddo   ! zshift
3125 C      enddo   ! yshift
3126 C      enddo   ! xshift
3127
3128 c      write (iout,*) "Number of loop steps in EELEC:",ind
3129 cd      do i=1,nres
3130 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3131 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3132 cd      enddo
3133 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3134 ccc      eel_loc=eel_loc+eello_turn3
3135 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3136       return
3137       end
3138 C-------------------------------------------------------------------------------
3139       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3140       implicit real*8 (a-h,o-z)
3141       include 'DIMENSIONS'
3142 #ifdef MPI
3143       include "mpif.h"
3144 #endif
3145       include 'COMMON.CONTROL'
3146       include 'COMMON.IOUNITS'
3147       include 'COMMON.GEO'
3148       include 'COMMON.VAR'
3149       include 'COMMON.LOCAL'
3150       include 'COMMON.CHAIN'
3151       include 'COMMON.DERIV'
3152       include 'COMMON.INTERACT'
3153       include 'COMMON.CONTACTS'
3154       include 'COMMON.TORSION'
3155       include 'COMMON.VECTORS'
3156       include 'COMMON.FFIELD'
3157       include 'COMMON.TIME1'
3158       include 'COMMON.SPLITELE'
3159       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3160      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3161       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3162      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3163       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3164      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3165      &    num_conti,j1,j2
3166 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3167 #ifdef MOMENT
3168       double precision scal_el /1.0d0/
3169 #else
3170       double precision scal_el /0.5d0/
3171 #endif
3172 C 12/13/98
3173 C 13-go grudnia roku pamietnego...
3174       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3175      &                   0.0d0,1.0d0,0.0d0,
3176      &                   0.0d0,0.0d0,1.0d0/
3177 c          time00=MPI_Wtime()
3178 cd      write (iout,*) "eelecij",i,j
3179 c          ind=ind+1
3180           iteli=itel(i)
3181           itelj=itel(j)
3182           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3183           aaa=app(iteli,itelj)
3184           bbb=bpp(iteli,itelj)
3185           ael6i=ael6(iteli,itelj)
3186           ael3i=ael3(iteli,itelj)
3187           dxj=dc(1,j)
3188           dyj=dc(2,j)
3189           dzj=dc(3,j)
3190           dx_normj=dc_norm(1,j)
3191           dy_normj=dc_norm(2,j)
3192           dz_normj=dc_norm(3,j)
3193 C          xj=c(1,j)+0.5D0*dxj-xmedi
3194 C          yj=c(2,j)+0.5D0*dyj-ymedi
3195 C          zj=c(3,j)+0.5D0*dzj-zmedi
3196           xj=c(1,j)+0.5D0*dxj
3197           yj=c(2,j)+0.5D0*dyj
3198           zj=c(3,j)+0.5D0*dzj
3199           xj=mod(xj,boxxsize)
3200           if (xj.lt.0) xj=xj+boxxsize
3201           yj=mod(yj,boxysize)
3202           if (yj.lt.0) yj=yj+boxysize
3203           zj=mod(zj,boxzsize)
3204           if (zj.lt.0) zj=zj+boxzsize
3205           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3206       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3207       xj_safe=xj
3208       yj_safe=yj
3209       zj_safe=zj
3210       isubchap=0
3211       do xshift=-1,1
3212       do yshift=-1,1
3213       do zshift=-1,1
3214           xj=xj_safe+xshift*boxxsize
3215           yj=yj_safe+yshift*boxysize
3216           zj=zj_safe+zshift*boxzsize
3217           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3218           if(dist_temp.lt.dist_init) then
3219             dist_init=dist_temp
3220             xj_temp=xj
3221             yj_temp=yj
3222             zj_temp=zj
3223             isubchap=1
3224           endif
3225        enddo
3226        enddo
3227        enddo
3228        if (isubchap.eq.1) then
3229           xj=xj_temp-xmedi
3230           yj=yj_temp-ymedi
3231           zj=zj_temp-zmedi
3232        else
3233           xj=xj_safe-xmedi
3234           yj=yj_safe-ymedi
3235           zj=zj_safe-zmedi
3236        endif
3237 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3238 c  174   continue
3239 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3240 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3241 C Condition for being inside the proper box
3242 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3243 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3244 c        go to 174
3245 c        endif
3246 c  175   continue
3247 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3248 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3249 C Condition for being inside the proper box
3250 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3251 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3252 c        go to 175
3253 c        endif
3254 c  176   continue
3255 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3256 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3257 C Condition for being inside the proper box
3258 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3259 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3260 c        go to 176
3261 c        endif
3262 C        endif !endPBC condintion
3263 C        xj=xj-xmedi
3264 C        yj=yj-ymedi
3265 C        zj=zj-zmedi
3266           rij=xj*xj+yj*yj+zj*zj
3267
3268             sss=sscale(sqrt(rij))
3269             sssgrad=sscagrad(sqrt(rij))
3270 c            if (sss.gt.0.0d0) then
3271           rrmij=1.0D0/rij
3272           rij=dsqrt(rij)
3273           rmij=1.0D0/rij
3274           r3ij=rrmij*rmij
3275           r6ij=r3ij*r3ij
3276           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3277           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3278           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3279           fac=cosa-3.0D0*cosb*cosg
3280           ev1=aaa*r6ij*r6ij
3281 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3282           if (j.eq.i+2) ev1=scal_el*ev1
3283           ev2=bbb*r6ij
3284           fac3=ael6i*r6ij
3285           fac4=ael3i*r3ij
3286           evdwij=(ev1+ev2)
3287           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3288           el2=fac4*fac
3289 C MARYSIA
3290           eesij=(el1+el2)
3291 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3292           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3293           ees=ees+eesij
3294           evdw1=evdw1+evdwij*sss
3295 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3296 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3297 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3298 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3299
3300           if (energy_dec) then
3301               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3302      &'evdw1',i,j,evdwij
3303      &,iteli,itelj,aaa,evdw1
3304               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3305           endif
3306
3307 C
3308 C Calculate contributions to the Cartesian gradient.
3309 C
3310 #ifdef SPLITELE
3311           facvdw=-6*rrmij*(ev1+evdwij)*sss
3312           facel=-3*rrmij*(el1+eesij)
3313           fac1=fac
3314           erij(1)=xj*rmij
3315           erij(2)=yj*rmij
3316           erij(3)=zj*rmij
3317 *
3318 * Radial derivatives. First process both termini of the fragment (i,j)
3319 *
3320           ggg(1)=facel*xj
3321           ggg(2)=facel*yj
3322           ggg(3)=facel*zj
3323 c          do k=1,3
3324 c            ghalf=0.5D0*ggg(k)
3325 c            gelc(k,i)=gelc(k,i)+ghalf
3326 c            gelc(k,j)=gelc(k,j)+ghalf
3327 c          enddo
3328 c 9/28/08 AL Gradient compotents will be summed only at the end
3329           do k=1,3
3330             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3331             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3332           enddo
3333 *
3334 * Loop over residues i+1 thru j-1.
3335 *
3336 cgrad          do k=i+1,j-1
3337 cgrad            do l=1,3
3338 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3339 cgrad            enddo
3340 cgrad          enddo
3341           if (sss.gt.0.0) then
3342           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3343           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3344           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3345           else
3346           ggg(1)=0.0
3347           ggg(2)=0.0
3348           ggg(3)=0.0
3349           endif
3350 c          do k=1,3
3351 c            ghalf=0.5D0*ggg(k)
3352 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3353 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3354 c          enddo
3355 c 9/28/08 AL Gradient compotents will be summed only at the end
3356           do k=1,3
3357             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3358             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3359           enddo
3360 *
3361 * Loop over residues i+1 thru j-1.
3362 *
3363 cgrad          do k=i+1,j-1
3364 cgrad            do l=1,3
3365 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3366 cgrad            enddo
3367 cgrad          enddo
3368 #else
3369 C MARYSIA
3370           facvdw=(ev1+evdwij)*sss
3371           facel=(el1+eesij)
3372           fac1=fac
3373           fac=-3*rrmij*(facvdw+facvdw+facel)
3374           erij(1)=xj*rmij
3375           erij(2)=yj*rmij
3376           erij(3)=zj*rmij
3377 *
3378 * Radial derivatives. First process both termini of the fragment (i,j)
3379 *
3380           ggg(1)=fac*xj
3381           ggg(2)=fac*yj
3382           ggg(3)=fac*zj
3383 c          do k=1,3
3384 c            ghalf=0.5D0*ggg(k)
3385 c            gelc(k,i)=gelc(k,i)+ghalf
3386 c            gelc(k,j)=gelc(k,j)+ghalf
3387 c          enddo
3388 c 9/28/08 AL Gradient compotents will be summed only at the end
3389           do k=1,3
3390             gelc_long(k,j)=gelc(k,j)+ggg(k)
3391             gelc_long(k,i)=gelc(k,i)-ggg(k)
3392           enddo
3393 *
3394 * Loop over residues i+1 thru j-1.
3395 *
3396 cgrad          do k=i+1,j-1
3397 cgrad            do l=1,3
3398 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3399 cgrad            enddo
3400 cgrad          enddo
3401 c 9/28/08 AL Gradient compotents will be summed only at the end
3402           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3403           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3404           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3405           do k=1,3
3406             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3407             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3408           enddo
3409 #endif
3410 *
3411 * Angular part
3412 *
3413           ecosa=2.0D0*fac3*fac1+fac4
3414           fac4=-3.0D0*fac4
3415           fac3=-6.0D0*fac3
3416           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3417           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3418           do k=1,3
3419             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3420             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3421           enddo
3422 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3423 cd   &          (dcosg(k),k=1,3)
3424           do k=1,3
3425             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3426           enddo
3427 c          do k=1,3
3428 c            ghalf=0.5D0*ggg(k)
3429 c            gelc(k,i)=gelc(k,i)+ghalf
3430 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3431 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3432 c            gelc(k,j)=gelc(k,j)+ghalf
3433 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3434 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3435 c          enddo
3436 cgrad          do k=i+1,j-1
3437 cgrad            do l=1,3
3438 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3439 cgrad            enddo
3440 cgrad          enddo
3441           do k=1,3
3442             gelc(k,i)=gelc(k,i)
3443      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3444      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3445             gelc(k,j)=gelc(k,j)
3446      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3447      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3448             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3449             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3450           enddo
3451 C MARYSIA
3452 c          endif !sscale
3453           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3454      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3455      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3456 C
3457 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3458 C   energy of a peptide unit is assumed in the form of a second-order
3459 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3460 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3461 C   are computed for EVERY pair of non-contiguous peptide groups.
3462 C
3463           if (j.lt.nres-1) then
3464             j1=j+1
3465             j2=j-1
3466           else
3467             j1=j-1
3468             j2=j-2
3469           endif
3470           kkk=0
3471           do k=1,2
3472             do l=1,2
3473               kkk=kkk+1
3474               muij(kkk)=mu(k,i)*mu(l,j)
3475             enddo
3476           enddo
3477 cd         write (iout,*) 'EELEC: i',i,' j',j
3478 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3479 cd          write(iout,*) 'muij',muij
3480           ury=scalar(uy(1,i),erij)
3481           urz=scalar(uz(1,i),erij)
3482           vry=scalar(uy(1,j),erij)
3483           vrz=scalar(uz(1,j),erij)
3484           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3485           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3486           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3487           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3488           fac=dsqrt(-ael6i)*r3ij
3489           a22=a22*fac
3490           a23=a23*fac
3491           a32=a32*fac
3492           a33=a33*fac
3493 cd          write (iout,'(4i5,4f10.5)')
3494 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3495 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3496 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3497 cd     &      uy(:,j),uz(:,j)
3498 cd          write (iout,'(4f10.5)')
3499 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3500 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3501 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3502 cd           write (iout,'(9f10.5/)')
3503 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3504 C Derivatives of the elements of A in virtual-bond vectors
3505           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3506           do k=1,3
3507             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3508             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3509             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3510             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3511             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3512             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3513             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3514             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3515             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3516             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3517             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3518             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3519           enddo
3520 C Compute radial contributions to the gradient
3521           facr=-3.0d0*rrmij
3522           a22der=a22*facr
3523           a23der=a23*facr
3524           a32der=a32*facr
3525           a33der=a33*facr
3526           agg(1,1)=a22der*xj
3527           agg(2,1)=a22der*yj
3528           agg(3,1)=a22der*zj
3529           agg(1,2)=a23der*xj
3530           agg(2,2)=a23der*yj
3531           agg(3,2)=a23der*zj
3532           agg(1,3)=a32der*xj
3533           agg(2,3)=a32der*yj
3534           agg(3,3)=a32der*zj
3535           agg(1,4)=a33der*xj
3536           agg(2,4)=a33der*yj
3537           agg(3,4)=a33der*zj
3538 C Add the contributions coming from er
3539           fac3=-3.0d0*fac
3540           do k=1,3
3541             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3542             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3543             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3544             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3545           enddo
3546           do k=1,3
3547 C Derivatives in DC(i)
3548 cgrad            ghalf1=0.5d0*agg(k,1)
3549 cgrad            ghalf2=0.5d0*agg(k,2)
3550 cgrad            ghalf3=0.5d0*agg(k,3)
3551 cgrad            ghalf4=0.5d0*agg(k,4)
3552             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3553      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3554             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3555      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3556             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3557      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3558             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3559      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3560 C Derivatives in DC(i+1)
3561             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3562      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3563             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3564      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3565             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3566      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3567             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3568      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3569 C Derivatives in DC(j)
3570             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3571      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3572             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3573      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3574             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3575      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3576             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3577      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3578 C Derivatives in DC(j+1) or DC(nres-1)
3579             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3580      &      -3.0d0*vryg(k,3)*ury)
3581             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3582      &      -3.0d0*vrzg(k,3)*ury)
3583             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3584      &      -3.0d0*vryg(k,3)*urz)
3585             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3586      &      -3.0d0*vrzg(k,3)*urz)
3587 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3588 cgrad              do l=1,4
3589 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3590 cgrad              enddo
3591 cgrad            endif
3592           enddo
3593           acipa(1,1)=a22
3594           acipa(1,2)=a23
3595           acipa(2,1)=a32
3596           acipa(2,2)=a33
3597           a22=-a22
3598           a23=-a23
3599           do l=1,2
3600             do k=1,3
3601               agg(k,l)=-agg(k,l)
3602               aggi(k,l)=-aggi(k,l)
3603               aggi1(k,l)=-aggi1(k,l)
3604               aggj(k,l)=-aggj(k,l)
3605               aggj1(k,l)=-aggj1(k,l)
3606             enddo
3607           enddo
3608           if (j.lt.nres-1) then
3609             a22=-a22
3610             a32=-a32
3611             do l=1,3,2
3612               do k=1,3
3613                 agg(k,l)=-agg(k,l)
3614                 aggi(k,l)=-aggi(k,l)
3615                 aggi1(k,l)=-aggi1(k,l)
3616                 aggj(k,l)=-aggj(k,l)
3617                 aggj1(k,l)=-aggj1(k,l)
3618               enddo
3619             enddo
3620           else
3621             a22=-a22
3622             a23=-a23
3623             a32=-a32
3624             a33=-a33
3625             do l=1,4
3626               do k=1,3
3627                 agg(k,l)=-agg(k,l)
3628                 aggi(k,l)=-aggi(k,l)
3629                 aggi1(k,l)=-aggi1(k,l)
3630                 aggj(k,l)=-aggj(k,l)
3631                 aggj1(k,l)=-aggj1(k,l)
3632               enddo
3633             enddo
3634           endif
3635           ENDIF ! WCORR
3636           IF (wel_loc.gt.0.0d0) THEN
3637 C Contribution to the local-electrostatic energy coming from the i-j pair
3638           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3639      &     +a33*muij(4)
3640 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3641 c     &                     ' eel_loc_ij',eel_loc_ij
3642
3643           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3644      &            'eelloc',i,j,eel_loc_ij
3645 c           if (eel_loc_ij.ne.0)
3646 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3647 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3648
3649           eel_loc=eel_loc+eel_loc_ij
3650 C Partial derivatives in virtual-bond dihedral angles gamma
3651           if (i.gt.1)
3652      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3653      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3654      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3655           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3656      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3657      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3658 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3659           do l=1,3
3660             ggg(l)=agg(l,1)*muij(1)+
3661      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3662             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3663             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3664 cgrad            ghalf=0.5d0*ggg(l)
3665 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3666 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3667           enddo
3668 cgrad          do k=i+1,j2
3669 cgrad            do l=1,3
3670 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3671 cgrad            enddo
3672 cgrad          enddo
3673 C Remaining derivatives of eello
3674           do l=1,3
3675             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3676      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3677             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3678      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3679             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3680      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3681             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3682      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3683           enddo
3684           ENDIF
3685 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3686 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3687           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3688      &       .and. num_conti.le.maxconts) then
3689 c            write (iout,*) i,j," entered corr"
3690 C
3691 C Calculate the contact function. The ith column of the array JCONT will
3692 C contain the numbers of atoms that make contacts with the atom I (of numbers
3693 C greater than I). The arrays FACONT and GACONT will contain the values of
3694 C the contact function and its derivative.
3695 c           r0ij=1.02D0*rpp(iteli,itelj)
3696 c           r0ij=1.11D0*rpp(iteli,itelj)
3697             r0ij=2.20D0*rpp(iteli,itelj)
3698 c           r0ij=1.55D0*rpp(iteli,itelj)
3699             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3700             if (fcont.gt.0.0D0) then
3701               num_conti=num_conti+1
3702               if (num_conti.gt.maxconts) then
3703                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3704      &                         ' will skip next contacts for this conf.'
3705               else
3706                 jcont_hb(num_conti,i)=j
3707 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3708 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3709                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3710      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3711 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3712 C  terms.
3713                 d_cont(num_conti,i)=rij
3714 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3715 C     --- Electrostatic-interaction matrix ---
3716                 a_chuj(1,1,num_conti,i)=a22
3717                 a_chuj(1,2,num_conti,i)=a23
3718                 a_chuj(2,1,num_conti,i)=a32
3719                 a_chuj(2,2,num_conti,i)=a33
3720 C     --- Gradient of rij
3721                 do kkk=1,3
3722                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3723                 enddo
3724                 kkll=0
3725                 do k=1,2
3726                   do l=1,2
3727                     kkll=kkll+1
3728                     do m=1,3
3729                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3730                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3731                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3732                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3733                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3734                     enddo
3735                   enddo
3736                 enddo
3737                 ENDIF
3738                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3739 C Calculate contact energies
3740                 cosa4=4.0D0*cosa
3741                 wij=cosa-3.0D0*cosb*cosg
3742                 cosbg1=cosb+cosg
3743                 cosbg2=cosb-cosg
3744 c               fac3=dsqrt(-ael6i)/r0ij**3
3745                 fac3=dsqrt(-ael6i)*r3ij
3746 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3747                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3748                 if (ees0tmp.gt.0) then
3749                   ees0pij=dsqrt(ees0tmp)
3750                 else
3751                   ees0pij=0
3752                 endif
3753 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3754                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3755                 if (ees0tmp.gt.0) then
3756                   ees0mij=dsqrt(ees0tmp)
3757                 else
3758                   ees0mij=0
3759                 endif
3760 c               ees0mij=0.0D0
3761                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3762                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3763 C Diagnostics. Comment out or remove after debugging!
3764 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3765 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3766 c               ees0m(num_conti,i)=0.0D0
3767 C End diagnostics.
3768 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3769 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3770 C Angular derivatives of the contact function
3771                 ees0pij1=fac3/ees0pij
3772                 ees0mij1=fac3/ees0mij
3773                 fac3p=-3.0D0*fac3*rrmij
3774                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3775                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3776 c               ees0mij1=0.0D0
3777                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3778                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3779                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3780                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3781                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3782                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3783                 ecosap=ecosa1+ecosa2
3784                 ecosbp=ecosb1+ecosb2
3785                 ecosgp=ecosg1+ecosg2
3786                 ecosam=ecosa1-ecosa2
3787                 ecosbm=ecosb1-ecosb2
3788                 ecosgm=ecosg1-ecosg2
3789 C Diagnostics
3790 c               ecosap=ecosa1
3791 c               ecosbp=ecosb1
3792 c               ecosgp=ecosg1
3793 c               ecosam=0.0D0
3794 c               ecosbm=0.0D0
3795 c               ecosgm=0.0D0
3796 C End diagnostics
3797                 facont_hb(num_conti,i)=fcont
3798                 fprimcont=fprimcont/rij
3799 cd              facont_hb(num_conti,i)=1.0D0
3800 C Following line is for diagnostics.
3801 cd              fprimcont=0.0D0
3802                 do k=1,3
3803                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3804                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3805                 enddo
3806                 do k=1,3
3807                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3808                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3809                 enddo
3810                 gggp(1)=gggp(1)+ees0pijp*xj
3811                 gggp(2)=gggp(2)+ees0pijp*yj
3812                 gggp(3)=gggp(3)+ees0pijp*zj
3813                 gggm(1)=gggm(1)+ees0mijp*xj
3814                 gggm(2)=gggm(2)+ees0mijp*yj
3815                 gggm(3)=gggm(3)+ees0mijp*zj
3816 C Derivatives due to the contact function
3817                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3818                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3819                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3820                 do k=1,3
3821 c
3822 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3823 c          following the change of gradient-summation algorithm.
3824 c
3825 cgrad                  ghalfp=0.5D0*gggp(k)
3826 cgrad                  ghalfm=0.5D0*gggm(k)
3827                   gacontp_hb1(k,num_conti,i)=!ghalfp
3828      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3829      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3830                   gacontp_hb2(k,num_conti,i)=!ghalfp
3831      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3832      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3833                   gacontp_hb3(k,num_conti,i)=gggp(k)
3834                   gacontm_hb1(k,num_conti,i)=!ghalfm
3835      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3836      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3837                   gacontm_hb2(k,num_conti,i)=!ghalfm
3838      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3839      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3840                   gacontm_hb3(k,num_conti,i)=gggm(k)
3841                 enddo
3842 C Diagnostics. Comment out or remove after debugging!
3843 cdiag           do k=1,3
3844 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3845 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3846 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3847 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3848 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3849 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3850 cdiag           enddo
3851               ENDIF ! wcorr
3852               endif  ! num_conti.le.maxconts
3853             endif  ! fcont.gt.0
3854           endif    ! j.gt.i+1
3855           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3856             do k=1,4
3857               do l=1,3
3858                 ghalf=0.5d0*agg(l,k)
3859                 aggi(l,k)=aggi(l,k)+ghalf
3860                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3861                 aggj(l,k)=aggj(l,k)+ghalf
3862               enddo
3863             enddo
3864             if (j.eq.nres-1 .and. i.lt.j-2) then
3865               do k=1,4
3866                 do l=1,3
3867                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3868                 enddo
3869               enddo
3870             endif
3871           endif
3872 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3873       return
3874       end
3875 C-----------------------------------------------------------------------------
3876       subroutine eturn3(i,eello_turn3)
3877 C Third- and fourth-order contributions from turns
3878       implicit real*8 (a-h,o-z)
3879       include 'DIMENSIONS'
3880       include 'COMMON.IOUNITS'
3881       include 'COMMON.GEO'
3882       include 'COMMON.VAR'
3883       include 'COMMON.LOCAL'
3884       include 'COMMON.CHAIN'
3885       include 'COMMON.DERIV'
3886       include 'COMMON.INTERACT'
3887       include 'COMMON.CONTACTS'
3888       include 'COMMON.TORSION'
3889       include 'COMMON.VECTORS'
3890       include 'COMMON.FFIELD'
3891       include 'COMMON.CONTROL'
3892       dimension ggg(3)
3893       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3894      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3895      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3896       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3897      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3898       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3899      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3900      &    num_conti,j1,j2
3901       j=i+2
3902 c      write (iout,*) "eturn3",i,j,j1,j2
3903       a_temp(1,1)=a22
3904       a_temp(1,2)=a23
3905       a_temp(2,1)=a32
3906       a_temp(2,2)=a33
3907 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3908 C
3909 C               Third-order contributions
3910 C
3911 C                 (i+2)o----(i+3)
3912 C                      | |
3913 C                      | |
3914 C                 (i+1)o----i
3915 C
3916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3917 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3918         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3919         call transpose2(auxmat(1,1),auxmat1(1,1))
3920         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3921         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3922         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3923      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3924 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3925 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3926 cd     &    ' eello_turn3_num',4*eello_turn3_num
3927 C Derivatives in gamma(i)
3928         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3929         call transpose2(auxmat2(1,1),auxmat3(1,1))
3930         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3931         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3932 C Derivatives in gamma(i+1)
3933         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3934         call transpose2(auxmat2(1,1),auxmat3(1,1))
3935         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3936         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3937      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3938 C Cartesian derivatives
3939         do l=1,3
3940 c            ghalf1=0.5d0*agg(l,1)
3941 c            ghalf2=0.5d0*agg(l,2)
3942 c            ghalf3=0.5d0*agg(l,3)
3943 c            ghalf4=0.5d0*agg(l,4)
3944           a_temp(1,1)=aggi(l,1)!+ghalf1
3945           a_temp(1,2)=aggi(l,2)!+ghalf2
3946           a_temp(2,1)=aggi(l,3)!+ghalf3
3947           a_temp(2,2)=aggi(l,4)!+ghalf4
3948           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3949           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3950      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3951           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3952           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3953           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3954           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3955           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3956           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3957      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3958           a_temp(1,1)=aggj(l,1)!+ghalf1
3959           a_temp(1,2)=aggj(l,2)!+ghalf2
3960           a_temp(2,1)=aggj(l,3)!+ghalf3
3961           a_temp(2,2)=aggj(l,4)!+ghalf4
3962           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3963           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3964      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3965           a_temp(1,1)=aggj1(l,1)
3966           a_temp(1,2)=aggj1(l,2)
3967           a_temp(2,1)=aggj1(l,3)
3968           a_temp(2,2)=aggj1(l,4)
3969           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3970           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3971      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3972         enddo
3973       return
3974       end
3975 C-------------------------------------------------------------------------------
3976       subroutine eturn4(i,eello_turn4)
3977 C Third- and fourth-order contributions from turns
3978       implicit real*8 (a-h,o-z)
3979       include 'DIMENSIONS'
3980       include 'COMMON.IOUNITS'
3981       include 'COMMON.GEO'
3982       include 'COMMON.VAR'
3983       include 'COMMON.LOCAL'
3984       include 'COMMON.CHAIN'
3985       include 'COMMON.DERIV'
3986       include 'COMMON.INTERACT'
3987       include 'COMMON.CONTACTS'
3988       include 'COMMON.TORSION'
3989       include 'COMMON.VECTORS'
3990       include 'COMMON.FFIELD'
3991       include 'COMMON.CONTROL'
3992       dimension ggg(3)
3993       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3994      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3995      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3996       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3997      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3998       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3999      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4000      &    num_conti,j1,j2
4001       j=i+3
4002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4003 C
4004 C               Fourth-order contributions
4005 C
4006 C                 (i+3)o----(i+4)
4007 C                     /  |
4008 C               (i+2)o   |
4009 C                     \  |
4010 C                 (i+1)o----i
4011 C
4012 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4013 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4014 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4015         a_temp(1,1)=a22
4016         a_temp(1,2)=a23
4017         a_temp(2,1)=a32
4018         a_temp(2,2)=a33
4019         iti1=itortyp(itype(i+1))
4020         iti2=itortyp(itype(i+2))
4021         iti3=itortyp(itype(i+3))
4022 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4023         call transpose2(EUg(1,1,i+1),e1t(1,1))
4024         call transpose2(Eug(1,1,i+2),e2t(1,1))
4025         call transpose2(Eug(1,1,i+3),e3t(1,1))
4026         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4027         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4028         s1=scalar2(b1(1,iti2),auxvec(1))
4029         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4030         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4031         s2=scalar2(b1(1,iti1),auxvec(1))
4032         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4033         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4034         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4035         eello_turn4=eello_turn4-(s1+s2+s3)
4036 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4037         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4038      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4039 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4040 cd     &    ' eello_turn4_num',8*eello_turn4_num
4041 C Derivatives in gamma(i)
4042         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4043         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4044         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4045         s1=scalar2(b1(1,iti2),auxvec(1))
4046         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4047         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4048         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4049 C Derivatives in gamma(i+1)
4050         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4051         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4052         s2=scalar2(b1(1,iti1),auxvec(1))
4053         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4054         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4055         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4056         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4057 C Derivatives in gamma(i+2)
4058         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4059         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4060         s1=scalar2(b1(1,iti2),auxvec(1))
4061         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4062         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4063         s2=scalar2(b1(1,iti1),auxvec(1))
4064         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4065         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4066         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4067         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4068 C Cartesian derivatives
4069 C Derivatives of this turn contributions in DC(i+2)
4070         if (j.lt.nres-1) then
4071           do l=1,3
4072             a_temp(1,1)=agg(l,1)
4073             a_temp(1,2)=agg(l,2)
4074             a_temp(2,1)=agg(l,3)
4075             a_temp(2,2)=agg(l,4)
4076             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4077             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4078             s1=scalar2(b1(1,iti2),auxvec(1))
4079             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4080             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4081             s2=scalar2(b1(1,iti1),auxvec(1))
4082             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4083             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4084             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4085             ggg(l)=-(s1+s2+s3)
4086             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4087           enddo
4088         endif
4089 C Remaining derivatives of this turn contribution
4090         do l=1,3
4091           a_temp(1,1)=aggi(l,1)
4092           a_temp(1,2)=aggi(l,2)
4093           a_temp(2,1)=aggi(l,3)
4094           a_temp(2,2)=aggi(l,4)
4095           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4096           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4097           s1=scalar2(b1(1,iti2),auxvec(1))
4098           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4099           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4100           s2=scalar2(b1(1,iti1),auxvec(1))
4101           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4102           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4103           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4104           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4105           a_temp(1,1)=aggi1(l,1)
4106           a_temp(1,2)=aggi1(l,2)
4107           a_temp(2,1)=aggi1(l,3)
4108           a_temp(2,2)=aggi1(l,4)
4109           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4110           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4111           s1=scalar2(b1(1,iti2),auxvec(1))
4112           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4113           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4114           s2=scalar2(b1(1,iti1),auxvec(1))
4115           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4116           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4117           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4118           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4119           a_temp(1,1)=aggj(l,1)
4120           a_temp(1,2)=aggj(l,2)
4121           a_temp(2,1)=aggj(l,3)
4122           a_temp(2,2)=aggj(l,4)
4123           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4124           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4125           s1=scalar2(b1(1,iti2),auxvec(1))
4126           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4127           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4128           s2=scalar2(b1(1,iti1),auxvec(1))
4129           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4130           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4131           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4132           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4133           a_temp(1,1)=aggj1(l,1)
4134           a_temp(1,2)=aggj1(l,2)
4135           a_temp(2,1)=aggj1(l,3)
4136           a_temp(2,2)=aggj1(l,4)
4137           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4138           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4139           s1=scalar2(b1(1,iti2),auxvec(1))
4140           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4141           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4142           s2=scalar2(b1(1,iti1),auxvec(1))
4143           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4144           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4145           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4146 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4147           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4148         enddo
4149       return
4150       end
4151 C-----------------------------------------------------------------------------
4152       subroutine vecpr(u,v,w)
4153       implicit real*8(a-h,o-z)
4154       dimension u(3),v(3),w(3)
4155       w(1)=u(2)*v(3)-u(3)*v(2)
4156       w(2)=-u(1)*v(3)+u(3)*v(1)
4157       w(3)=u(1)*v(2)-u(2)*v(1)
4158       return
4159       end
4160 C-----------------------------------------------------------------------------
4161       subroutine unormderiv(u,ugrad,unorm,ungrad)
4162 C This subroutine computes the derivatives of a normalized vector u, given
4163 C the derivatives computed without normalization conditions, ugrad. Returns
4164 C ungrad.
4165       implicit none
4166       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4167       double precision vec(3)
4168       double precision scalar
4169       integer i,j
4170 c      write (2,*) 'ugrad',ugrad
4171 c      write (2,*) 'u',u
4172       do i=1,3
4173         vec(i)=scalar(ugrad(1,i),u(1))
4174       enddo
4175 c      write (2,*) 'vec',vec
4176       do i=1,3
4177         do j=1,3
4178           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4179         enddo
4180       enddo
4181 c      write (2,*) 'ungrad',ungrad
4182       return
4183       end
4184 C-----------------------------------------------------------------------------
4185       subroutine escp_soft_sphere(evdw2,evdw2_14)
4186 C
4187 C This subroutine calculates the excluded-volume interaction energy between
4188 C peptide-group centers and side chains and its gradient in virtual-bond and
4189 C side-chain vectors.
4190 C
4191       implicit real*8 (a-h,o-z)
4192       include 'DIMENSIONS'
4193       include 'COMMON.GEO'
4194       include 'COMMON.VAR'
4195       include 'COMMON.LOCAL'
4196       include 'COMMON.CHAIN'
4197       include 'COMMON.DERIV'
4198       include 'COMMON.INTERACT'
4199       include 'COMMON.FFIELD'
4200       include 'COMMON.IOUNITS'
4201       include 'COMMON.CONTROL'
4202       dimension ggg(3)
4203       evdw2=0.0D0
4204       evdw2_14=0.0d0
4205       r0_scp=4.5d0
4206 cd    print '(a)','Enter ESCP'
4207 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4208 C      do xshift=-1,1
4209 C      do yshift=-1,1
4210 C      do zshift=-1,1
4211       do i=iatscp_s,iatscp_e
4212         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4213         iteli=itel(i)
4214         xi=0.5D0*(c(1,i)+c(1,i+1))
4215         yi=0.5D0*(c(2,i)+c(2,i+1))
4216         zi=0.5D0*(c(3,i)+c(3,i+1))
4217 C Return atom into box, boxxsize is size of box in x dimension
4218 c  134   continue
4219 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4220 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4221 C Condition for being inside the proper box
4222 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4223 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4224 c        go to 134
4225 c        endif
4226 c  135   continue
4227 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4228 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4229 C Condition for being inside the proper box
4230 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4231 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4232 c        go to 135
4233 c c       endif
4234 c  136   continue
4235 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4236 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4237 cC Condition for being inside the proper box
4238 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4239 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4240 c        go to 136
4241 c        endif
4242           xi=mod(xi,boxxsize)
4243           if (xi.lt.0) xi=xi+boxxsize
4244           yi=mod(yi,boxysize)
4245           if (yi.lt.0) yi=yi+boxysize
4246           zi=mod(zi,boxzsize)
4247           if (zi.lt.0) zi=zi+boxzsize
4248 C          xi=xi+xshift*boxxsize
4249 C          yi=yi+yshift*boxysize
4250 C          zi=zi+zshift*boxzsize
4251         do iint=1,nscp_gr(i)
4252
4253         do j=iscpstart(i,iint),iscpend(i,iint)
4254           if (itype(j).eq.ntyp1) cycle
4255           itypj=iabs(itype(j))
4256 C Uncomment following three lines for SC-p interactions
4257 c         xj=c(1,nres+j)-xi
4258 c         yj=c(2,nres+j)-yi
4259 c         zj=c(3,nres+j)-zi
4260 C Uncomment following three lines for Ca-p interactions
4261           xj=c(1,j)
4262           yj=c(2,j)
4263           zj=c(3,j)
4264 c  174   continue
4265 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4266 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4267 C Condition for being inside the proper box
4268 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4269 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4270 c        go to 174
4271 c        endif
4272 c  175   continue
4273 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4274 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4275 cC Condition for being inside the proper box
4276 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4277 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4278 c        go to 175
4279 c        endif
4280 c  176   continue
4281 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4282 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4283 C Condition for being inside the proper box
4284 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4285 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4286 c        go to 176
4287           xj=mod(xj,boxxsize)
4288           if (xj.lt.0) xj=xj+boxxsize
4289           yj=mod(yj,boxysize)
4290           if (yj.lt.0) yj=yj+boxysize
4291           zj=mod(zj,boxzsize)
4292           if (zj.lt.0) zj=zj+boxzsize
4293       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4294       xj_safe=xj
4295       yj_safe=yj
4296       zj_safe=zj
4297       subchap=0
4298       do xshift=-1,1
4299       do yshift=-1,1
4300       do zshift=-1,1
4301           xj=xj_safe+xshift*boxxsize
4302           yj=yj_safe+yshift*boxysize
4303           zj=zj_safe+zshift*boxzsize
4304           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4305           if(dist_temp.lt.dist_init) then
4306             dist_init=dist_temp
4307             xj_temp=xj
4308             yj_temp=yj
4309             zj_temp=zj
4310             subchap=1
4311           endif
4312        enddo
4313        enddo
4314        enddo
4315        if (subchap.eq.1) then
4316           xj=xj_temp-xi
4317           yj=yj_temp-yi
4318           zj=zj_temp-zi
4319        else
4320           xj=xj_safe-xi
4321           yj=yj_safe-yi
4322           zj=zj_safe-zi
4323        endif
4324 c c       endif
4325 C          xj=xj-xi
4326 C          yj=yj-yi
4327 C          zj=zj-zi
4328           rij=xj*xj+yj*yj+zj*zj
4329
4330           r0ij=r0_scp
4331           r0ijsq=r0ij*r0ij
4332           if (rij.lt.r0ijsq) then
4333             evdwij=0.25d0*(rij-r0ijsq)**2
4334             fac=rij-r0ijsq
4335           else
4336             evdwij=0.0d0
4337             fac=0.0d0
4338           endif
4339           evdw2=evdw2+evdwij
4340 C
4341 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4342 C
4343           ggg(1)=xj*fac
4344           ggg(2)=yj*fac
4345           ggg(3)=zj*fac
4346 cgrad          if (j.lt.i) then
4347 cd          write (iout,*) 'j<i'
4348 C Uncomment following three lines for SC-p interactions
4349 c           do k=1,3
4350 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4351 c           enddo
4352 cgrad          else
4353 cd          write (iout,*) 'j>i'
4354 cgrad            do k=1,3
4355 cgrad              ggg(k)=-ggg(k)
4356 C Uncomment following line for SC-p interactions
4357 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4358 cgrad            enddo
4359 cgrad          endif
4360 cgrad          do k=1,3
4361 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4362 cgrad          enddo
4363 cgrad          kstart=min0(i+1,j)
4364 cgrad          kend=max0(i-1,j-1)
4365 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4366 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4367 cgrad          do k=kstart,kend
4368 cgrad            do l=1,3
4369 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4370 cgrad            enddo
4371 cgrad          enddo
4372           do k=1,3
4373             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4374             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4375           enddo
4376         enddo
4377
4378         enddo ! iint
4379       enddo ! i
4380 C      enddo !zshift
4381 C      enddo !yshift
4382 C      enddo !xshift
4383       return
4384       end
4385 C-----------------------------------------------------------------------------
4386       subroutine escp(evdw2,evdw2_14)
4387 C
4388 C This subroutine calculates the excluded-volume interaction energy between
4389 C peptide-group centers and side chains and its gradient in virtual-bond and
4390 C side-chain vectors.
4391 C
4392       implicit real*8 (a-h,o-z)
4393       include 'DIMENSIONS'
4394       include 'COMMON.GEO'
4395       include 'COMMON.VAR'
4396       include 'COMMON.LOCAL'
4397       include 'COMMON.CHAIN'
4398       include 'COMMON.DERIV'
4399       include 'COMMON.INTERACT'
4400       include 'COMMON.FFIELD'
4401       include 'COMMON.IOUNITS'
4402       include 'COMMON.CONTROL'
4403       include 'COMMON.SPLITELE'
4404       dimension ggg(3)
4405       evdw2=0.0D0
4406       evdw2_14=0.0d0
4407 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4408 cd    print '(a)','Enter ESCP'
4409 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4410 C      do xshift=-1,1
4411 C      do yshift=-1,1
4412 C      do zshift=-1,1
4413       do i=iatscp_s,iatscp_e
4414         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4415         iteli=itel(i)
4416         xi=0.5D0*(c(1,i)+c(1,i+1))
4417         yi=0.5D0*(c(2,i)+c(2,i+1))
4418         zi=0.5D0*(c(3,i)+c(3,i+1))
4419           xi=mod(xi,boxxsize)
4420           if (xi.lt.0) xi=xi+boxxsize
4421           yi=mod(yi,boxysize)
4422           if (yi.lt.0) yi=yi+boxysize
4423           zi=mod(zi,boxzsize)
4424           if (zi.lt.0) zi=zi+boxzsize
4425 c          xi=xi+xshift*boxxsize
4426 c          yi=yi+yshift*boxysize
4427 c          zi=zi+zshift*boxzsize
4428 c        print *,xi,yi,zi,'polozenie i'
4429 C Return atom into box, boxxsize is size of box in x dimension
4430 c  134   continue
4431 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4432 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4433 C Condition for being inside the proper box
4434 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4435 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4436 c        go to 134
4437 c        endif
4438 c  135   continue
4439 c          print *,xi,boxxsize,"pierwszy"
4440
4441 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4442 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4443 C Condition for being inside the proper box
4444 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4445 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4446 c        go to 135
4447 c        endif
4448 c  136   continue
4449 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4450 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4451 C Condition for being inside the proper box
4452 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4453 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4454 c        go to 136
4455 c        endif
4456         do iint=1,nscp_gr(i)
4457
4458         do j=iscpstart(i,iint),iscpend(i,iint)
4459           itypj=iabs(itype(j))
4460           if (itypj.eq.ntyp1) cycle
4461 C Uncomment following three lines for SC-p interactions
4462 c         xj=c(1,nres+j)-xi
4463 c         yj=c(2,nres+j)-yi
4464 c         zj=c(3,nres+j)-zi
4465 C Uncomment following three lines for Ca-p interactions
4466           xj=c(1,j)
4467           yj=c(2,j)
4468           zj=c(3,j)
4469           xj=mod(xj,boxxsize)
4470           if (xj.lt.0) xj=xj+boxxsize
4471           yj=mod(yj,boxysize)
4472           if (yj.lt.0) yj=yj+boxysize
4473           zj=mod(zj,boxzsize)
4474           if (zj.lt.0) zj=zj+boxzsize
4475 c  174   continue
4476 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4477 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4478 C Condition for being inside the proper box
4479 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4480 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4481 c        go to 174
4482 c        endif
4483 c  175   continue
4484 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4485 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4486 cC Condition for being inside the proper box
4487 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4488 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4489 c        go to 175
4490 c        endif
4491 c  176   continue
4492 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4493 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4494 C Condition for being inside the proper box
4495 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4496 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4497 c        go to 176
4498 c        endif
4499 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4500       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4501       xj_safe=xj
4502       yj_safe=yj
4503       zj_safe=zj
4504       subchap=0
4505       do xshift=-1,1
4506       do yshift=-1,1
4507       do zshift=-1,1
4508           xj=xj_safe+xshift*boxxsize
4509           yj=yj_safe+yshift*boxysize
4510           zj=zj_safe+zshift*boxzsize
4511           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4512           if(dist_temp.lt.dist_init) then
4513             dist_init=dist_temp
4514             xj_temp=xj
4515             yj_temp=yj
4516             zj_temp=zj
4517             subchap=1
4518           endif
4519        enddo
4520        enddo
4521        enddo
4522        if (subchap.eq.1) then
4523           xj=xj_temp-xi
4524           yj=yj_temp-yi
4525           zj=zj_temp-zi
4526        else
4527           xj=xj_safe-xi
4528           yj=yj_safe-yi
4529           zj=zj_safe-zi
4530        endif
4531 c          print *,xj,yj,zj,'polozenie j'
4532           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4533 c          print *,rrij
4534           sss=sscale(1.0d0/(dsqrt(rrij)))
4535 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4536 c          if (sss.eq.0) print *,'czasem jest OK'
4537           if (sss.le.0.0d0) cycle
4538           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4539           fac=rrij**expon2
4540           e1=fac*fac*aad(itypj,iteli)
4541           e2=fac*bad(itypj,iteli)
4542           if (iabs(j-i) .le. 2) then
4543             e1=scal14*e1
4544             e2=scal14*e2
4545             evdw2_14=evdw2_14+(e1+e2)*sss
4546           endif
4547           evdwij=e1+e2
4548           evdw2=evdw2+evdwij*sss
4549           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4550      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4551      &       bad(itypj,iteli)
4552 C
4553 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4554 C
4555           fac=-(evdwij+e1)*rrij*sss
4556           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4557           ggg(1)=xj*fac
4558           ggg(2)=yj*fac
4559           ggg(3)=zj*fac
4560 cgrad          if (j.lt.i) then
4561 cd          write (iout,*) 'j<i'
4562 C Uncomment following three lines for SC-p interactions
4563 c           do k=1,3
4564 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4565 c           enddo
4566 cgrad          else
4567 cd          write (iout,*) 'j>i'
4568 cgrad            do k=1,3
4569 cgrad              ggg(k)=-ggg(k)
4570 C Uncomment following line for SC-p interactions
4571 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4572 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4573 cgrad            enddo
4574 cgrad          endif
4575 cgrad          do k=1,3
4576 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4577 cgrad          enddo
4578 cgrad          kstart=min0(i+1,j)
4579 cgrad          kend=max0(i-1,j-1)
4580 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4581 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4582 cgrad          do k=kstart,kend
4583 cgrad            do l=1,3
4584 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4585 cgrad            enddo
4586 cgrad          enddo
4587           do k=1,3
4588             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4589             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4590           enddo
4591 c        endif !endif for sscale cutoff
4592         enddo ! j
4593
4594         enddo ! iint
4595       enddo ! i
4596 c      enddo !zshift
4597 c      enddo !yshift
4598 c      enddo !xshift
4599       do i=1,nct
4600         do j=1,3
4601           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4602           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4603           gradx_scp(j,i)=expon*gradx_scp(j,i)
4604         enddo
4605       enddo
4606 C******************************************************************************
4607 C
4608 C                              N O T E !!!
4609 C
4610 C To save time the factor EXPON has been extracted from ALL components
4611 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4612 C use!
4613 C
4614 C******************************************************************************
4615       return
4616       end
4617 C--------------------------------------------------------------------------
4618       subroutine edis(ehpb)
4619 C
4620 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4621 C
4622       implicit real*8 (a-h,o-z)
4623       include 'DIMENSIONS'
4624       include 'COMMON.SBRIDGE'
4625       include 'COMMON.CHAIN'
4626       include 'COMMON.DERIV'
4627       include 'COMMON.VAR'
4628       include 'COMMON.INTERACT'
4629       include 'COMMON.IOUNITS'
4630       dimension ggg(3)
4631       ehpb=0.0D0
4632 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4633 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4634       if (link_end.eq.0) return
4635       do i=link_start,link_end
4636 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4637 C CA-CA distance used in regularization of structure.
4638         ii=ihpb(i)
4639         jj=jhpb(i)
4640 C iii and jjj point to the residues for which the distance is assigned.
4641         if (ii.gt.nres) then
4642           iii=ii-nres
4643           jjj=jj-nres
4644         else
4645           iii=ii
4646           jjj=jj
4647         endif
4648 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4649 c     &    dhpb(i),dhpb1(i),forcon(i)
4650 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4651 C    distance and angle dependent SS bond potential.
4652         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4653      & iabs(itype(jjj)).eq.1) then
4654 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4655 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4656         if (.not.dyn_ss .and. i.le.nss) then
4657 C 15/02/13 CC dynamic SSbond - additional check
4658          if (ii.gt.nres
4659      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4660 >>>>>>> f5379d3246c4bd95e946c4d35d4a1c13e329c4cb
4661           call ssbond_ene(iii,jjj,eij)
4662           ehpb=ehpb+2*eij
4663          endif
4664 cd          write (iout,*) "eij",eij
4665         else
4666 C Calculate the distance between the two points and its difference from the
4667 C target distance.
4668           dd=dist(ii,jj)
4669             rdis=dd-dhpb(i)
4670 C Get the force constant corresponding to this distance.
4671             waga=forcon(i)
4672 C Calculate the contribution to energy.
4673             ehpb=ehpb+waga*rdis*rdis
4674 C
4675 C Evaluate gradient.
4676 C
4677             fac=waga*rdis/dd
4678 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4679 cd   &   ' waga=',waga,' fac=',fac
4680             do j=1,3
4681               ggg(j)=fac*(c(j,jj)-c(j,ii))
4682             enddo
4683 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4684 C If this is a SC-SC distance, we need to calculate the contributions to the
4685 C Cartesian gradient in the SC vectors (ghpbx).
4686           if (iii.lt.ii) then
4687           do j=1,3
4688             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4689             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4690           enddo
4691           endif
4692 cgrad        do j=iii,jjj-1
4693 cgrad          do k=1,3
4694 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4695 cgrad          enddo
4696 cgrad        enddo
4697           do k=1,3
4698             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4699             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4700           enddo
4701         endif
4702       enddo
4703       ehpb=0.5D0*ehpb
4704       return
4705       end
4706 C--------------------------------------------------------------------------
4707       subroutine ssbond_ene(i,j,eij)
4708 C
4709 C Calculate the distance and angle dependent SS-bond potential energy
4710 C using a free-energy function derived based on RHF/6-31G** ab initio
4711 C calculations of diethyl disulfide.
4712 C
4713 C A. Liwo and U. Kozlowska, 11/24/03
4714 C
4715       implicit real*8 (a-h,o-z)
4716       include 'DIMENSIONS'
4717       include 'COMMON.SBRIDGE'
4718       include 'COMMON.CHAIN'
4719       include 'COMMON.DERIV'
4720       include 'COMMON.LOCAL'
4721       include 'COMMON.INTERACT'
4722       include 'COMMON.VAR'
4723       include 'COMMON.IOUNITS'
4724       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4725       itypi=iabs(itype(i))
4726       xi=c(1,nres+i)
4727       yi=c(2,nres+i)
4728       zi=c(3,nres+i)
4729       dxi=dc_norm(1,nres+i)
4730       dyi=dc_norm(2,nres+i)
4731       dzi=dc_norm(3,nres+i)
4732 c      dsci_inv=dsc_inv(itypi)
4733       dsci_inv=vbld_inv(nres+i)
4734       itypj=iabs(itype(j))
4735 c      dscj_inv=dsc_inv(itypj)
4736       dscj_inv=vbld_inv(nres+j)
4737       xj=c(1,nres+j)-xi
4738       yj=c(2,nres+j)-yi
4739       zj=c(3,nres+j)-zi
4740       dxj=dc_norm(1,nres+j)
4741       dyj=dc_norm(2,nres+j)
4742       dzj=dc_norm(3,nres+j)
4743       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4744       rij=dsqrt(rrij)
4745       erij(1)=xj*rij
4746       erij(2)=yj*rij
4747       erij(3)=zj*rij
4748       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4749       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4750       om12=dxi*dxj+dyi*dyj+dzi*dzj
4751       do k=1,3
4752         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4753         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4754       enddo
4755       rij=1.0d0/rij
4756       deltad=rij-d0cm
4757       deltat1=1.0d0-om1
4758       deltat2=1.0d0+om2
4759       deltat12=om2-om1+2.0d0
4760       cosphi=om12-om1*om2
4761       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4762      &  +akct*deltad*deltat12
4763      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4764 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4765 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4766 c     &  " deltat12",deltat12," eij",eij
4767       ed=2*akcm*deltad+akct*deltat12
4768       pom1=akct*deltad
4769       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4770       eom1=-2*akth*deltat1-pom1-om2*pom2
4771       eom2= 2*akth*deltat2+pom1-om1*pom2
4772       eom12=pom2
4773       do k=1,3
4774         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4775         ghpbx(k,i)=ghpbx(k,i)-ggk
4776      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4777      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4778         ghpbx(k,j)=ghpbx(k,j)+ggk
4779      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4780      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4781         ghpbc(k,i)=ghpbc(k,i)-ggk
4782         ghpbc(k,j)=ghpbc(k,j)+ggk
4783       enddo
4784 C
4785 C Calculate the components of the gradient in DC and X
4786 C
4787 cgrad      do k=i,j-1
4788 cgrad        do l=1,3
4789 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4790 cgrad        enddo
4791 cgrad      enddo
4792       return
4793       end
4794 C--------------------------------------------------------------------------
4795       subroutine ebond(estr)
4796 c
4797 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4798 c
4799       implicit real*8 (a-h,o-z)
4800       include 'DIMENSIONS'
4801       include 'COMMON.LOCAL'
4802       include 'COMMON.GEO'
4803       include 'COMMON.INTERACT'
4804       include 'COMMON.DERIV'
4805       include 'COMMON.VAR'
4806       include 'COMMON.CHAIN'
4807       include 'COMMON.IOUNITS'
4808       include 'COMMON.NAMES'
4809       include 'COMMON.FFIELD'
4810       include 'COMMON.CONTROL'
4811       include 'COMMON.SETUP'
4812       double precision u(3),ud(3)
4813       estr=0.0d0
4814       estr1=0.0d0
4815       do i=ibondp_start,ibondp_end
4816         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4817 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4818 c          do j=1,3
4819 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4820 c     &      *dc(j,i-1)/vbld(i)
4821 c          enddo
4822 c          if (energy_dec) write(iout,*)
4823 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4824 c        else
4825 C       Checking if it involves dummy (NH3+ or COO-) group
4826          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4827 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
4828         diff = vbld(i)-vbldpDUM
4829          else
4830 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
4831         diff = vbld(i)-vbldp0
4832          endif
4833         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4834      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4835         estr=estr+diff*diff
4836         do j=1,3
4837           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4838         enddo
4839 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4840 c        endif
4841       enddo
4842       estr=0.5d0*AKP*estr+estr1
4843 c
4844 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4845 c
4846       do i=ibond_start,ibond_end
4847         iti=iabs(itype(i))
4848         if (iti.ne.10 .and. iti.ne.ntyp1) then
4849           nbi=nbondterm(iti)
4850           if (nbi.eq.1) then
4851             diff=vbld(i+nres)-vbldsc0(1,iti)
4852             if (energy_dec)  write (iout,*)
4853      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4854      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4855             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4856             do j=1,3
4857               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4858             enddo
4859           else
4860             do j=1,nbi
4861               diff=vbld(i+nres)-vbldsc0(j,iti)
4862               ud(j)=aksc(j,iti)*diff
4863               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4864             enddo
4865             uprod=u(1)
4866             do j=2,nbi
4867               uprod=uprod*u(j)
4868             enddo
4869             usum=0.0d0
4870             usumsqder=0.0d0
4871             do j=1,nbi
4872               uprod1=1.0d0
4873               uprod2=1.0d0
4874               do k=1,nbi
4875                 if (k.ne.j) then
4876                   uprod1=uprod1*u(k)
4877                   uprod2=uprod2*u(k)*u(k)
4878                 endif
4879               enddo
4880               usum=usum+uprod1
4881               usumsqder=usumsqder+ud(j)*uprod2
4882             enddo
4883             estr=estr+uprod/usum
4884             do j=1,3
4885              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4886             enddo
4887           endif
4888         endif
4889       enddo
4890       return
4891       end
4892 #ifdef CRYST_THETA
4893 C--------------------------------------------------------------------------
4894       subroutine ebend(etheta)
4895 C
4896 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4897 C angles gamma and its derivatives in consecutive thetas and gammas.
4898 C
4899       implicit real*8 (a-h,o-z)
4900       include 'DIMENSIONS'
4901       include 'COMMON.LOCAL'
4902       include 'COMMON.GEO'
4903       include 'COMMON.INTERACT'
4904       include 'COMMON.DERIV'
4905       include 'COMMON.VAR'
4906       include 'COMMON.CHAIN'
4907       include 'COMMON.IOUNITS'
4908       include 'COMMON.NAMES'
4909       include 'COMMON.FFIELD'
4910       include 'COMMON.CONTROL'
4911       common /calcthet/ term1,term2,termm,diffak,ratak,
4912      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4913      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4914       double precision y(2),z(2)
4915       delta=0.02d0*pi
4916 c      time11=dexp(-2*time)
4917 c      time12=1.0d0
4918       etheta=0.0D0
4919 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4920       do i=ithet_start,ithet_end
4921         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4922      &  .or.itype(i).eq.ntyp1) cycle
4923 C Zero the energy function and its derivative at 0 or pi.
4924         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4925         it=itype(i-1)
4926         ichir1=isign(1,itype(i-2))
4927         ichir2=isign(1,itype(i))
4928          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4929          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4930          if (itype(i-1).eq.10) then
4931           itype1=isign(10,itype(i-2))
4932           ichir11=isign(1,itype(i-2))
4933           ichir12=isign(1,itype(i-2))
4934           itype2=isign(10,itype(i))
4935           ichir21=isign(1,itype(i))
4936           ichir22=isign(1,itype(i))
4937          endif
4938
4939         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4940 #ifdef OSF
4941           phii=phi(i)
4942           if (phii.ne.phii) phii=150.0
4943 #else
4944           phii=phi(i)
4945 #endif
4946           y(1)=dcos(phii)
4947           y(2)=dsin(phii)
4948         else
4949           y(1)=0.0D0
4950           y(2)=0.0D0
4951         endif
4952         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4953 #ifdef OSF
4954           phii1=phi(i+1)
4955           if (phii1.ne.phii1) phii1=150.0
4956           phii1=pinorm(phii1)
4957           z(1)=cos(phii1)
4958 #else
4959           phii1=phi(i+1)
4960 #endif
4961           z(1)=dcos(phii1)
4962           z(2)=dsin(phii1)
4963         else
4964           z(1)=0.0D0
4965           z(2)=0.0D0
4966         endif
4967 C Calculate the "mean" value of theta from the part of the distribution
4968 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4969 C In following comments this theta will be referred to as t_c.
4970         thet_pred_mean=0.0d0
4971         do k=1,2
4972             athetk=athet(k,it,ichir1,ichir2)
4973             bthetk=bthet(k,it,ichir1,ichir2)
4974           if (it.eq.10) then
4975              athetk=athet(k,itype1,ichir11,ichir12)
4976              bthetk=bthet(k,itype2,ichir21,ichir22)
4977           endif
4978          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4979 c         write(iout,*) 'chuj tu', y(k),z(k)
4980         enddo
4981         dthett=thet_pred_mean*ssd
4982         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4983 C Derivatives of the "mean" values in gamma1 and gamma2.
4984         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4985      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4986          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4987      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4988          if (it.eq.10) then
4989       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4990      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4991         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4992      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4993          endif
4994         if (theta(i).gt.pi-delta) then
4995           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4996      &         E_tc0)
4997           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4998           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4999           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5000      &        E_theta)
5001           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5002      &        E_tc)
5003         else if (theta(i).lt.delta) then
5004           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5005           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5006           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5007      &        E_theta)
5008           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5009           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5010      &        E_tc)
5011         else
5012           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5013      &        E_theta,E_tc)
5014         endif
5015         etheta=etheta+ethetai
5016         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5017      &      'ebend',i,ethetai,theta(i),itype(i)
5018         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5019         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5020         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5021       enddo
5022 C Ufff.... We've done all this!!!
5023       return
5024       end
5025 C---------------------------------------------------------------------------
5026       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5027      &     E_tc)
5028       implicit real*8 (a-h,o-z)
5029       include 'DIMENSIONS'
5030       include 'COMMON.LOCAL'
5031       include 'COMMON.IOUNITS'
5032       common /calcthet/ term1,term2,termm,diffak,ratak,
5033      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5034      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5035 C Calculate the contributions to both Gaussian lobes.
5036 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5037 C The "polynomial part" of the "standard deviation" of this part of
5038 C the distributioni.
5039 ccc        write (iout,*) thetai,thet_pred_mean
5040         sig=polthet(3,it)
5041         do j=2,0,-1
5042           sig=sig*thet_pred_mean+polthet(j,it)
5043         enddo
5044 C Derivative of the "interior part" of the "standard deviation of the"
5045 C gamma-dependent Gaussian lobe in t_c.
5046         sigtc=3*polthet(3,it)
5047         do j=2,1,-1
5048           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5049         enddo
5050         sigtc=sig*sigtc
5051 C Set the parameters of both Gaussian lobes of the distribution.
5052 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5053         fac=sig*sig+sigc0(it)
5054         sigcsq=fac+fac
5055         sigc=1.0D0/sigcsq
5056 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5057         sigsqtc=-4.0D0*sigcsq*sigtc
5058 c       print *,i,sig,sigtc,sigsqtc
5059 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5060         sigtc=-sigtc/(fac*fac)
5061 C Following variable is sigma(t_c)**(-2)
5062         sigcsq=sigcsq*sigcsq
5063         sig0i=sig0(it)
5064         sig0inv=1.0D0/sig0i**2
5065         delthec=thetai-thet_pred_mean
5066         delthe0=thetai-theta0i
5067         term1=-0.5D0*sigcsq*delthec*delthec
5068         term2=-0.5D0*sig0inv*delthe0*delthe0
5069 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5070 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5071 C NaNs in taking the logarithm. We extract the largest exponent which is added
5072 C to the energy (this being the log of the distribution) at the end of energy
5073 C term evaluation for this virtual-bond angle.
5074         if (term1.gt.term2) then
5075           termm=term1
5076           term2=dexp(term2-termm)
5077           term1=1.0d0
5078         else
5079           termm=term2
5080           term1=dexp(term1-termm)
5081           term2=1.0d0
5082         endif
5083 C The ratio between the gamma-independent and gamma-dependent lobes of
5084 C the distribution is a Gaussian function of thet_pred_mean too.
5085         diffak=gthet(2,it)-thet_pred_mean
5086         ratak=diffak/gthet(3,it)**2
5087         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5088 C Let's differentiate it in thet_pred_mean NOW.
5089         aktc=ak*ratak
5090 C Now put together the distribution terms to make complete distribution.
5091         termexp=term1+ak*term2
5092         termpre=sigc+ak*sig0i
5093 C Contribution of the bending energy from this theta is just the -log of
5094 C the sum of the contributions from the two lobes and the pre-exponential
5095 C factor. Simple enough, isn't it?
5096         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5097 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5098 C NOW the derivatives!!!
5099 C 6/6/97 Take into account the deformation.
5100         E_theta=(delthec*sigcsq*term1
5101      &       +ak*delthe0*sig0inv*term2)/termexp
5102         E_tc=((sigtc+aktc*sig0i)/termpre
5103      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5104      &       aktc*term2)/termexp)
5105       return
5106       end
5107 c-----------------------------------------------------------------------------
5108       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5109       implicit real*8 (a-h,o-z)
5110       include 'DIMENSIONS'
5111       include 'COMMON.LOCAL'
5112       include 'COMMON.IOUNITS'
5113       common /calcthet/ term1,term2,termm,diffak,ratak,
5114      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5115      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5116       delthec=thetai-thet_pred_mean
5117       delthe0=thetai-theta0i
5118 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5119       t3 = thetai-thet_pred_mean
5120       t6 = t3**2
5121       t9 = term1
5122       t12 = t3*sigcsq
5123       t14 = t12+t6*sigsqtc
5124       t16 = 1.0d0
5125       t21 = thetai-theta0i
5126       t23 = t21**2
5127       t26 = term2
5128       t27 = t21*t26
5129       t32 = termexp
5130       t40 = t32**2
5131       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5132      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5133      & *(-t12*t9-ak*sig0inv*t27)
5134       return
5135       end
5136 #else
5137 C--------------------------------------------------------------------------
5138       subroutine ebend(etheta)
5139 C
5140 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5141 C angles gamma and its derivatives in consecutive thetas and gammas.
5142 C ab initio-derived potentials from
5143 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5144 C
5145       implicit real*8 (a-h,o-z)
5146       include 'DIMENSIONS'
5147       include 'COMMON.LOCAL'
5148       include 'COMMON.GEO'
5149       include 'COMMON.INTERACT'
5150       include 'COMMON.DERIV'
5151       include 'COMMON.VAR'
5152       include 'COMMON.CHAIN'
5153       include 'COMMON.IOUNITS'
5154       include 'COMMON.NAMES'
5155       include 'COMMON.FFIELD'
5156       include 'COMMON.CONTROL'
5157       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5158      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5159      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5160      & sinph1ph2(maxdouble,maxdouble)
5161       logical lprn /.false./, lprn1 /.false./
5162       etheta=0.0D0
5163       do i=ithet_start,ithet_end
5164 c        print *,i,itype(i-1),itype(i),itype(i-2)
5165         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5166      &  .or.itype(i).eq.ntyp1) cycle
5167 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5168
5169         if (iabs(itype(i+1)).eq.20) iblock=2
5170         if (iabs(itype(i+1)).ne.20) iblock=1
5171         dethetai=0.0d0
5172         dephii=0.0d0
5173         dephii1=0.0d0
5174         theti2=0.5d0*theta(i)
5175         ityp2=ithetyp((itype(i-1)))
5176         do k=1,nntheterm
5177           coskt(k)=dcos(k*theti2)
5178           sinkt(k)=dsin(k*theti2)
5179         enddo
5180         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5181 #ifdef OSF
5182           phii=phi(i)
5183           if (phii.ne.phii) phii=150.0
5184 #else
5185           phii=phi(i)
5186 #endif
5187           ityp1=ithetyp((itype(i-2)))
5188 C propagation of chirality for glycine type
5189           do k=1,nsingle
5190             cosph1(k)=dcos(k*phii)
5191             sinph1(k)=dsin(k*phii)
5192           enddo
5193         else
5194           phii=0.0d0
5195           ityp1=nthetyp+1
5196           do k=1,nsingle
5197             cosph1(k)=0.0d0
5198             sinph1(k)=0.0d0
5199           enddo
5200         endif
5201         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5202 #ifdef OSF
5203           phii1=phi(i+1)
5204           if (phii1.ne.phii1) phii1=150.0
5205           phii1=pinorm(phii1)
5206 #else
5207           phii1=phi(i+1)
5208 #endif
5209           ityp3=ithetyp((itype(i)))
5210           do k=1,nsingle
5211             cosph2(k)=dcos(k*phii1)
5212             sinph2(k)=dsin(k*phii1)
5213           enddo
5214         else
5215           phii1=0.0d0
5216           ityp3=nthetyp+1
5217           do k=1,nsingle
5218             cosph2(k)=0.0d0
5219             sinph2(k)=0.0d0
5220           enddo
5221         endif
5222         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5223         do k=1,ndouble
5224           do l=1,k-1
5225             ccl=cosph1(l)*cosph2(k-l)
5226             ssl=sinph1(l)*sinph2(k-l)
5227             scl=sinph1(l)*cosph2(k-l)
5228             csl=cosph1(l)*sinph2(k-l)
5229             cosph1ph2(l,k)=ccl-ssl
5230             cosph1ph2(k,l)=ccl+ssl
5231             sinph1ph2(l,k)=scl+csl
5232             sinph1ph2(k,l)=scl-csl
5233           enddo
5234         enddo
5235         if (lprn) then
5236         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5237      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5238         write (iout,*) "coskt and sinkt"
5239         do k=1,nntheterm
5240           write (iout,*) k,coskt(k),sinkt(k)
5241         enddo
5242         endif
5243         do k=1,ntheterm
5244           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5245           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5246      &      *coskt(k)
5247           if (lprn)
5248      &    write (iout,*) "k",k,"
5249      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5250      &     " ethetai",ethetai
5251         enddo
5252         if (lprn) then
5253         write (iout,*) "cosph and sinph"
5254         do k=1,nsingle
5255           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5256         enddo
5257         write (iout,*) "cosph1ph2 and sinph2ph2"
5258         do k=2,ndouble
5259           do l=1,k-1
5260             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5261      &         sinph1ph2(l,k),sinph1ph2(k,l)
5262           enddo
5263         enddo
5264         write(iout,*) "ethetai",ethetai
5265         endif
5266         do m=1,ntheterm2
5267           do k=1,nsingle
5268             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5269      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5270      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5271      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5272             ethetai=ethetai+sinkt(m)*aux
5273             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5274             dephii=dephii+k*sinkt(m)*(
5275      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5276      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5277             dephii1=dephii1+k*sinkt(m)*(
5278      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5279      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5280             if (lprn)
5281      &      write (iout,*) "m",m," k",k," bbthet",
5282      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5283      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5284      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5285      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5286           enddo
5287         enddo
5288         if (lprn)
5289      &  write(iout,*) "ethetai",ethetai
5290         do m=1,ntheterm3
5291           do k=2,ndouble
5292             do l=1,k-1
5293               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5294      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5295      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5296      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5297               ethetai=ethetai+sinkt(m)*aux
5298               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5299               dephii=dephii+l*sinkt(m)*(
5300      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5301      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5302      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5303      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5304               dephii1=dephii1+(k-l)*sinkt(m)*(
5305      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5306      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5307      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5308      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5309               if (lprn) then
5310               write (iout,*) "m",m," k",k," l",l," ffthet",
5311      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5312      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5313      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5314      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5315      &            " ethetai",ethetai
5316               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5317      &            cosph1ph2(k,l)*sinkt(m),
5318      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5319               endif
5320             enddo
5321           enddo
5322         enddo
5323 10      continue
5324 c        lprn1=.true.
5325         if (lprn1)
5326      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5327      &   i,theta(i)*rad2deg,phii*rad2deg,
5328      &   phii1*rad2deg,ethetai
5329 c        lprn1=.false.
5330         etheta=etheta+ethetai
5331         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5332         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5333         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5334       enddo
5335       return
5336       end
5337 #endif
5338 #ifdef CRYST_SC
5339 c-----------------------------------------------------------------------------
5340       subroutine esc(escloc)
5341 C Calculate the local energy of a side chain and its derivatives in the
5342 C corresponding virtual-bond valence angles THETA and the spherical angles
5343 C ALPHA and OMEGA.
5344       implicit real*8 (a-h,o-z)
5345       include 'DIMENSIONS'
5346       include 'COMMON.GEO'
5347       include 'COMMON.LOCAL'
5348       include 'COMMON.VAR'
5349       include 'COMMON.INTERACT'
5350       include 'COMMON.DERIV'
5351       include 'COMMON.CHAIN'
5352       include 'COMMON.IOUNITS'
5353       include 'COMMON.NAMES'
5354       include 'COMMON.FFIELD'
5355       include 'COMMON.CONTROL'
5356       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5357      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5358       common /sccalc/ time11,time12,time112,theti,it,nlobit
5359       delta=0.02d0*pi
5360       escloc=0.0D0
5361 c     write (iout,'(a)') 'ESC'
5362       do i=loc_start,loc_end
5363         it=itype(i)
5364         if (it.eq.ntyp1) cycle
5365         if (it.eq.10) goto 1
5366         nlobit=nlob(iabs(it))
5367 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5368 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5369         theti=theta(i+1)-pipol
5370         x(1)=dtan(theti)
5371         x(2)=alph(i)
5372         x(3)=omeg(i)
5373
5374         if (x(2).gt.pi-delta) then
5375           xtemp(1)=x(1)
5376           xtemp(2)=pi-delta
5377           xtemp(3)=x(3)
5378           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5379           xtemp(2)=pi
5380           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5381           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5382      &        escloci,dersc(2))
5383           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5384      &        ddersc0(1),dersc(1))
5385           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5386      &        ddersc0(3),dersc(3))
5387           xtemp(2)=pi-delta
5388           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5389           xtemp(2)=pi
5390           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5391           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5392      &            dersc0(2),esclocbi,dersc02)
5393           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5394      &            dersc12,dersc01)
5395           call splinthet(x(2),0.5d0*delta,ss,ssd)
5396           dersc0(1)=dersc01
5397           dersc0(2)=dersc02
5398           dersc0(3)=0.0d0
5399           do k=1,3
5400             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5401           enddo
5402           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5403 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5404 c    &             esclocbi,ss,ssd
5405           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5406 c         escloci=esclocbi
5407 c         write (iout,*) escloci
5408         else if (x(2).lt.delta) then
5409           xtemp(1)=x(1)
5410           xtemp(2)=delta
5411           xtemp(3)=x(3)
5412           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5413           xtemp(2)=0.0d0
5414           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5415           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5416      &        escloci,dersc(2))
5417           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5418      &        ddersc0(1),dersc(1))
5419           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5420      &        ddersc0(3),dersc(3))
5421           xtemp(2)=delta
5422           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5423           xtemp(2)=0.0d0
5424           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5425           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5426      &            dersc0(2),esclocbi,dersc02)
5427           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5428      &            dersc12,dersc01)
5429           dersc0(1)=dersc01
5430           dersc0(2)=dersc02
5431           dersc0(3)=0.0d0
5432           call splinthet(x(2),0.5d0*delta,ss,ssd)
5433           do k=1,3
5434             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5435           enddo
5436           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5437 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5438 c    &             esclocbi,ss,ssd
5439           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5440 c         write (iout,*) escloci
5441         else
5442           call enesc(x,escloci,dersc,ddummy,.false.)
5443         endif
5444
5445         escloc=escloc+escloci
5446         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5447      &     'escloc',i,escloci
5448 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5449
5450         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5451      &   wscloc*dersc(1)
5452         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5453         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5454     1   continue
5455       enddo
5456       return
5457       end
5458 C---------------------------------------------------------------------------
5459       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5460       implicit real*8 (a-h,o-z)
5461       include 'DIMENSIONS'
5462       include 'COMMON.GEO'
5463       include 'COMMON.LOCAL'
5464       include 'COMMON.IOUNITS'
5465       common /sccalc/ time11,time12,time112,theti,it,nlobit
5466       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5467       double precision contr(maxlob,-1:1)
5468       logical mixed
5469 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5470         escloc_i=0.0D0
5471         do j=1,3
5472           dersc(j)=0.0D0
5473           if (mixed) ddersc(j)=0.0d0
5474         enddo
5475         x3=x(3)
5476
5477 C Because of periodicity of the dependence of the SC energy in omega we have
5478 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5479 C To avoid underflows, first compute & store the exponents.
5480
5481         do iii=-1,1
5482
5483           x(3)=x3+iii*dwapi
5484
5485           do j=1,nlobit
5486             do k=1,3
5487               z(k)=x(k)-censc(k,j,it)
5488             enddo
5489             do k=1,3
5490               Axk=0.0D0
5491               do l=1,3
5492                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5493               enddo
5494               Ax(k,j,iii)=Axk
5495             enddo
5496             expfac=0.0D0
5497             do k=1,3
5498               expfac=expfac+Ax(k,j,iii)*z(k)
5499             enddo
5500             contr(j,iii)=expfac
5501           enddo ! j
5502
5503         enddo ! iii
5504
5505         x(3)=x3
5506 C As in the case of ebend, we want to avoid underflows in exponentiation and
5507 C subsequent NaNs and INFs in energy calculation.
5508 C Find the largest exponent
5509         emin=contr(1,-1)
5510         do iii=-1,1
5511           do j=1,nlobit
5512             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5513           enddo
5514         enddo
5515         emin=0.5D0*emin
5516 cd      print *,'it=',it,' emin=',emin
5517
5518 C Compute the contribution to SC energy and derivatives
5519         do iii=-1,1
5520
5521           do j=1,nlobit
5522 #ifdef OSF
5523             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5524             if(adexp.ne.adexp) adexp=1.0
5525             expfac=dexp(adexp)
5526 #else
5527             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5528 #endif
5529 cd          print *,'j=',j,' expfac=',expfac
5530             escloc_i=escloc_i+expfac
5531             do k=1,3
5532               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5533             enddo
5534             if (mixed) then
5535               do k=1,3,2
5536                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5537      &            +gaussc(k,2,j,it))*expfac
5538               enddo
5539             endif
5540           enddo
5541
5542         enddo ! iii
5543
5544         dersc(1)=dersc(1)/cos(theti)**2
5545         ddersc(1)=ddersc(1)/cos(theti)**2
5546         ddersc(3)=ddersc(3)
5547
5548         escloci=-(dlog(escloc_i)-emin)
5549         do j=1,3
5550           dersc(j)=dersc(j)/escloc_i
5551         enddo
5552         if (mixed) then
5553           do j=1,3,2
5554             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5555           enddo
5556         endif
5557       return
5558       end
5559 C------------------------------------------------------------------------------
5560       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5561       implicit real*8 (a-h,o-z)
5562       include 'DIMENSIONS'
5563       include 'COMMON.GEO'
5564       include 'COMMON.LOCAL'
5565       include 'COMMON.IOUNITS'
5566       common /sccalc/ time11,time12,time112,theti,it,nlobit
5567       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5568       double precision contr(maxlob)
5569       logical mixed
5570
5571       escloc_i=0.0D0
5572
5573       do j=1,3
5574         dersc(j)=0.0D0
5575       enddo
5576
5577       do j=1,nlobit
5578         do k=1,2
5579           z(k)=x(k)-censc(k,j,it)
5580         enddo
5581         z(3)=dwapi
5582         do k=1,3
5583           Axk=0.0D0
5584           do l=1,3
5585             Axk=Axk+gaussc(l,k,j,it)*z(l)
5586           enddo
5587           Ax(k,j)=Axk
5588         enddo
5589         expfac=0.0D0
5590         do k=1,3
5591           expfac=expfac+Ax(k,j)*z(k)
5592         enddo
5593         contr(j)=expfac
5594       enddo ! j
5595
5596 C As in the case of ebend, we want to avoid underflows in exponentiation and
5597 C subsequent NaNs and INFs in energy calculation.
5598 C Find the largest exponent
5599       emin=contr(1)
5600       do j=1,nlobit
5601         if (emin.gt.contr(j)) emin=contr(j)
5602       enddo
5603       emin=0.5D0*emin
5604
5605 C Compute the contribution to SC energy and derivatives
5606
5607       dersc12=0.0d0
5608       do j=1,nlobit
5609         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5610         escloc_i=escloc_i+expfac
5611         do k=1,2
5612           dersc(k)=dersc(k)+Ax(k,j)*expfac
5613         enddo
5614         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5615      &            +gaussc(1,2,j,it))*expfac
5616         dersc(3)=0.0d0
5617       enddo
5618
5619       dersc(1)=dersc(1)/cos(theti)**2
5620       dersc12=dersc12/cos(theti)**2
5621       escloci=-(dlog(escloc_i)-emin)
5622       do j=1,2
5623         dersc(j)=dersc(j)/escloc_i
5624       enddo
5625       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5626       return
5627       end
5628 #else
5629 c----------------------------------------------------------------------------------
5630       subroutine esc(escloc)
5631 C Calculate the local energy of a side chain and its derivatives in the
5632 C corresponding virtual-bond valence angles THETA and the spherical angles
5633 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5634 C added by Urszula Kozlowska. 07/11/2007
5635 C
5636       implicit real*8 (a-h,o-z)
5637       include 'DIMENSIONS'
5638       include 'COMMON.GEO'
5639       include 'COMMON.LOCAL'
5640       include 'COMMON.VAR'
5641       include 'COMMON.SCROT'
5642       include 'COMMON.INTERACT'
5643       include 'COMMON.DERIV'
5644       include 'COMMON.CHAIN'
5645       include 'COMMON.IOUNITS'
5646       include 'COMMON.NAMES'
5647       include 'COMMON.FFIELD'
5648       include 'COMMON.CONTROL'
5649       include 'COMMON.VECTORS'
5650       double precision x_prime(3),y_prime(3),z_prime(3)
5651      &    , sumene,dsc_i,dp2_i,x(65),
5652      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5653      &    de_dxx,de_dyy,de_dzz,de_dt
5654       double precision s1_t,s1_6_t,s2_t,s2_6_t
5655       double precision
5656      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5657      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5658      & dt_dCi(3),dt_dCi1(3)
5659       common /sccalc/ time11,time12,time112,theti,it,nlobit
5660       delta=0.02d0*pi
5661       escloc=0.0D0
5662       do i=loc_start,loc_end
5663         if (itype(i).eq.ntyp1) cycle
5664         costtab(i+1) =dcos(theta(i+1))
5665         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5666         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5667         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5668         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5669         cosfac=dsqrt(cosfac2)
5670         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5671         sinfac=dsqrt(sinfac2)
5672         it=iabs(itype(i))
5673         if (it.eq.10) goto 1
5674 c
5675 C  Compute the axes of tghe local cartesian coordinates system; store in
5676 c   x_prime, y_prime and z_prime
5677 c
5678         do j=1,3
5679           x_prime(j) = 0.00
5680           y_prime(j) = 0.00
5681           z_prime(j) = 0.00
5682         enddo
5683 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5684 C     &   dc_norm(3,i+nres)
5685         do j = 1,3
5686           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5687           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5688         enddo
5689         do j = 1,3
5690           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5691         enddo
5692 c       write (2,*) "i",i
5693 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5694 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5695 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5696 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5697 c      & " xy",scalar(x_prime(1),y_prime(1)),
5698 c      & " xz",scalar(x_prime(1),z_prime(1)),
5699 c      & " yy",scalar(y_prime(1),y_prime(1)),
5700 c      & " yz",scalar(y_prime(1),z_prime(1)),
5701 c      & " zz",scalar(z_prime(1),z_prime(1))
5702 c
5703 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5704 C to local coordinate system. Store in xx, yy, zz.
5705 c
5706         xx=0.0d0
5707         yy=0.0d0
5708         zz=0.0d0
5709         do j = 1,3
5710           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5711           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5712           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5713         enddo
5714
5715         xxtab(i)=xx
5716         yytab(i)=yy
5717         zztab(i)=zz
5718 C
5719 C Compute the energy of the ith side cbain
5720 C
5721 c        write (2,*) "xx",xx," yy",yy," zz",zz
5722         it=iabs(itype(i))
5723         do j = 1,65
5724           x(j) = sc_parmin(j,it)
5725         enddo
5726 #ifdef CHECK_COORD
5727 Cc diagnostics - remove later
5728         xx1 = dcos(alph(2))
5729         yy1 = dsin(alph(2))*dcos(omeg(2))
5730         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5731         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5732      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5733      &    xx1,yy1,zz1
5734 C,"  --- ", xx_w,yy_w,zz_w
5735 c end diagnostics
5736 #endif
5737         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5738      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5739      &   + x(10)*yy*zz
5740         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5741      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5742      & + x(20)*yy*zz
5743         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5744      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5745      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5746      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5747      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5748      &  +x(40)*xx*yy*zz
5749         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5750      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5751      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5752      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5753      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5754      &  +x(60)*xx*yy*zz
5755         dsc_i   = 0.743d0+x(61)
5756         dp2_i   = 1.9d0+x(62)
5757         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5758      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5759         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5760      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5761         s1=(1+x(63))/(0.1d0 + dscp1)
5762         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5763         s2=(1+x(65))/(0.1d0 + dscp2)
5764         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5765         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5766      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5767 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5768 c     &   sumene4,
5769 c     &   dscp1,dscp2,sumene
5770 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5771         escloc = escloc + sumene
5772 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5773 c     & ,zz,xx,yy
5774 c#define DEBUG
5775 #ifdef DEBUG
5776 C
5777 C This section to check the numerical derivatives of the energy of ith side
5778 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5779 C #define DEBUG in the code to turn it on.
5780 C
5781         write (2,*) "sumene               =",sumene
5782         aincr=1.0d-7
5783         xxsave=xx
5784         xx=xx+aincr
5785         write (2,*) xx,yy,zz
5786         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5787         de_dxx_num=(sumenep-sumene)/aincr
5788         xx=xxsave
5789         write (2,*) "xx+ sumene from enesc=",sumenep
5790         yysave=yy
5791         yy=yy+aincr
5792         write (2,*) xx,yy,zz
5793         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5794         de_dyy_num=(sumenep-sumene)/aincr
5795         yy=yysave
5796         write (2,*) "yy+ sumene from enesc=",sumenep
5797         zzsave=zz
5798         zz=zz+aincr
5799         write (2,*) xx,yy,zz
5800         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5801         de_dzz_num=(sumenep-sumene)/aincr
5802         zz=zzsave
5803         write (2,*) "zz+ sumene from enesc=",sumenep
5804         costsave=cost2tab(i+1)
5805         sintsave=sint2tab(i+1)
5806         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5807         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5808         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5809         de_dt_num=(sumenep-sumene)/aincr
5810         write (2,*) " t+ sumene from enesc=",sumenep
5811         cost2tab(i+1)=costsave
5812         sint2tab(i+1)=sintsave
5813 C End of diagnostics section.
5814 #endif
5815 C
5816 C Compute the gradient of esc
5817 C
5818 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5819         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5820         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5821         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5822         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5823         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5824         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5825         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5826         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5827         pom1=(sumene3*sint2tab(i+1)+sumene1)
5828      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5829         pom2=(sumene4*cost2tab(i+1)+sumene2)
5830      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5831         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5832         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5833      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5834      &  +x(40)*yy*zz
5835         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5836         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5837      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5838      &  +x(60)*yy*zz
5839         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5840      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5841      &        +(pom1+pom2)*pom_dx
5842 #ifdef DEBUG
5843         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5844 #endif
5845 C
5846         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5847         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5848      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5849      &  +x(40)*xx*zz
5850         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5851         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5852      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5853      &  +x(59)*zz**2 +x(60)*xx*zz
5854         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5855      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5856      &        +(pom1-pom2)*pom_dy
5857 #ifdef DEBUG
5858         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5859 #endif
5860 C
5861         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5862      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5863      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5864      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5865      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5866      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5867      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5868      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5869 #ifdef DEBUG
5870         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5871 #endif
5872 C
5873         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5874      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5875      &  +pom1*pom_dt1+pom2*pom_dt2
5876 #ifdef DEBUG
5877         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5878 #endif
5879 c#undef DEBUG
5880 c
5881 C
5882        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5883        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5884        cosfac2xx=cosfac2*xx
5885        sinfac2yy=sinfac2*yy
5886        do k = 1,3
5887          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5888      &      vbld_inv(i+1)
5889          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5890      &      vbld_inv(i)
5891          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5892          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5893 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5894 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5895 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5896 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5897          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5898          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5899          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5900          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5901          dZZ_Ci1(k)=0.0d0
5902          dZZ_Ci(k)=0.0d0
5903          do j=1,3
5904            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5905      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5906            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5907      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5908          enddo
5909
5910          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5911          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5912          dZZ_XYZ(k)=vbld_inv(i+nres)*
5913      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5914 c
5915          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5916          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5917        enddo
5918
5919        do k=1,3
5920          dXX_Ctab(k,i)=dXX_Ci(k)
5921          dXX_C1tab(k,i)=dXX_Ci1(k)
5922          dYY_Ctab(k,i)=dYY_Ci(k)
5923          dYY_C1tab(k,i)=dYY_Ci1(k)
5924          dZZ_Ctab(k,i)=dZZ_Ci(k)
5925          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5926          dXX_XYZtab(k,i)=dXX_XYZ(k)
5927          dYY_XYZtab(k,i)=dYY_XYZ(k)
5928          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5929        enddo
5930
5931        do k = 1,3
5932 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5933 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5934 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5935 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5936 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5937 c     &    dt_dci(k)
5938 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5939 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5940          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5941      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5942          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5943      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5944          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5945      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5946        enddo
5947 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5948 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5949
5950 C to check gradient call subroutine check_grad
5951
5952     1 continue
5953       enddo
5954       return
5955       end
5956 c------------------------------------------------------------------------------
5957       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5958       implicit none
5959       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5960      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5961       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5962      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5963      &   + x(10)*yy*zz
5964       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5965      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5966      & + x(20)*yy*zz
5967       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5968      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5969      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5970      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5971      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5972      &  +x(40)*xx*yy*zz
5973       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5974      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5975      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5976      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5977      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5978      &  +x(60)*xx*yy*zz
5979       dsc_i   = 0.743d0+x(61)
5980       dp2_i   = 1.9d0+x(62)
5981       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5982      &          *(xx*cost2+yy*sint2))
5983       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5984      &          *(xx*cost2-yy*sint2))
5985       s1=(1+x(63))/(0.1d0 + dscp1)
5986       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5987       s2=(1+x(65))/(0.1d0 + dscp2)
5988       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5989       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5990      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5991       enesc=sumene
5992       return
5993       end
5994 #endif
5995 c------------------------------------------------------------------------------
5996       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5997 C
5998 C This procedure calculates two-body contact function g(rij) and its derivative:
5999 C
6000 C           eps0ij                                     !       x < -1
6001 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6002 C            0                                         !       x > 1
6003 C
6004 C where x=(rij-r0ij)/delta
6005 C
6006 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6007 C
6008       implicit none
6009       double precision rij,r0ij,eps0ij,fcont,fprimcont
6010       double precision x,x2,x4,delta
6011 c     delta=0.02D0*r0ij
6012 c      delta=0.2D0*r0ij
6013       x=(rij-r0ij)/delta
6014       if (x.lt.-1.0D0) then
6015         fcont=eps0ij
6016         fprimcont=0.0D0
6017       else if (x.le.1.0D0) then
6018         x2=x*x
6019         x4=x2*x2
6020         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6021         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6022       else
6023         fcont=0.0D0
6024         fprimcont=0.0D0
6025       endif
6026       return
6027       end
6028 c------------------------------------------------------------------------------
6029       subroutine splinthet(theti,delta,ss,ssder)
6030       implicit real*8 (a-h,o-z)
6031       include 'DIMENSIONS'
6032       include 'COMMON.VAR'
6033       include 'COMMON.GEO'
6034       thetup=pi-delta
6035       thetlow=delta
6036       if (theti.gt.pipol) then
6037         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6038       else
6039         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6040         ssder=-ssder
6041       endif
6042       return
6043       end
6044 c------------------------------------------------------------------------------
6045       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6046       implicit none
6047       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6048       double precision ksi,ksi2,ksi3,a1,a2,a3
6049       a1=fprim0*delta/(f1-f0)
6050       a2=3.0d0-2.0d0*a1
6051       a3=a1-2.0d0
6052       ksi=(x-x0)/delta
6053       ksi2=ksi*ksi
6054       ksi3=ksi2*ksi
6055       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6056       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6057       return
6058       end
6059 c------------------------------------------------------------------------------
6060       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6061       implicit none
6062       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6063       double precision ksi,ksi2,ksi3,a1,a2,a3
6064       ksi=(x-x0)/delta
6065       ksi2=ksi*ksi
6066       ksi3=ksi2*ksi
6067       a1=fprim0x*delta
6068       a2=3*(f1x-f0x)-2*fprim0x*delta
6069       a3=fprim0x*delta-2*(f1x-f0x)
6070       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6071       return
6072       end
6073 C-----------------------------------------------------------------------------
6074 #ifdef CRYST_TOR
6075 C-----------------------------------------------------------------------------
6076       subroutine etor(etors,edihcnstr)
6077       implicit real*8 (a-h,o-z)
6078       include 'DIMENSIONS'
6079       include 'COMMON.VAR'
6080       include 'COMMON.GEO'
6081       include 'COMMON.LOCAL'
6082       include 'COMMON.TORSION'
6083       include 'COMMON.INTERACT'
6084       include 'COMMON.DERIV'
6085       include 'COMMON.CHAIN'
6086       include 'COMMON.NAMES'
6087       include 'COMMON.IOUNITS'
6088       include 'COMMON.FFIELD'
6089       include 'COMMON.TORCNSTR'
6090       include 'COMMON.CONTROL'
6091       logical lprn
6092 C Set lprn=.true. for debugging
6093       lprn=.false.
6094 c      lprn=.true.
6095       etors=0.0D0
6096       do i=iphi_start,iphi_end
6097       etors_ii=0.0D0
6098         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6099      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6100         itori=itortyp(itype(i-2))
6101         itori1=itortyp(itype(i-1))
6102         phii=phi(i)
6103         gloci=0.0D0
6104 C Proline-Proline pair is a special case...
6105         if (itori.eq.3 .and. itori1.eq.3) then
6106           if (phii.gt.-dwapi3) then
6107             cosphi=dcos(3*phii)
6108             fac=1.0D0/(1.0D0-cosphi)
6109             etorsi=v1(1,3,3)*fac
6110             etorsi=etorsi+etorsi
6111             etors=etors+etorsi-v1(1,3,3)
6112             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6113             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6114           endif
6115           do j=1,3
6116             v1ij=v1(j+1,itori,itori1)
6117             v2ij=v2(j+1,itori,itori1)
6118             cosphi=dcos(j*phii)
6119             sinphi=dsin(j*phii)
6120             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6121             if (energy_dec) etors_ii=etors_ii+
6122      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6123             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6124           enddo
6125         else
6126           do j=1,nterm_old
6127             v1ij=v1(j,itori,itori1)
6128             v2ij=v2(j,itori,itori1)
6129             cosphi=dcos(j*phii)
6130             sinphi=dsin(j*phii)
6131             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6132             if (energy_dec) etors_ii=etors_ii+
6133      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6134             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6135           enddo
6136         endif
6137         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6138              'etor',i,etors_ii
6139         if (lprn)
6140      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6141      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6142      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6143         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6144 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6145       enddo
6146 ! 6/20/98 - dihedral angle constraints
6147       edihcnstr=0.0d0
6148       do i=1,ndih_constr
6149         itori=idih_constr(i)
6150         phii=phi(itori)
6151         difi=phii-phi0(i)
6152         if (difi.gt.drange(i)) then
6153           difi=difi-drange(i)
6154           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6155           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6156         else if (difi.lt.-drange(i)) then
6157           difi=difi+drange(i)
6158           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6159           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6160         endif
6161 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6162 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6163       enddo
6164 !      write (iout,*) 'edihcnstr',edihcnstr
6165       return
6166       end
6167 c------------------------------------------------------------------------------
6168       subroutine etor_d(etors_d)
6169       etors_d=0.0d0
6170       return
6171       end
6172 c----------------------------------------------------------------------------
6173 #else
6174       subroutine etor(etors,edihcnstr)
6175       implicit real*8 (a-h,o-z)
6176       include 'DIMENSIONS'
6177       include 'COMMON.VAR'
6178       include 'COMMON.GEO'
6179       include 'COMMON.LOCAL'
6180       include 'COMMON.TORSION'
6181       include 'COMMON.INTERACT'
6182       include 'COMMON.DERIV'
6183       include 'COMMON.CHAIN'
6184       include 'COMMON.NAMES'
6185       include 'COMMON.IOUNITS'
6186       include 'COMMON.FFIELD'
6187       include 'COMMON.TORCNSTR'
6188       include 'COMMON.CONTROL'
6189       logical lprn
6190 C Set lprn=.true. for debugging
6191       lprn=.false.
6192 c     lprn=.true.
6193       etors=0.0D0
6194       do i=iphi_start,iphi_end
6195 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6196 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6197 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6198 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6199         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6200      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6201 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6202 C For introducing the NH3+ and COO- group please check the etor_d for reference
6203 C and guidance
6204         etors_ii=0.0D0
6205          if (iabs(itype(i)).eq.20) then
6206          iblock=2
6207          else
6208          iblock=1
6209          endif
6210         itori=itortyp(itype(i-2))
6211         itori1=itortyp(itype(i-1))
6212         phii=phi(i)
6213         gloci=0.0D0
6214 C Regular cosine and sine terms
6215         do j=1,nterm(itori,itori1,iblock)
6216           v1ij=v1(j,itori,itori1,iblock)
6217           v2ij=v2(j,itori,itori1,iblock)
6218           cosphi=dcos(j*phii)
6219           sinphi=dsin(j*phii)
6220           etors=etors+v1ij*cosphi+v2ij*sinphi
6221           if (energy_dec) etors_ii=etors_ii+
6222      &                v1ij*cosphi+v2ij*sinphi
6223           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6224         enddo
6225 C Lorentz terms
6226 C                         v1
6227 C  E = SUM ----------------------------------- - v1
6228 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6229 C
6230         cosphi=dcos(0.5d0*phii)
6231         sinphi=dsin(0.5d0*phii)
6232         do j=1,nlor(itori,itori1,iblock)
6233           vl1ij=vlor1(j,itori,itori1)
6234           vl2ij=vlor2(j,itori,itori1)
6235           vl3ij=vlor3(j,itori,itori1)
6236           pom=vl2ij*cosphi+vl3ij*sinphi
6237           pom1=1.0d0/(pom*pom+1.0d0)
6238           etors=etors+vl1ij*pom1
6239           if (energy_dec) etors_ii=etors_ii+
6240      &                vl1ij*pom1
6241           pom=-pom*pom1*pom1
6242           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6243         enddo
6244 C Subtract the constant term
6245         etors=etors-v0(itori,itori1,iblock)
6246           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6247      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6248         if (lprn)
6249      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6250      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6251      &  (v1(j,itori,itori1,iblock),j=1,6),
6252      &  (v2(j,itori,itori1,iblock),j=1,6)
6253         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6254 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6255       enddo
6256 ! 6/20/98 - dihedral angle constraints
6257       edihcnstr=0.0d0
6258 c      do i=1,ndih_constr
6259       do i=idihconstr_start,idihconstr_end
6260         itori=idih_constr(i)
6261         phii=phi(itori)
6262         difi=pinorm(phii-phi0(i))
6263         if (difi.gt.drange(i)) then
6264           difi=difi-drange(i)
6265           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6266           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6267         else if (difi.lt.-drange(i)) then
6268           difi=difi+drange(i)
6269           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6270           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6271         else
6272           difi=0.0
6273         endif
6274 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6275 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6276 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6277       enddo
6278 cd       write (iout,*) 'edihcnstr',edihcnstr
6279       return
6280       end
6281 c----------------------------------------------------------------------------
6282       subroutine etor_d(etors_d)
6283 C 6/23/01 Compute double torsional energy
6284       implicit real*8 (a-h,o-z)
6285       include 'DIMENSIONS'
6286       include 'COMMON.VAR'
6287       include 'COMMON.GEO'
6288       include 'COMMON.LOCAL'
6289       include 'COMMON.TORSION'
6290       include 'COMMON.INTERACT'
6291       include 'COMMON.DERIV'
6292       include 'COMMON.CHAIN'
6293       include 'COMMON.NAMES'
6294       include 'COMMON.IOUNITS'
6295       include 'COMMON.FFIELD'
6296       include 'COMMON.TORCNSTR'
6297       logical lprn
6298 C Set lprn=.true. for debugging
6299       lprn=.false.
6300 c     lprn=.true.
6301       etors_d=0.0D0
6302 c      write(iout,*) "a tu??"
6303       do i=iphid_start,iphid_end
6304 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6305 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6306 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6307 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6308 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6309          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6310      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6311      &  (itype(i+1).eq.ntyp1)) cycle
6312 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6313         itori=itortyp(itype(i-2))
6314         itori1=itortyp(itype(i-1))
6315         itori2=itortyp(itype(i))
6316         phii=phi(i)
6317         phii1=phi(i+1)
6318         gloci1=0.0D0
6319         gloci2=0.0D0
6320         iblock=1
6321         if (iabs(itype(i+1)).eq.20) iblock=2
6322 C Iblock=2 Proline type
6323 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6324 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6325 C        if (itype(i+1).eq.ntyp1) iblock=3
6326 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6327 C IS or IS NOT need for this
6328 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6329 C        is (itype(i-3).eq.ntyp1) ntblock=2
6330 C        ntblock is N-terminal blocking group
6331
6332 C Regular cosine and sine terms
6333         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6334 C Example of changes for NH3+ blocking group
6335 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6336 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6337           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6338           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6339           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6340           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6341           cosphi1=dcos(j*phii)
6342           sinphi1=dsin(j*phii)
6343           cosphi2=dcos(j*phii1)
6344           sinphi2=dsin(j*phii1)
6345           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6346      &     v2cij*cosphi2+v2sij*sinphi2
6347           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6348           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6349         enddo
6350         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6351           do l=1,k-1
6352             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6353             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6354             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6355             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6356             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6357             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6358             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6359             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6360             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6361      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6362             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6363      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6364             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6365      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6366           enddo
6367         enddo
6368         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6369         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6370       enddo
6371       return
6372       end
6373 #endif
6374 c------------------------------------------------------------------------------
6375       subroutine eback_sc_corr(esccor)
6376 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6377 c        conformational states; temporarily implemented as differences
6378 c        between UNRES torsional potentials (dependent on three types of
6379 c        residues) and the torsional potentials dependent on all 20 types
6380 c        of residues computed from AM1  energy surfaces of terminally-blocked
6381 c        amino-acid residues.
6382       implicit real*8 (a-h,o-z)
6383       include 'DIMENSIONS'
6384       include 'COMMON.VAR'
6385       include 'COMMON.GEO'
6386       include 'COMMON.LOCAL'
6387       include 'COMMON.TORSION'
6388       include 'COMMON.SCCOR'
6389       include 'COMMON.INTERACT'
6390       include 'COMMON.DERIV'
6391       include 'COMMON.CHAIN'
6392       include 'COMMON.NAMES'
6393       include 'COMMON.IOUNITS'
6394       include 'COMMON.FFIELD'
6395       include 'COMMON.CONTROL'
6396       logical lprn
6397 C Set lprn=.true. for debugging
6398       lprn=.false.
6399 c      lprn=.true.
6400 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6401       esccor=0.0D0
6402       do i=itau_start,itau_end
6403         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6404         esccor_ii=0.0D0
6405         isccori=isccortyp(itype(i-2))
6406         isccori1=isccortyp(itype(i-1))
6407 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6408         phii=phi(i)
6409         do intertyp=1,3 !intertyp
6410 cc Added 09 May 2012 (Adasko)
6411 cc  Intertyp means interaction type of backbone mainchain correlation:
6412 c   1 = SC...Ca...Ca...Ca
6413 c   2 = Ca...Ca...Ca...SC
6414 c   3 = SC...Ca...Ca...SCi
6415         gloci=0.0D0
6416         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6417      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6418      &      (itype(i-1).eq.ntyp1)))
6419      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6420      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6421      &     .or.(itype(i).eq.ntyp1)))
6422      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6423      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6424      &      (itype(i-3).eq.ntyp1)))) cycle
6425         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6426         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6427      & cycle
6428        do j=1,nterm_sccor(isccori,isccori1)
6429           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6430           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6431           cosphi=dcos(j*tauangle(intertyp,i))
6432           sinphi=dsin(j*tauangle(intertyp,i))
6433           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6434           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6435         enddo
6436 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6437         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6438         if (lprn)
6439      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6440      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6441      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6442      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6443         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6444        enddo !intertyp
6445       enddo
6446
6447       return
6448       end
6449 c----------------------------------------------------------------------------
6450       subroutine multibody(ecorr)
6451 C This subroutine calculates multi-body contributions to energy following
6452 C the idea of Skolnick et al. If side chains I and J make a contact and
6453 C at the same time side chains I+1 and J+1 make a contact, an extra
6454 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6455       implicit real*8 (a-h,o-z)
6456       include 'DIMENSIONS'
6457       include 'COMMON.IOUNITS'
6458       include 'COMMON.DERIV'
6459       include 'COMMON.INTERACT'
6460       include 'COMMON.CONTACTS'
6461       double precision gx(3),gx1(3)
6462       logical lprn
6463
6464 C Set lprn=.true. for debugging
6465       lprn=.false.
6466
6467       if (lprn) then
6468         write (iout,'(a)') 'Contact function values:'
6469         do i=nnt,nct-2
6470           write (iout,'(i2,20(1x,i2,f10.5))')
6471      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6472         enddo
6473       endif
6474       ecorr=0.0D0
6475       do i=nnt,nct
6476         do j=1,3
6477           gradcorr(j,i)=0.0D0
6478           gradxorr(j,i)=0.0D0
6479         enddo
6480       enddo
6481       do i=nnt,nct-2
6482
6483         DO ISHIFT = 3,4
6484
6485         i1=i+ishift
6486         num_conti=num_cont(i)
6487         num_conti1=num_cont(i1)
6488         do jj=1,num_conti
6489           j=jcont(jj,i)
6490           do kk=1,num_conti1
6491             j1=jcont(kk,i1)
6492             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6493 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6494 cd   &                   ' ishift=',ishift
6495 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6496 C The system gains extra energy.
6497               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6498             endif   ! j1==j+-ishift
6499           enddo     ! kk
6500         enddo       ! jj
6501
6502         ENDDO ! ISHIFT
6503
6504       enddo         ! i
6505       return
6506       end
6507 c------------------------------------------------------------------------------
6508       double precision function esccorr(i,j,k,l,jj,kk)
6509       implicit real*8 (a-h,o-z)
6510       include 'DIMENSIONS'
6511       include 'COMMON.IOUNITS'
6512       include 'COMMON.DERIV'
6513       include 'COMMON.INTERACT'
6514       include 'COMMON.CONTACTS'
6515       double precision gx(3),gx1(3)
6516       logical lprn
6517       lprn=.false.
6518       eij=facont(jj,i)
6519       ekl=facont(kk,k)
6520 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6521 C Calculate the multi-body contribution to energy.
6522 C Calculate multi-body contributions to the gradient.
6523 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6524 cd   & k,l,(gacont(m,kk,k),m=1,3)
6525       do m=1,3
6526         gx(m) =ekl*gacont(m,jj,i)
6527         gx1(m)=eij*gacont(m,kk,k)
6528         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6529         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6530         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6531         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6532       enddo
6533       do m=i,j-1
6534         do ll=1,3
6535           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6536         enddo
6537       enddo
6538       do m=k,l-1
6539         do ll=1,3
6540           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6541         enddo
6542       enddo
6543       esccorr=-eij*ekl
6544       return
6545       end
6546 c------------------------------------------------------------------------------
6547       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6548 C This subroutine calculates multi-body contributions to hydrogen-bonding
6549       implicit real*8 (a-h,o-z)
6550       include 'DIMENSIONS'
6551       include 'COMMON.IOUNITS'
6552 #ifdef MPI
6553       include "mpif.h"
6554       parameter (max_cont=maxconts)
6555       parameter (max_dim=26)
6556       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6557       double precision zapas(max_dim,maxconts,max_fg_procs),
6558      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6559       common /przechowalnia/ zapas
6560       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6561      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6562 #endif
6563       include 'COMMON.SETUP'
6564       include 'COMMON.FFIELD'
6565       include 'COMMON.DERIV'
6566       include 'COMMON.INTERACT'
6567       include 'COMMON.CONTACTS'
6568       include 'COMMON.CONTROL'
6569       include 'COMMON.LOCAL'
6570       double precision gx(3),gx1(3),time00
6571       logical lprn,ldone
6572
6573 C Set lprn=.true. for debugging
6574       lprn=.false.
6575 #ifdef MPI
6576       n_corr=0
6577       n_corr1=0
6578       if (nfgtasks.le.1) goto 30
6579       if (lprn) then
6580         write (iout,'(a)') 'Contact function values before RECEIVE:'
6581         do i=nnt,nct-2
6582           write (iout,'(2i3,50(1x,i2,f5.2))')
6583      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6584      &    j=1,num_cont_hb(i))
6585         enddo
6586       endif
6587       call flush(iout)
6588       do i=1,ntask_cont_from
6589         ncont_recv(i)=0
6590       enddo
6591       do i=1,ntask_cont_to
6592         ncont_sent(i)=0
6593       enddo
6594 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6595 c     & ntask_cont_to
6596 C Make the list of contacts to send to send to other procesors
6597 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6598 c      call flush(iout)
6599       do i=iturn3_start,iturn3_end
6600 c        write (iout,*) "make contact list turn3",i," num_cont",
6601 c     &    num_cont_hb(i)
6602         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6603       enddo
6604       do i=iturn4_start,iturn4_end
6605 c        write (iout,*) "make contact list turn4",i," num_cont",
6606 c     &   num_cont_hb(i)
6607         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6608       enddo
6609       do ii=1,nat_sent
6610         i=iat_sent(ii)
6611 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6612 c     &    num_cont_hb(i)
6613         do j=1,num_cont_hb(i)
6614         do k=1,4
6615           jjc=jcont_hb(j,i)
6616           iproc=iint_sent_local(k,jjc,ii)
6617 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6618           if (iproc.gt.0) then
6619             ncont_sent(iproc)=ncont_sent(iproc)+1
6620             nn=ncont_sent(iproc)
6621             zapas(1,nn,iproc)=i
6622             zapas(2,nn,iproc)=jjc
6623             zapas(3,nn,iproc)=facont_hb(j,i)
6624             zapas(4,nn,iproc)=ees0p(j,i)
6625             zapas(5,nn,iproc)=ees0m(j,i)
6626             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6627             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6628             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6629             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6630             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6631             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6632             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6633             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6634             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6635             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6636             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6637             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6638             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6639             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6640             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6641             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6642             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6643             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6644             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6645             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6646             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6647           endif
6648         enddo
6649         enddo
6650       enddo
6651       if (lprn) then
6652       write (iout,*)
6653      &  "Numbers of contacts to be sent to other processors",
6654      &  (ncont_sent(i),i=1,ntask_cont_to)
6655       write (iout,*) "Contacts sent"
6656       do ii=1,ntask_cont_to
6657         nn=ncont_sent(ii)
6658         iproc=itask_cont_to(ii)
6659         write (iout,*) nn," contacts to processor",iproc,
6660      &   " of CONT_TO_COMM group"
6661         do i=1,nn
6662           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6663         enddo
6664       enddo
6665       call flush(iout)
6666       endif
6667       CorrelType=477
6668       CorrelID=fg_rank+1
6669       CorrelType1=478
6670       CorrelID1=nfgtasks+fg_rank+1
6671       ireq=0
6672 C Receive the numbers of needed contacts from other processors
6673       do ii=1,ntask_cont_from
6674         iproc=itask_cont_from(ii)
6675         ireq=ireq+1
6676         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6677      &    FG_COMM,req(ireq),IERR)
6678       enddo
6679 c      write (iout,*) "IRECV ended"
6680 c      call flush(iout)
6681 C Send the number of contacts needed by other processors
6682       do ii=1,ntask_cont_to
6683         iproc=itask_cont_to(ii)
6684         ireq=ireq+1
6685         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6686      &    FG_COMM,req(ireq),IERR)
6687       enddo
6688 c      write (iout,*) "ISEND ended"
6689 c      write (iout,*) "number of requests (nn)",ireq
6690       call flush(iout)
6691       if (ireq.gt.0)
6692      &  call MPI_Waitall(ireq,req,status_array,ierr)
6693 c      write (iout,*)
6694 c     &  "Numbers of contacts to be received from other processors",
6695 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6696 c      call flush(iout)
6697 C Receive contacts
6698       ireq=0
6699       do ii=1,ntask_cont_from
6700         iproc=itask_cont_from(ii)
6701         nn=ncont_recv(ii)
6702 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6703 c     &   " of CONT_TO_COMM group"
6704         call flush(iout)
6705         if (nn.gt.0) then
6706           ireq=ireq+1
6707           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6708      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6709 c          write (iout,*) "ireq,req",ireq,req(ireq)
6710         endif
6711       enddo
6712 C Send the contacts to processors that need them
6713       do ii=1,ntask_cont_to
6714         iproc=itask_cont_to(ii)
6715         nn=ncont_sent(ii)
6716 c        write (iout,*) nn," contacts to processor",iproc,
6717 c     &   " of CONT_TO_COMM group"
6718         if (nn.gt.0) then
6719           ireq=ireq+1
6720           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6721      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6722 c          write (iout,*) "ireq,req",ireq,req(ireq)
6723 c          do i=1,nn
6724 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6725 c          enddo
6726         endif
6727       enddo
6728 c      write (iout,*) "number of requests (contacts)",ireq
6729 c      write (iout,*) "req",(req(i),i=1,4)
6730 c      call flush(iout)
6731       if (ireq.gt.0)
6732      & call MPI_Waitall(ireq,req,status_array,ierr)
6733       do iii=1,ntask_cont_from
6734         iproc=itask_cont_from(iii)
6735         nn=ncont_recv(iii)
6736         if (lprn) then
6737         write (iout,*) "Received",nn," contacts from processor",iproc,
6738      &   " of CONT_FROM_COMM group"
6739         call flush(iout)
6740         do i=1,nn
6741           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6742         enddo
6743         call flush(iout)
6744         endif
6745         do i=1,nn
6746           ii=zapas_recv(1,i,iii)
6747 c Flag the received contacts to prevent double-counting
6748           jj=-zapas_recv(2,i,iii)
6749 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6750 c          call flush(iout)
6751           nnn=num_cont_hb(ii)+1
6752           num_cont_hb(ii)=nnn
6753           jcont_hb(nnn,ii)=jj
6754           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6755           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6756           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6757           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6758           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6759           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6760           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6761           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6762           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6763           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6764           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6765           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6766           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6767           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6768           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6769           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6770           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6771           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6772           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6773           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6774           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6775           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6776           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6777           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6778         enddo
6779       enddo
6780       call flush(iout)
6781       if (lprn) then
6782         write (iout,'(a)') 'Contact function values after receive:'
6783         do i=nnt,nct-2
6784           write (iout,'(2i3,50(1x,i3,f5.2))')
6785      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6786      &    j=1,num_cont_hb(i))
6787         enddo
6788         call flush(iout)
6789       endif
6790    30 continue
6791 #endif
6792       if (lprn) then
6793         write (iout,'(a)') 'Contact function values:'
6794         do i=nnt,nct-2
6795           write (iout,'(2i3,50(1x,i3,f5.2))')
6796      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6797      &    j=1,num_cont_hb(i))
6798         enddo
6799       endif
6800       ecorr=0.0D0
6801 C Remove the loop below after debugging !!!
6802       do i=nnt,nct
6803         do j=1,3
6804           gradcorr(j,i)=0.0D0
6805           gradxorr(j,i)=0.0D0
6806         enddo
6807       enddo
6808 C Calculate the local-electrostatic correlation terms
6809       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6810         i1=i+1
6811         num_conti=num_cont_hb(i)
6812         num_conti1=num_cont_hb(i+1)
6813         do jj=1,num_conti
6814           j=jcont_hb(jj,i)
6815           jp=iabs(j)
6816           do kk=1,num_conti1
6817             j1=jcont_hb(kk,i1)
6818             jp1=iabs(j1)
6819 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6820 c     &         ' jj=',jj,' kk=',kk
6821             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6822      &          .or. j.lt.0 .and. j1.gt.0) .and.
6823      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6824 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6825 C The system gains extra energy.
6826               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6827               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6828      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6829               n_corr=n_corr+1
6830             else if (j1.eq.j) then
6831 C Contacts I-J and I-(J+1) occur simultaneously.
6832 C The system loses extra energy.
6833 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6834             endif
6835           enddo ! kk
6836           do kk=1,num_conti
6837             j1=jcont_hb(kk,i)
6838 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6839 c    &         ' jj=',jj,' kk=',kk
6840             if (j1.eq.j+1) then
6841 C Contacts I-J and (I+1)-J occur simultaneously.
6842 C The system loses extra energy.
6843 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6844             endif ! j1==j+1
6845           enddo ! kk
6846         enddo ! jj
6847       enddo ! i
6848       return
6849       end
6850 c------------------------------------------------------------------------------
6851       subroutine add_hb_contact(ii,jj,itask)
6852       implicit real*8 (a-h,o-z)
6853       include "DIMENSIONS"
6854       include "COMMON.IOUNITS"
6855       integer max_cont
6856       integer max_dim
6857       parameter (max_cont=maxconts)
6858       parameter (max_dim=26)
6859       include "COMMON.CONTACTS"
6860       double precision zapas(max_dim,maxconts,max_fg_procs),
6861      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6862       common /przechowalnia/ zapas
6863       integer i,j,ii,jj,iproc,itask(4),nn
6864 c      write (iout,*) "itask",itask
6865       do i=1,2
6866         iproc=itask(i)
6867         if (iproc.gt.0) then
6868           do j=1,num_cont_hb(ii)
6869             jjc=jcont_hb(j,ii)
6870 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6871             if (jjc.eq.jj) then
6872               ncont_sent(iproc)=ncont_sent(iproc)+1
6873               nn=ncont_sent(iproc)
6874               zapas(1,nn,iproc)=ii
6875               zapas(2,nn,iproc)=jjc
6876               zapas(3,nn,iproc)=facont_hb(j,ii)
6877               zapas(4,nn,iproc)=ees0p(j,ii)
6878               zapas(5,nn,iproc)=ees0m(j,ii)
6879               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6880               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6881               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6882               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6883               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6884               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6885               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6886               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6887               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6888               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6889               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6890               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6891               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6892               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6893               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6894               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6895               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6896               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6897               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6898               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6899               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6900               exit
6901             endif
6902           enddo
6903         endif
6904       enddo
6905       return
6906       end
6907 c------------------------------------------------------------------------------
6908       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6909      &  n_corr1)
6910 C This subroutine calculates multi-body contributions to hydrogen-bonding
6911       implicit real*8 (a-h,o-z)
6912       include 'DIMENSIONS'
6913       include 'COMMON.IOUNITS'
6914 #ifdef MPI
6915       include "mpif.h"
6916       parameter (max_cont=maxconts)
6917       parameter (max_dim=70)
6918       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6919       double precision zapas(max_dim,maxconts,max_fg_procs),
6920      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6921       common /przechowalnia/ zapas
6922       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6923      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6924 #endif
6925       include 'COMMON.SETUP'
6926       include 'COMMON.FFIELD'
6927       include 'COMMON.DERIV'
6928       include 'COMMON.LOCAL'
6929       include 'COMMON.INTERACT'
6930       include 'COMMON.CONTACTS'
6931       include 'COMMON.CHAIN'
6932       include 'COMMON.CONTROL'
6933       double precision gx(3),gx1(3)
6934       integer num_cont_hb_old(maxres)
6935       logical lprn,ldone
6936       double precision eello4,eello5,eelo6,eello_turn6
6937       external eello4,eello5,eello6,eello_turn6
6938 C Set lprn=.true. for debugging
6939       lprn=.false.
6940       eturn6=0.0d0
6941 #ifdef MPI
6942       do i=1,nres
6943         num_cont_hb_old(i)=num_cont_hb(i)
6944       enddo
6945       n_corr=0
6946       n_corr1=0
6947       if (nfgtasks.le.1) goto 30
6948       if (lprn) then
6949         write (iout,'(a)') 'Contact function values before RECEIVE:'
6950         do i=nnt,nct-2
6951           write (iout,'(2i3,50(1x,i2,f5.2))')
6952      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6953      &    j=1,num_cont_hb(i))
6954         enddo
6955       endif
6956       call flush(iout)
6957       do i=1,ntask_cont_from
6958         ncont_recv(i)=0
6959       enddo
6960       do i=1,ntask_cont_to
6961         ncont_sent(i)=0
6962       enddo
6963 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6964 c     & ntask_cont_to
6965 C Make the list of contacts to send to send to other procesors
6966       do i=iturn3_start,iturn3_end
6967 c        write (iout,*) "make contact list turn3",i," num_cont",
6968 c     &    num_cont_hb(i)
6969         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6970       enddo
6971       do i=iturn4_start,iturn4_end
6972 c        write (iout,*) "make contact list turn4",i," num_cont",
6973 c     &   num_cont_hb(i)
6974         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6975       enddo
6976       do ii=1,nat_sent
6977         i=iat_sent(ii)
6978 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6979 c     &    num_cont_hb(i)
6980         do j=1,num_cont_hb(i)
6981         do k=1,4
6982           jjc=jcont_hb(j,i)
6983           iproc=iint_sent_local(k,jjc,ii)
6984 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6985           if (iproc.ne.0) then
6986             ncont_sent(iproc)=ncont_sent(iproc)+1
6987             nn=ncont_sent(iproc)
6988             zapas(1,nn,iproc)=i
6989             zapas(2,nn,iproc)=jjc
6990             zapas(3,nn,iproc)=d_cont(j,i)
6991             ind=3
6992             do kk=1,3
6993               ind=ind+1
6994               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6995             enddo
6996             do kk=1,2
6997               do ll=1,2
6998                 ind=ind+1
6999                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7000               enddo
7001             enddo
7002             do jj=1,5
7003               do kk=1,3
7004                 do ll=1,2
7005                   do mm=1,2
7006                     ind=ind+1
7007                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7008                   enddo
7009                 enddo
7010               enddo
7011             enddo
7012           endif
7013         enddo
7014         enddo
7015       enddo
7016       if (lprn) then
7017       write (iout,*)
7018      &  "Numbers of contacts to be sent to other processors",
7019      &  (ncont_sent(i),i=1,ntask_cont_to)
7020       write (iout,*) "Contacts sent"
7021       do ii=1,ntask_cont_to
7022         nn=ncont_sent(ii)
7023         iproc=itask_cont_to(ii)
7024         write (iout,*) nn," contacts to processor",iproc,
7025      &   " of CONT_TO_COMM group"
7026         do i=1,nn
7027           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7028         enddo
7029       enddo
7030       call flush(iout)
7031       endif
7032       CorrelType=477
7033       CorrelID=fg_rank+1
7034       CorrelType1=478
7035       CorrelID1=nfgtasks+fg_rank+1
7036       ireq=0
7037 C Receive the numbers of needed contacts from other processors
7038       do ii=1,ntask_cont_from
7039         iproc=itask_cont_from(ii)
7040         ireq=ireq+1
7041         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7042      &    FG_COMM,req(ireq),IERR)
7043       enddo
7044 c      write (iout,*) "IRECV ended"
7045 c      call flush(iout)
7046 C Send the number of contacts needed by other processors
7047       do ii=1,ntask_cont_to
7048         iproc=itask_cont_to(ii)
7049         ireq=ireq+1
7050         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7051      &    FG_COMM,req(ireq),IERR)
7052       enddo
7053 c      write (iout,*) "ISEND ended"
7054 c      write (iout,*) "number of requests (nn)",ireq
7055       call flush(iout)
7056       if (ireq.gt.0)
7057      &  call MPI_Waitall(ireq,req,status_array,ierr)
7058 c      write (iout,*)
7059 c     &  "Numbers of contacts to be received from other processors",
7060 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7061 c      call flush(iout)
7062 C Receive contacts
7063       ireq=0
7064       do ii=1,ntask_cont_from
7065         iproc=itask_cont_from(ii)
7066         nn=ncont_recv(ii)
7067 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7068 c     &   " of CONT_TO_COMM group"
7069         call flush(iout)
7070         if (nn.gt.0) then
7071           ireq=ireq+1
7072           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7073      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7074 c          write (iout,*) "ireq,req",ireq,req(ireq)
7075         endif
7076       enddo
7077 C Send the contacts to processors that need them
7078       do ii=1,ntask_cont_to
7079         iproc=itask_cont_to(ii)
7080         nn=ncont_sent(ii)
7081 c        write (iout,*) nn," contacts to processor",iproc,
7082 c     &   " of CONT_TO_COMM group"
7083         if (nn.gt.0) then
7084           ireq=ireq+1
7085           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7086      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7087 c          write (iout,*) "ireq,req",ireq,req(ireq)
7088 c          do i=1,nn
7089 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7090 c          enddo
7091         endif
7092       enddo
7093 c      write (iout,*) "number of requests (contacts)",ireq
7094 c      write (iout,*) "req",(req(i),i=1,4)
7095 c      call flush(iout)
7096       if (ireq.gt.0)
7097      & call MPI_Waitall(ireq,req,status_array,ierr)
7098       do iii=1,ntask_cont_from
7099         iproc=itask_cont_from(iii)
7100         nn=ncont_recv(iii)
7101         if (lprn) then
7102         write (iout,*) "Received",nn," contacts from processor",iproc,
7103      &   " of CONT_FROM_COMM group"
7104         call flush(iout)
7105         do i=1,nn
7106           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7107         enddo
7108         call flush(iout)
7109         endif
7110         do i=1,nn
7111           ii=zapas_recv(1,i,iii)
7112 c Flag the received contacts to prevent double-counting
7113           jj=-zapas_recv(2,i,iii)
7114 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7115 c          call flush(iout)
7116           nnn=num_cont_hb(ii)+1
7117           num_cont_hb(ii)=nnn
7118           jcont_hb(nnn,ii)=jj
7119           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7120           ind=3
7121           do kk=1,3
7122             ind=ind+1
7123             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7124           enddo
7125           do kk=1,2
7126             do ll=1,2
7127               ind=ind+1
7128               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7129             enddo
7130           enddo
7131           do jj=1,5
7132             do kk=1,3
7133               do ll=1,2
7134                 do mm=1,2
7135                   ind=ind+1
7136                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7137                 enddo
7138               enddo
7139             enddo
7140           enddo
7141         enddo
7142       enddo
7143       call flush(iout)
7144       if (lprn) then
7145         write (iout,'(a)') 'Contact function values after receive:'
7146         do i=nnt,nct-2
7147           write (iout,'(2i3,50(1x,i3,5f6.3))')
7148      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7149      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7150         enddo
7151         call flush(iout)
7152       endif
7153    30 continue
7154 #endif
7155       if (lprn) then
7156         write (iout,'(a)') 'Contact function values:'
7157         do i=nnt,nct-2
7158           write (iout,'(2i3,50(1x,i2,5f6.3))')
7159      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7160      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7161         enddo
7162       endif
7163       ecorr=0.0D0
7164       ecorr5=0.0d0
7165       ecorr6=0.0d0
7166 C Remove the loop below after debugging !!!
7167       do i=nnt,nct
7168         do j=1,3
7169           gradcorr(j,i)=0.0D0
7170           gradxorr(j,i)=0.0D0
7171         enddo
7172       enddo
7173 C Calculate the dipole-dipole interaction energies
7174       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7175       do i=iatel_s,iatel_e+1
7176         num_conti=num_cont_hb(i)
7177         do jj=1,num_conti
7178           j=jcont_hb(jj,i)
7179 #ifdef MOMENT
7180           call dipole(i,j,jj)
7181 #endif
7182         enddo
7183       enddo
7184       endif
7185 C Calculate the local-electrostatic correlation terms
7186 c                write (iout,*) "gradcorr5 in eello5 before loop"
7187 c                do iii=1,nres
7188 c                  write (iout,'(i5,3f10.5)')
7189 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7190 c                enddo
7191       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7192 c        write (iout,*) "corr loop i",i
7193         i1=i+1
7194         num_conti=num_cont_hb(i)
7195         num_conti1=num_cont_hb(i+1)
7196         do jj=1,num_conti
7197           j=jcont_hb(jj,i)
7198           jp=iabs(j)
7199           do kk=1,num_conti1
7200             j1=jcont_hb(kk,i1)
7201             jp1=iabs(j1)
7202 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7203 c     &         ' jj=',jj,' kk=',kk
7204 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7205             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7206      &          .or. j.lt.0 .and. j1.gt.0) .and.
7207      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7208 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7209 C The system gains extra energy.
7210               n_corr=n_corr+1
7211               sqd1=dsqrt(d_cont(jj,i))
7212               sqd2=dsqrt(d_cont(kk,i1))
7213               sred_geom = sqd1*sqd2
7214               IF (sred_geom.lt.cutoff_corr) THEN
7215                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7216      &            ekont,fprimcont)
7217 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7218 cd     &         ' jj=',jj,' kk=',kk
7219                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7220                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7221                 do l=1,3
7222                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7223                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7224                 enddo
7225                 n_corr1=n_corr1+1
7226 cd               write (iout,*) 'sred_geom=',sred_geom,
7227 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7228 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7229 cd               write (iout,*) "g_contij",g_contij
7230 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7231 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7232                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7233                 if (wcorr4.gt.0.0d0)
7234      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7235                   if (energy_dec.and.wcorr4.gt.0.0d0)
7236      1                 write (iout,'(a6,4i5,0pf7.3)')
7237      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7238 c                write (iout,*) "gradcorr5 before eello5"
7239 c                do iii=1,nres
7240 c                  write (iout,'(i5,3f10.5)')
7241 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7242 c                enddo
7243                 if (wcorr5.gt.0.0d0)
7244      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7245 c                write (iout,*) "gradcorr5 after eello5"
7246 c                do iii=1,nres
7247 c                  write (iout,'(i5,3f10.5)')
7248 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7249 c                enddo
7250                   if (energy_dec.and.wcorr5.gt.0.0d0)
7251      1                 write (iout,'(a6,4i5,0pf7.3)')
7252      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7253 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7254 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7255                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7256      &               .or. wturn6.eq.0.0d0))then
7257 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7258                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7259                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7260      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7261 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7262 cd     &            'ecorr6=',ecorr6
7263 cd                write (iout,'(4e15.5)') sred_geom,
7264 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7265 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7266 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7267                 else if (wturn6.gt.0.0d0
7268      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7269 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7270                   eturn6=eturn6+eello_turn6(i,jj,kk)
7271                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7272      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7273 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7274                 endif
7275               ENDIF
7276 1111          continue
7277             endif
7278           enddo ! kk
7279         enddo ! jj
7280       enddo ! i
7281       do i=1,nres
7282         num_cont_hb(i)=num_cont_hb_old(i)
7283       enddo
7284 c                write (iout,*) "gradcorr5 in eello5"
7285 c                do iii=1,nres
7286 c                  write (iout,'(i5,3f10.5)')
7287 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7288 c                enddo
7289       return
7290       end
7291 c------------------------------------------------------------------------------
7292       subroutine add_hb_contact_eello(ii,jj,itask)
7293       implicit real*8 (a-h,o-z)
7294       include "DIMENSIONS"
7295       include "COMMON.IOUNITS"
7296       integer max_cont
7297       integer max_dim
7298       parameter (max_cont=maxconts)
7299       parameter (max_dim=70)
7300       include "COMMON.CONTACTS"
7301       double precision zapas(max_dim,maxconts,max_fg_procs),
7302      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7303       common /przechowalnia/ zapas
7304       integer i,j,ii,jj,iproc,itask(4),nn
7305 c      write (iout,*) "itask",itask
7306       do i=1,2
7307         iproc=itask(i)
7308         if (iproc.gt.0) then
7309           do j=1,num_cont_hb(ii)
7310             jjc=jcont_hb(j,ii)
7311 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7312             if (jjc.eq.jj) then
7313               ncont_sent(iproc)=ncont_sent(iproc)+1
7314               nn=ncont_sent(iproc)
7315               zapas(1,nn,iproc)=ii
7316               zapas(2,nn,iproc)=jjc
7317               zapas(3,nn,iproc)=d_cont(j,ii)
7318               ind=3
7319               do kk=1,3
7320                 ind=ind+1
7321                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7322               enddo
7323               do kk=1,2
7324                 do ll=1,2
7325                   ind=ind+1
7326                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7327                 enddo
7328               enddo
7329               do jj=1,5
7330                 do kk=1,3
7331                   do ll=1,2
7332                     do mm=1,2
7333                       ind=ind+1
7334                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7335                     enddo
7336                   enddo
7337                 enddo
7338               enddo
7339               exit
7340             endif
7341           enddo
7342         endif
7343       enddo
7344       return
7345       end
7346 c------------------------------------------------------------------------------
7347       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7348       implicit real*8 (a-h,o-z)
7349       include 'DIMENSIONS'
7350       include 'COMMON.IOUNITS'
7351       include 'COMMON.DERIV'
7352       include 'COMMON.INTERACT'
7353       include 'COMMON.CONTACTS'
7354       double precision gx(3),gx1(3)
7355       logical lprn
7356       lprn=.false.
7357       eij=facont_hb(jj,i)
7358       ekl=facont_hb(kk,k)
7359       ees0pij=ees0p(jj,i)
7360       ees0pkl=ees0p(kk,k)
7361       ees0mij=ees0m(jj,i)
7362       ees0mkl=ees0m(kk,k)
7363       ekont=eij*ekl
7364       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7365 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7366 C Following 4 lines for diagnostics.
7367 cd    ees0pkl=0.0D0
7368 cd    ees0pij=1.0D0
7369 cd    ees0mkl=0.0D0
7370 cd    ees0mij=1.0D0
7371 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7372 c     & 'Contacts ',i,j,
7373 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7374 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7375 c     & 'gradcorr_long'
7376 C Calculate the multi-body contribution to energy.
7377 c      ecorr=ecorr+ekont*ees
7378 C Calculate multi-body contributions to the gradient.
7379       coeffpees0pij=coeffp*ees0pij
7380       coeffmees0mij=coeffm*ees0mij
7381       coeffpees0pkl=coeffp*ees0pkl
7382       coeffmees0mkl=coeffm*ees0mkl
7383       do ll=1,3
7384 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7385         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7386      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7387      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7388         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7389      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7390      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7391 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7392         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7393      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7394      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7395         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7396      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7397      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7398         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7399      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7400      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7401         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7402         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7403         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7404      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7405      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7406         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7407         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7408 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7409       enddo
7410 c      write (iout,*)
7411 cgrad      do m=i+1,j-1
7412 cgrad        do ll=1,3
7413 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7414 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7415 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7416 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7417 cgrad        enddo
7418 cgrad      enddo
7419 cgrad      do m=k+1,l-1
7420 cgrad        do ll=1,3
7421 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7422 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7423 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7424 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7425 cgrad        enddo
7426 cgrad      enddo
7427 c      write (iout,*) "ehbcorr",ekont*ees
7428       ehbcorr=ekont*ees
7429       return
7430       end
7431 #ifdef MOMENT
7432 C---------------------------------------------------------------------------
7433       subroutine dipole(i,j,jj)
7434       implicit real*8 (a-h,o-z)
7435       include 'DIMENSIONS'
7436       include 'COMMON.IOUNITS'
7437       include 'COMMON.CHAIN'
7438       include 'COMMON.FFIELD'
7439       include 'COMMON.DERIV'
7440       include 'COMMON.INTERACT'
7441       include 'COMMON.CONTACTS'
7442       include 'COMMON.TORSION'
7443       include 'COMMON.VAR'
7444       include 'COMMON.GEO'
7445       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7446      &  auxmat(2,2)
7447       iti1 = itortyp(itype(i+1))
7448       if (j.lt.nres-1) then
7449         itj1 = itortyp(itype(j+1))
7450       else
7451         itj1=ntortyp
7452       endif
7453       do iii=1,2
7454         dipi(iii,1)=Ub2(iii,i)
7455         dipderi(iii)=Ub2der(iii,i)
7456         dipi(iii,2)=b1(iii,iti1)
7457         dipj(iii,1)=Ub2(iii,j)
7458         dipderj(iii)=Ub2der(iii,j)
7459         dipj(iii,2)=b1(iii,itj1)
7460       enddo
7461       kkk=0
7462       do iii=1,2
7463         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7464         do jjj=1,2
7465           kkk=kkk+1
7466           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7467         enddo
7468       enddo
7469       do kkk=1,5
7470         do lll=1,3
7471           mmm=0
7472           do iii=1,2
7473             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7474      &        auxvec(1))
7475             do jjj=1,2
7476               mmm=mmm+1
7477               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7478             enddo
7479           enddo
7480         enddo
7481       enddo
7482       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7483       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7484       do iii=1,2
7485         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7486       enddo
7487       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7488       do iii=1,2
7489         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7490       enddo
7491       return
7492       end
7493 #endif
7494 C---------------------------------------------------------------------------
7495       subroutine calc_eello(i,j,k,l,jj,kk)
7496 C
7497 C This subroutine computes matrices and vectors needed to calculate
7498 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7499 C
7500       implicit real*8 (a-h,o-z)
7501       include 'DIMENSIONS'
7502       include 'COMMON.IOUNITS'
7503       include 'COMMON.CHAIN'
7504       include 'COMMON.DERIV'
7505       include 'COMMON.INTERACT'
7506       include 'COMMON.CONTACTS'
7507       include 'COMMON.TORSION'
7508       include 'COMMON.VAR'
7509       include 'COMMON.GEO'
7510       include 'COMMON.FFIELD'
7511       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7512      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7513       logical lprn
7514       common /kutas/ lprn
7515 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7516 cd     & ' jj=',jj,' kk=',kk
7517 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7518 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7519 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7520       do iii=1,2
7521         do jjj=1,2
7522           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7523           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7524         enddo
7525       enddo
7526       call transpose2(aa1(1,1),aa1t(1,1))
7527       call transpose2(aa2(1,1),aa2t(1,1))
7528       do kkk=1,5
7529         do lll=1,3
7530           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7531      &      aa1tder(1,1,lll,kkk))
7532           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7533      &      aa2tder(1,1,lll,kkk))
7534         enddo
7535       enddo
7536       if (l.eq.j+1) then
7537 C parallel orientation of the two CA-CA-CA frames.
7538         if (i.gt.1) then
7539           iti=itortyp(itype(i))
7540         else
7541           iti=ntortyp
7542         endif
7543         itk1=itortyp(itype(k+1))
7544         itj=itortyp(itype(j))
7545         if (l.lt.nres-1) then
7546           itl1=itortyp(itype(l+1))
7547         else
7548           itl1=ntortyp
7549         endif
7550 C A1 kernel(j+1) A2T
7551 cd        do iii=1,2
7552 cd          write (iout,'(3f10.5,5x,3f10.5)')
7553 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7554 cd        enddo
7555         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7556      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7557      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7558 C Following matrices are needed only for 6-th order cumulants
7559         IF (wcorr6.gt.0.0d0) THEN
7560         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7561      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7562      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7563         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7564      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7565      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7566      &   ADtEAderx(1,1,1,1,1,1))
7567         lprn=.false.
7568         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7569      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7570      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7571      &   ADtEA1derx(1,1,1,1,1,1))
7572         ENDIF
7573 C End 6-th order cumulants
7574 cd        lprn=.false.
7575 cd        if (lprn) then
7576 cd        write (2,*) 'In calc_eello6'
7577 cd        do iii=1,2
7578 cd          write (2,*) 'iii=',iii
7579 cd          do kkk=1,5
7580 cd            write (2,*) 'kkk=',kkk
7581 cd            do jjj=1,2
7582 cd              write (2,'(3(2f10.5),5x)')
7583 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7584 cd            enddo
7585 cd          enddo
7586 cd        enddo
7587 cd        endif
7588         call transpose2(EUgder(1,1,k),auxmat(1,1))
7589         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7590         call transpose2(EUg(1,1,k),auxmat(1,1))
7591         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7592         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7593         do iii=1,2
7594           do kkk=1,5
7595             do lll=1,3
7596               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7597      &          EAEAderx(1,1,lll,kkk,iii,1))
7598             enddo
7599           enddo
7600         enddo
7601 C A1T kernel(i+1) A2
7602         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7603      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7604      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7605 C Following matrices are needed only for 6-th order cumulants
7606         IF (wcorr6.gt.0.0d0) THEN
7607         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7608      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7609      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7610         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7611      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7612      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7613      &   ADtEAderx(1,1,1,1,1,2))
7614         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7615      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7616      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7617      &   ADtEA1derx(1,1,1,1,1,2))
7618         ENDIF
7619 C End 6-th order cumulants
7620         call transpose2(EUgder(1,1,l),auxmat(1,1))
7621         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7622         call transpose2(EUg(1,1,l),auxmat(1,1))
7623         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7624         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7625         do iii=1,2
7626           do kkk=1,5
7627             do lll=1,3
7628               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7629      &          EAEAderx(1,1,lll,kkk,iii,2))
7630             enddo
7631           enddo
7632         enddo
7633 C AEAb1 and AEAb2
7634 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7635 C They are needed only when the fifth- or the sixth-order cumulants are
7636 C indluded.
7637         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7638         call transpose2(AEA(1,1,1),auxmat(1,1))
7639         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7640         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7641         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7642         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7643         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7644         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7645         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7646         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7647         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7648         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7649         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7650         call transpose2(AEA(1,1,2),auxmat(1,1))
7651         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7652         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7653         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7654         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7655         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7656         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7657         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7658         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7659         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7660         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7661         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7662 C Calculate the Cartesian derivatives of the vectors.
7663         do iii=1,2
7664           do kkk=1,5
7665             do lll=1,3
7666               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7667               call matvec2(auxmat(1,1),b1(1,iti),
7668      &          AEAb1derx(1,lll,kkk,iii,1,1))
7669               call matvec2(auxmat(1,1),Ub2(1,i),
7670      &          AEAb2derx(1,lll,kkk,iii,1,1))
7671               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7672      &          AEAb1derx(1,lll,kkk,iii,2,1))
7673               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7674      &          AEAb2derx(1,lll,kkk,iii,2,1))
7675               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7676               call matvec2(auxmat(1,1),b1(1,itj),
7677      &          AEAb1derx(1,lll,kkk,iii,1,2))
7678               call matvec2(auxmat(1,1),Ub2(1,j),
7679      &          AEAb2derx(1,lll,kkk,iii,1,2))
7680               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7681      &          AEAb1derx(1,lll,kkk,iii,2,2))
7682               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7683      &          AEAb2derx(1,lll,kkk,iii,2,2))
7684             enddo
7685           enddo
7686         enddo
7687         ENDIF
7688 C End vectors
7689       else
7690 C Antiparallel orientation of the two CA-CA-CA frames.
7691         if (i.gt.1) then
7692           iti=itortyp(itype(i))
7693         else
7694           iti=ntortyp
7695         endif
7696         itk1=itortyp(itype(k+1))
7697         itl=itortyp(itype(l))
7698         itj=itortyp(itype(j))
7699         if (j.lt.nres-1) then
7700           itj1=itortyp(itype(j+1))
7701         else
7702           itj1=ntortyp
7703         endif
7704 C A2 kernel(j-1)T A1T
7705         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7706      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7707      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7708 C Following matrices are needed only for 6-th order cumulants
7709         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7710      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7711         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7712      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7713      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7714         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7715      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7716      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7717      &   ADtEAderx(1,1,1,1,1,1))
7718         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7719      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7720      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7721      &   ADtEA1derx(1,1,1,1,1,1))
7722         ENDIF
7723 C End 6-th order cumulants
7724         call transpose2(EUgder(1,1,k),auxmat(1,1))
7725         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7726         call transpose2(EUg(1,1,k),auxmat(1,1))
7727         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7728         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7729         do iii=1,2
7730           do kkk=1,5
7731             do lll=1,3
7732               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7733      &          EAEAderx(1,1,lll,kkk,iii,1))
7734             enddo
7735           enddo
7736         enddo
7737 C A2T kernel(i+1)T A1
7738         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7739      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7740      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7741 C Following matrices are needed only for 6-th order cumulants
7742         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7743      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7744         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7745      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7746      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7747         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7748      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7749      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7750      &   ADtEAderx(1,1,1,1,1,2))
7751         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7752      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7753      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7754      &   ADtEA1derx(1,1,1,1,1,2))
7755         ENDIF
7756 C End 6-th order cumulants
7757         call transpose2(EUgder(1,1,j),auxmat(1,1))
7758         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7759         call transpose2(EUg(1,1,j),auxmat(1,1))
7760         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7761         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7762         do iii=1,2
7763           do kkk=1,5
7764             do lll=1,3
7765               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7766      &          EAEAderx(1,1,lll,kkk,iii,2))
7767             enddo
7768           enddo
7769         enddo
7770 C AEAb1 and AEAb2
7771 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7772 C They are needed only when the fifth- or the sixth-order cumulants are
7773 C indluded.
7774         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7775      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7776         call transpose2(AEA(1,1,1),auxmat(1,1))
7777         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7778         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7779         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7780         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7781         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7782         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7783         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7784         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7785         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7786         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7787         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7788         call transpose2(AEA(1,1,2),auxmat(1,1))
7789         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7790         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7791         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7792         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7793         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7794         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7795         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7796         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7797         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7798         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7799         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7800 C Calculate the Cartesian derivatives of the vectors.
7801         do iii=1,2
7802           do kkk=1,5
7803             do lll=1,3
7804               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7805               call matvec2(auxmat(1,1),b1(1,iti),
7806      &          AEAb1derx(1,lll,kkk,iii,1,1))
7807               call matvec2(auxmat(1,1),Ub2(1,i),
7808      &          AEAb2derx(1,lll,kkk,iii,1,1))
7809               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7810      &          AEAb1derx(1,lll,kkk,iii,2,1))
7811               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7812      &          AEAb2derx(1,lll,kkk,iii,2,1))
7813               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7814               call matvec2(auxmat(1,1),b1(1,itl),
7815      &          AEAb1derx(1,lll,kkk,iii,1,2))
7816               call matvec2(auxmat(1,1),Ub2(1,l),
7817      &          AEAb2derx(1,lll,kkk,iii,1,2))
7818               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7819      &          AEAb1derx(1,lll,kkk,iii,2,2))
7820               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7821      &          AEAb2derx(1,lll,kkk,iii,2,2))
7822             enddo
7823           enddo
7824         enddo
7825         ENDIF
7826 C End vectors
7827       endif
7828       return
7829       end
7830 C---------------------------------------------------------------------------
7831       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7832      &  KK,KKderg,AKA,AKAderg,AKAderx)
7833       implicit none
7834       integer nderg
7835       logical transp
7836       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7837      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7838      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7839       integer iii,kkk,lll
7840       integer jjj,mmm
7841       logical lprn
7842       common /kutas/ lprn
7843       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7844       do iii=1,nderg
7845         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7846      &    AKAderg(1,1,iii))
7847       enddo
7848 cd      if (lprn) write (2,*) 'In kernel'
7849       do kkk=1,5
7850 cd        if (lprn) write (2,*) 'kkk=',kkk
7851         do lll=1,3
7852           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7853      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7854 cd          if (lprn) then
7855 cd            write (2,*) 'lll=',lll
7856 cd            write (2,*) 'iii=1'
7857 cd            do jjj=1,2
7858 cd              write (2,'(3(2f10.5),5x)')
7859 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7860 cd            enddo
7861 cd          endif
7862           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7863      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7864 cd          if (lprn) then
7865 cd            write (2,*) 'lll=',lll
7866 cd            write (2,*) 'iii=2'
7867 cd            do jjj=1,2
7868 cd              write (2,'(3(2f10.5),5x)')
7869 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7870 cd            enddo
7871 cd          endif
7872         enddo
7873       enddo
7874       return
7875       end
7876 C---------------------------------------------------------------------------
7877       double precision function eello4(i,j,k,l,jj,kk)
7878       implicit real*8 (a-h,o-z)
7879       include 'DIMENSIONS'
7880       include 'COMMON.IOUNITS'
7881       include 'COMMON.CHAIN'
7882       include 'COMMON.DERIV'
7883       include 'COMMON.INTERACT'
7884       include 'COMMON.CONTACTS'
7885       include 'COMMON.TORSION'
7886       include 'COMMON.VAR'
7887       include 'COMMON.GEO'
7888       double precision pizda(2,2),ggg1(3),ggg2(3)
7889 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7890 cd        eello4=0.0d0
7891 cd        return
7892 cd      endif
7893 cd      print *,'eello4:',i,j,k,l,jj,kk
7894 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7895 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7896 cold      eij=facont_hb(jj,i)
7897 cold      ekl=facont_hb(kk,k)
7898 cold      ekont=eij*ekl
7899       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7900 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7901       gcorr_loc(k-1)=gcorr_loc(k-1)
7902      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7903       if (l.eq.j+1) then
7904         gcorr_loc(l-1)=gcorr_loc(l-1)
7905      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7906       else
7907         gcorr_loc(j-1)=gcorr_loc(j-1)
7908      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7909       endif
7910       do iii=1,2
7911         do kkk=1,5
7912           do lll=1,3
7913             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7914      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7915 cd            derx(lll,kkk,iii)=0.0d0
7916           enddo
7917         enddo
7918       enddo
7919 cd      gcorr_loc(l-1)=0.0d0
7920 cd      gcorr_loc(j-1)=0.0d0
7921 cd      gcorr_loc(k-1)=0.0d0
7922 cd      eel4=1.0d0
7923 cd      write (iout,*)'Contacts have occurred for peptide groups',
7924 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7925 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7926       if (j.lt.nres-1) then
7927         j1=j+1
7928         j2=j-1
7929       else
7930         j1=j-1
7931         j2=j-2
7932       endif
7933       if (l.lt.nres-1) then
7934         l1=l+1
7935         l2=l-1
7936       else
7937         l1=l-1
7938         l2=l-2
7939       endif
7940       do ll=1,3
7941 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7942 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7943         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7944         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7945 cgrad        ghalf=0.5d0*ggg1(ll)
7946         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7947         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7948         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7949         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7950         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7951         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7952 cgrad        ghalf=0.5d0*ggg2(ll)
7953         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7954         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7955         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7956         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7957         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7958         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7959       enddo
7960 cgrad      do m=i+1,j-1
7961 cgrad        do ll=1,3
7962 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7963 cgrad        enddo
7964 cgrad      enddo
7965 cgrad      do m=k+1,l-1
7966 cgrad        do ll=1,3
7967 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7968 cgrad        enddo
7969 cgrad      enddo
7970 cgrad      do m=i+2,j2
7971 cgrad        do ll=1,3
7972 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7973 cgrad        enddo
7974 cgrad      enddo
7975 cgrad      do m=k+2,l2
7976 cgrad        do ll=1,3
7977 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7978 cgrad        enddo
7979 cgrad      enddo
7980 cd      do iii=1,nres-3
7981 cd        write (2,*) iii,gcorr_loc(iii)
7982 cd      enddo
7983       eello4=ekont*eel4
7984 cd      write (2,*) 'ekont',ekont
7985 cd      write (iout,*) 'eello4',ekont*eel4
7986       return
7987       end
7988 C---------------------------------------------------------------------------
7989       double precision function eello5(i,j,k,l,jj,kk)
7990       implicit real*8 (a-h,o-z)
7991       include 'DIMENSIONS'
7992       include 'COMMON.IOUNITS'
7993       include 'COMMON.CHAIN'
7994       include 'COMMON.DERIV'
7995       include 'COMMON.INTERACT'
7996       include 'COMMON.CONTACTS'
7997       include 'COMMON.TORSION'
7998       include 'COMMON.VAR'
7999       include 'COMMON.GEO'
8000       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8001       double precision ggg1(3),ggg2(3)
8002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8003 C                                                                              C
8004 C                            Parallel chains                                   C
8005 C                                                                              C
8006 C          o             o                   o             o                   C
8007 C         /l\           / \             \   / \           / \   /              C
8008 C        /   \         /   \             \ /   \         /   \ /               C
8009 C       j| o |l1       | o |              o| o |         | o |o                C
8010 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8011 C      \i/   \         /   \ /             /   \         /   \                 C
8012 C       o    k1             o                                                  C
8013 C         (I)          (II)                (III)          (IV)                 C
8014 C                                                                              C
8015 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8016 C                                                                              C
8017 C                            Antiparallel chains                               C
8018 C                                                                              C
8019 C          o             o                   o             o                   C
8020 C         /j\           / \             \   / \           / \   /              C
8021 C        /   \         /   \             \ /   \         /   \ /               C
8022 C      j1| o |l        | o |              o| o |         | o |o                C
8023 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8024 C      \i/   \         /   \ /             /   \         /   \                 C
8025 C       o     k1            o                                                  C
8026 C         (I)          (II)                (III)          (IV)                 C
8027 C                                                                              C
8028 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8029 C                                                                              C
8030 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8031 C                                                                              C
8032 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8033 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8034 cd        eello5=0.0d0
8035 cd        return
8036 cd      endif
8037 cd      write (iout,*)
8038 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8039 cd     &   ' and',k,l
8040       itk=itortyp(itype(k))
8041       itl=itortyp(itype(l))
8042       itj=itortyp(itype(j))
8043       eello5_1=0.0d0
8044       eello5_2=0.0d0
8045       eello5_3=0.0d0
8046       eello5_4=0.0d0
8047 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8048 cd     &   eel5_3_num,eel5_4_num)
8049       do iii=1,2
8050         do kkk=1,5
8051           do lll=1,3
8052             derx(lll,kkk,iii)=0.0d0
8053           enddo
8054         enddo
8055       enddo
8056 cd      eij=facont_hb(jj,i)
8057 cd      ekl=facont_hb(kk,k)
8058 cd      ekont=eij*ekl
8059 cd      write (iout,*)'Contacts have occurred for peptide groups',
8060 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8061 cd      goto 1111
8062 C Contribution from the graph I.
8063 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8064 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8065       call transpose2(EUg(1,1,k),auxmat(1,1))
8066       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8067       vv(1)=pizda(1,1)-pizda(2,2)
8068       vv(2)=pizda(1,2)+pizda(2,1)
8069       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8070      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8071 C Explicit gradient in virtual-dihedral angles.
8072       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8073      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8074      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8075       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8076       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8077       vv(1)=pizda(1,1)-pizda(2,2)
8078       vv(2)=pizda(1,2)+pizda(2,1)
8079       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8080      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8081      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8082       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8083       vv(1)=pizda(1,1)-pizda(2,2)
8084       vv(2)=pizda(1,2)+pizda(2,1)
8085       if (l.eq.j+1) then
8086         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8087      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8088      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8089       else
8090         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8091      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8092      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8093       endif
8094 C Cartesian gradient
8095       do iii=1,2
8096         do kkk=1,5
8097           do lll=1,3
8098             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8099      &        pizda(1,1))
8100             vv(1)=pizda(1,1)-pizda(2,2)
8101             vv(2)=pizda(1,2)+pizda(2,1)
8102             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8103      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8104      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8105           enddo
8106         enddo
8107       enddo
8108 c      goto 1112
8109 c1111  continue
8110 C Contribution from graph II
8111       call transpose2(EE(1,1,itk),auxmat(1,1))
8112       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8113       vv(1)=pizda(1,1)+pizda(2,2)
8114       vv(2)=pizda(2,1)-pizda(1,2)
8115       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8116      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8117 C Explicit gradient in virtual-dihedral angles.
8118       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8119      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8120       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8121       vv(1)=pizda(1,1)+pizda(2,2)
8122       vv(2)=pizda(2,1)-pizda(1,2)
8123       if (l.eq.j+1) then
8124         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8125      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8126      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8127       else
8128         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8129      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8130      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8131       endif
8132 C Cartesian gradient
8133       do iii=1,2
8134         do kkk=1,5
8135           do lll=1,3
8136             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8137      &        pizda(1,1))
8138             vv(1)=pizda(1,1)+pizda(2,2)
8139             vv(2)=pizda(2,1)-pizda(1,2)
8140             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8141      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8142      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8143           enddo
8144         enddo
8145       enddo
8146 cd      goto 1112
8147 cd1111  continue
8148       if (l.eq.j+1) then
8149 cd        goto 1110
8150 C Parallel orientation
8151 C Contribution from graph III
8152         call transpose2(EUg(1,1,l),auxmat(1,1))
8153         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8154         vv(1)=pizda(1,1)-pizda(2,2)
8155         vv(2)=pizda(1,2)+pizda(2,1)
8156         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8157      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8158 C Explicit gradient in virtual-dihedral angles.
8159         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8160      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8161      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8162         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8163         vv(1)=pizda(1,1)-pizda(2,2)
8164         vv(2)=pizda(1,2)+pizda(2,1)
8165         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8166      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8167      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8168         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8169         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8170         vv(1)=pizda(1,1)-pizda(2,2)
8171         vv(2)=pizda(1,2)+pizda(2,1)
8172         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8173      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8174      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8175 C Cartesian gradient
8176         do iii=1,2
8177           do kkk=1,5
8178             do lll=1,3
8179               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8180      &          pizda(1,1))
8181               vv(1)=pizda(1,1)-pizda(2,2)
8182               vv(2)=pizda(1,2)+pizda(2,1)
8183               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8184      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8185      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8186             enddo
8187           enddo
8188         enddo
8189 cd        goto 1112
8190 C Contribution from graph IV
8191 cd1110    continue
8192         call transpose2(EE(1,1,itl),auxmat(1,1))
8193         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8194         vv(1)=pizda(1,1)+pizda(2,2)
8195         vv(2)=pizda(2,1)-pizda(1,2)
8196         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8197      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8198 C Explicit gradient in virtual-dihedral angles.
8199         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8200      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8201         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8202         vv(1)=pizda(1,1)+pizda(2,2)
8203         vv(2)=pizda(2,1)-pizda(1,2)
8204         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8205      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8206      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8207 C Cartesian gradient
8208         do iii=1,2
8209           do kkk=1,5
8210             do lll=1,3
8211               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8212      &          pizda(1,1))
8213               vv(1)=pizda(1,1)+pizda(2,2)
8214               vv(2)=pizda(2,1)-pizda(1,2)
8215               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8216      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8217      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8218             enddo
8219           enddo
8220         enddo
8221       else
8222 C Antiparallel orientation
8223 C Contribution from graph III
8224 c        goto 1110
8225         call transpose2(EUg(1,1,j),auxmat(1,1))
8226         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8227         vv(1)=pizda(1,1)-pizda(2,2)
8228         vv(2)=pizda(1,2)+pizda(2,1)
8229         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8230      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8231 C Explicit gradient in virtual-dihedral angles.
8232         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8233      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8234      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8235         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8236         vv(1)=pizda(1,1)-pizda(2,2)
8237         vv(2)=pizda(1,2)+pizda(2,1)
8238         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8239      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8240      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8241         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8242         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8243         vv(1)=pizda(1,1)-pizda(2,2)
8244         vv(2)=pizda(1,2)+pizda(2,1)
8245         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8246      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8247      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8248 C Cartesian gradient
8249         do iii=1,2
8250           do kkk=1,5
8251             do lll=1,3
8252               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8253      &          pizda(1,1))
8254               vv(1)=pizda(1,1)-pizda(2,2)
8255               vv(2)=pizda(1,2)+pizda(2,1)
8256               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8257      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8258      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8259             enddo
8260           enddo
8261         enddo
8262 cd        goto 1112
8263 C Contribution from graph IV
8264 1110    continue
8265         call transpose2(EE(1,1,itj),auxmat(1,1))
8266         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8267         vv(1)=pizda(1,1)+pizda(2,2)
8268         vv(2)=pizda(2,1)-pizda(1,2)
8269         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8270      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8271 C Explicit gradient in virtual-dihedral angles.
8272         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8273      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8274         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8275         vv(1)=pizda(1,1)+pizda(2,2)
8276         vv(2)=pizda(2,1)-pizda(1,2)
8277         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8278      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8279      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8280 C Cartesian gradient
8281         do iii=1,2
8282           do kkk=1,5
8283             do lll=1,3
8284               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8285      &          pizda(1,1))
8286               vv(1)=pizda(1,1)+pizda(2,2)
8287               vv(2)=pizda(2,1)-pizda(1,2)
8288               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8289      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8290      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8291             enddo
8292           enddo
8293         enddo
8294       endif
8295 1112  continue
8296       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8297 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8298 cd        write (2,*) 'ijkl',i,j,k,l
8299 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8300 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8301 cd      endif
8302 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8303 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8304 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8305 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8306       if (j.lt.nres-1) then
8307         j1=j+1
8308         j2=j-1
8309       else
8310         j1=j-1
8311         j2=j-2
8312       endif
8313       if (l.lt.nres-1) then
8314         l1=l+1
8315         l2=l-1
8316       else
8317         l1=l-1
8318         l2=l-2
8319       endif
8320 cd      eij=1.0d0
8321 cd      ekl=1.0d0
8322 cd      ekont=1.0d0
8323 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8324 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8325 C        summed up outside the subrouine as for the other subroutines
8326 C        handling long-range interactions. The old code is commented out
8327 C        with "cgrad" to keep track of changes.
8328       do ll=1,3
8329 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8330 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8331         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8332         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8333 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8334 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8335 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8336 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8337 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8338 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8339 c     &   gradcorr5ij,
8340 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8341 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8342 cgrad        ghalf=0.5d0*ggg1(ll)
8343 cd        ghalf=0.0d0
8344         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8345         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8346         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8347         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8348         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8349         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8350 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8351 cgrad        ghalf=0.5d0*ggg2(ll)
8352 cd        ghalf=0.0d0
8353         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8354         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8355         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8356         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8357         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8358         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8359       enddo
8360 cd      goto 1112
8361 cgrad      do m=i+1,j-1
8362 cgrad        do ll=1,3
8363 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8364 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8365 cgrad        enddo
8366 cgrad      enddo
8367 cgrad      do m=k+1,l-1
8368 cgrad        do ll=1,3
8369 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8370 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8371 cgrad        enddo
8372 cgrad      enddo
8373 c1112  continue
8374 cgrad      do m=i+2,j2
8375 cgrad        do ll=1,3
8376 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8377 cgrad        enddo
8378 cgrad      enddo
8379 cgrad      do m=k+2,l2
8380 cgrad        do ll=1,3
8381 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8382 cgrad        enddo
8383 cgrad      enddo
8384 cd      do iii=1,nres-3
8385 cd        write (2,*) iii,g_corr5_loc(iii)
8386 cd      enddo
8387       eello5=ekont*eel5
8388 cd      write (2,*) 'ekont',ekont
8389 cd      write (iout,*) 'eello5',ekont*eel5
8390       return
8391       end
8392 c--------------------------------------------------------------------------
8393       double precision function eello6(i,j,k,l,jj,kk)
8394       implicit real*8 (a-h,o-z)
8395       include 'DIMENSIONS'
8396       include 'COMMON.IOUNITS'
8397       include 'COMMON.CHAIN'
8398       include 'COMMON.DERIV'
8399       include 'COMMON.INTERACT'
8400       include 'COMMON.CONTACTS'
8401       include 'COMMON.TORSION'
8402       include 'COMMON.VAR'
8403       include 'COMMON.GEO'
8404       include 'COMMON.FFIELD'
8405       double precision ggg1(3),ggg2(3)
8406 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8407 cd        eello6=0.0d0
8408 cd        return
8409 cd      endif
8410 cd      write (iout,*)
8411 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8412 cd     &   ' and',k,l
8413       eello6_1=0.0d0
8414       eello6_2=0.0d0
8415       eello6_3=0.0d0
8416       eello6_4=0.0d0
8417       eello6_5=0.0d0
8418       eello6_6=0.0d0
8419 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8420 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8421       do iii=1,2
8422         do kkk=1,5
8423           do lll=1,3
8424             derx(lll,kkk,iii)=0.0d0
8425           enddo
8426         enddo
8427       enddo
8428 cd      eij=facont_hb(jj,i)
8429 cd      ekl=facont_hb(kk,k)
8430 cd      ekont=eij*ekl
8431 cd      eij=1.0d0
8432 cd      ekl=1.0d0
8433 cd      ekont=1.0d0
8434       if (l.eq.j+1) then
8435         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8436         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8437         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8438         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8439         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8440         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8441       else
8442         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8443         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8444         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8445         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8446         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8447           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8448         else
8449           eello6_5=0.0d0
8450         endif
8451         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8452       endif
8453 C If turn contributions are considered, they will be handled separately.
8454       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8455 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8456 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8457 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8458 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8459 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8460 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8461 cd      goto 1112
8462       if (j.lt.nres-1) then
8463         j1=j+1
8464         j2=j-1
8465       else
8466         j1=j-1
8467         j2=j-2
8468       endif
8469       if (l.lt.nres-1) then
8470         l1=l+1
8471         l2=l-1
8472       else
8473         l1=l-1
8474         l2=l-2
8475       endif
8476       do ll=1,3
8477 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8478 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8479 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8480 cgrad        ghalf=0.5d0*ggg1(ll)
8481 cd        ghalf=0.0d0
8482         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8483         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8484         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8485         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8486         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8487         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8488         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8489         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8490 cgrad        ghalf=0.5d0*ggg2(ll)
8491 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8492 cd        ghalf=0.0d0
8493         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8494         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8495         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8496         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8497         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8498         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8499       enddo
8500 cd      goto 1112
8501 cgrad      do m=i+1,j-1
8502 cgrad        do ll=1,3
8503 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8504 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8505 cgrad        enddo
8506 cgrad      enddo
8507 cgrad      do m=k+1,l-1
8508 cgrad        do ll=1,3
8509 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8510 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8511 cgrad        enddo
8512 cgrad      enddo
8513 cgrad1112  continue
8514 cgrad      do m=i+2,j2
8515 cgrad        do ll=1,3
8516 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8517 cgrad        enddo
8518 cgrad      enddo
8519 cgrad      do m=k+2,l2
8520 cgrad        do ll=1,3
8521 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8522 cgrad        enddo
8523 cgrad      enddo
8524 cd      do iii=1,nres-3
8525 cd        write (2,*) iii,g_corr6_loc(iii)
8526 cd      enddo
8527       eello6=ekont*eel6
8528 cd      write (2,*) 'ekont',ekont
8529 cd      write (iout,*) 'eello6',ekont*eel6
8530       return
8531       end
8532 c--------------------------------------------------------------------------
8533       double precision function eello6_graph1(i,j,k,l,imat,swap)
8534       implicit real*8 (a-h,o-z)
8535       include 'DIMENSIONS'
8536       include 'COMMON.IOUNITS'
8537       include 'COMMON.CHAIN'
8538       include 'COMMON.DERIV'
8539       include 'COMMON.INTERACT'
8540       include 'COMMON.CONTACTS'
8541       include 'COMMON.TORSION'
8542       include 'COMMON.VAR'
8543       include 'COMMON.GEO'
8544       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8545       logical swap
8546       logical lprn
8547       common /kutas/ lprn
8548 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8549 C                                                                              C
8550 C      Parallel       Antiparallel                                             C
8551 C                                                                              C
8552 C          o             o                                                     C
8553 C         /l\           /j\                                                    C
8554 C        /   \         /   \                                                   C
8555 C       /| o |         | o |\                                                  C
8556 C     \ j|/k\|  /   \  |/k\|l /                                                C
8557 C      \ /   \ /     \ /   \ /                                                 C
8558 C       o     o       o     o                                                  C
8559 C       i             i                                                        C
8560 C                                                                              C
8561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8562       itk=itortyp(itype(k))
8563       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8564       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8565       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8566       call transpose2(EUgC(1,1,k),auxmat(1,1))
8567       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8568       vv1(1)=pizda1(1,1)-pizda1(2,2)
8569       vv1(2)=pizda1(1,2)+pizda1(2,1)
8570       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8571       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8572       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8573       s5=scalar2(vv(1),Dtobr2(1,i))
8574 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8575       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8576       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8577      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8578      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8579      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8580      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8581      & +scalar2(vv(1),Dtobr2der(1,i)))
8582       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8583       vv1(1)=pizda1(1,1)-pizda1(2,2)
8584       vv1(2)=pizda1(1,2)+pizda1(2,1)
8585       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8586       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8587       if (l.eq.j+1) then
8588         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8589      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8590      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8591      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8592      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8593       else
8594         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8595      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8596      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8597      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8598      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8599       endif
8600       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8601       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8602       vv1(1)=pizda1(1,1)-pizda1(2,2)
8603       vv1(2)=pizda1(1,2)+pizda1(2,1)
8604       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8605      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8606      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8607      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8608       do iii=1,2
8609         if (swap) then
8610           ind=3-iii
8611         else
8612           ind=iii
8613         endif
8614         do kkk=1,5
8615           do lll=1,3
8616             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8617             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8618             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8619             call transpose2(EUgC(1,1,k),auxmat(1,1))
8620             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8621      &        pizda1(1,1))
8622             vv1(1)=pizda1(1,1)-pizda1(2,2)
8623             vv1(2)=pizda1(1,2)+pizda1(2,1)
8624             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8625             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8626      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8627             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8628      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8629             s5=scalar2(vv(1),Dtobr2(1,i))
8630             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8631           enddo
8632         enddo
8633       enddo
8634       return
8635       end
8636 c----------------------------------------------------------------------------
8637       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8638       implicit real*8 (a-h,o-z)
8639       include 'DIMENSIONS'
8640       include 'COMMON.IOUNITS'
8641       include 'COMMON.CHAIN'
8642       include 'COMMON.DERIV'
8643       include 'COMMON.INTERACT'
8644       include 'COMMON.CONTACTS'
8645       include 'COMMON.TORSION'
8646       include 'COMMON.VAR'
8647       include 'COMMON.GEO'
8648       logical swap
8649       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8650      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8651       logical lprn
8652       common /kutas/ lprn
8653 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8654 C                                                                              C
8655 C      Parallel       Antiparallel                                             C
8656 C                                                                              C
8657 C          o             o                                                     C
8658 C     \   /l\           /j\   /                                                C
8659 C      \ /   \         /   \ /                                                 C
8660 C       o| o |         | o |o                                                  C
8661 C     \ j|/k\|      \  |/k\|l                                                  C
8662 C      \ /   \       \ /   \                                                   C
8663 C       o             o                                                        C
8664 C       i             i                                                        C
8665 C                                                                              C
8666 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8667 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8668 C AL 7/4/01 s1 would occur in the sixth-order moment,
8669 C           but not in a cluster cumulant
8670 #ifdef MOMENT
8671       s1=dip(1,jj,i)*dip(1,kk,k)
8672 #endif
8673       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8674       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8675       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8676       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8677       call transpose2(EUg(1,1,k),auxmat(1,1))
8678       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8679       vv(1)=pizda(1,1)-pizda(2,2)
8680       vv(2)=pizda(1,2)+pizda(2,1)
8681       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8682 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8683 #ifdef MOMENT
8684       eello6_graph2=-(s1+s2+s3+s4)
8685 #else
8686       eello6_graph2=-(s2+s3+s4)
8687 #endif
8688 c      eello6_graph2=-s3
8689 C Derivatives in gamma(i-1)
8690       if (i.gt.1) then
8691 #ifdef MOMENT
8692         s1=dipderg(1,jj,i)*dip(1,kk,k)
8693 #endif
8694         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8695         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8696         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8697         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8698 #ifdef MOMENT
8699         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8700 #else
8701         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8702 #endif
8703 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8704       endif
8705 C Derivatives in gamma(k-1)
8706 #ifdef MOMENT
8707       s1=dip(1,jj,i)*dipderg(1,kk,k)
8708 #endif
8709       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8710       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8711       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8712       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8713       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8714       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8715       vv(1)=pizda(1,1)-pizda(2,2)
8716       vv(2)=pizda(1,2)+pizda(2,1)
8717       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8718 #ifdef MOMENT
8719       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8720 #else
8721       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8722 #endif
8723 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8724 C Derivatives in gamma(j-1) or gamma(l-1)
8725       if (j.gt.1) then
8726 #ifdef MOMENT
8727         s1=dipderg(3,jj,i)*dip(1,kk,k)
8728 #endif
8729         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8730         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8731         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8732         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8733         vv(1)=pizda(1,1)-pizda(2,2)
8734         vv(2)=pizda(1,2)+pizda(2,1)
8735         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8736 #ifdef MOMENT
8737         if (swap) then
8738           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8739         else
8740           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8741         endif
8742 #endif
8743         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8744 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8745       endif
8746 C Derivatives in gamma(l-1) or gamma(j-1)
8747       if (l.gt.1) then
8748 #ifdef MOMENT
8749         s1=dip(1,jj,i)*dipderg(3,kk,k)
8750 #endif
8751         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8752         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8753         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8754         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8755         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8756         vv(1)=pizda(1,1)-pizda(2,2)
8757         vv(2)=pizda(1,2)+pizda(2,1)
8758         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8759 #ifdef MOMENT
8760         if (swap) then
8761           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8762         else
8763           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8764         endif
8765 #endif
8766         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8767 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8768       endif
8769 C Cartesian derivatives.
8770       if (lprn) then
8771         write (2,*) 'In eello6_graph2'
8772         do iii=1,2
8773           write (2,*) 'iii=',iii
8774           do kkk=1,5
8775             write (2,*) 'kkk=',kkk
8776             do jjj=1,2
8777               write (2,'(3(2f10.5),5x)')
8778      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8779             enddo
8780           enddo
8781         enddo
8782       endif
8783       do iii=1,2
8784         do kkk=1,5
8785           do lll=1,3
8786 #ifdef MOMENT
8787             if (iii.eq.1) then
8788               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8789             else
8790               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8791             endif
8792 #endif
8793             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8794      &        auxvec(1))
8795             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8796             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8797      &        auxvec(1))
8798             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8799             call transpose2(EUg(1,1,k),auxmat(1,1))
8800             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8801      &        pizda(1,1))
8802             vv(1)=pizda(1,1)-pizda(2,2)
8803             vv(2)=pizda(1,2)+pizda(2,1)
8804             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8805 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8806 #ifdef MOMENT
8807             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8808 #else
8809             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8810 #endif
8811             if (swap) then
8812               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8813             else
8814               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8815             endif
8816           enddo
8817         enddo
8818       enddo
8819       return
8820       end
8821 c----------------------------------------------------------------------------
8822       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8823       implicit real*8 (a-h,o-z)
8824       include 'DIMENSIONS'
8825       include 'COMMON.IOUNITS'
8826       include 'COMMON.CHAIN'
8827       include 'COMMON.DERIV'
8828       include 'COMMON.INTERACT'
8829       include 'COMMON.CONTACTS'
8830       include 'COMMON.TORSION'
8831       include 'COMMON.VAR'
8832       include 'COMMON.GEO'
8833       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8834       logical swap
8835 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8836 C                                                                              C
8837 C      Parallel       Antiparallel                                             C
8838 C                                                                              C
8839 C          o             o                                                     C
8840 C         /l\   /   \   /j\                                                    C
8841 C        /   \ /     \ /   \                                                   C
8842 C       /| o |o       o| o |\                                                  C
8843 C       j|/k\|  /      |/k\|l /                                                C
8844 C        /   \ /       /   \ /                                                 C
8845 C       /     o       /     o                                                  C
8846 C       i             i                                                        C
8847 C                                                                              C
8848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8849 C
8850 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8851 C           energy moment and not to the cluster cumulant.
8852       iti=itortyp(itype(i))
8853       if (j.lt.nres-1) then
8854         itj1=itortyp(itype(j+1))
8855       else
8856         itj1=ntortyp
8857       endif
8858       itk=itortyp(itype(k))
8859       itk1=itortyp(itype(k+1))
8860       if (l.lt.nres-1) then
8861         itl1=itortyp(itype(l+1))
8862       else
8863         itl1=ntortyp
8864       endif
8865 #ifdef MOMENT
8866       s1=dip(4,jj,i)*dip(4,kk,k)
8867 #endif
8868       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8869       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8870       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8871       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8872       call transpose2(EE(1,1,itk),auxmat(1,1))
8873       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8874       vv(1)=pizda(1,1)+pizda(2,2)
8875       vv(2)=pizda(2,1)-pizda(1,2)
8876       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8877 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8878 cd     & "sum",-(s2+s3+s4)
8879 #ifdef MOMENT
8880       eello6_graph3=-(s1+s2+s3+s4)
8881 #else
8882       eello6_graph3=-(s2+s3+s4)
8883 #endif
8884 c      eello6_graph3=-s4
8885 C Derivatives in gamma(k-1)
8886       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8887       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8888       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8889       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8890 C Derivatives in gamma(l-1)
8891       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8892       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8893       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8894       vv(1)=pizda(1,1)+pizda(2,2)
8895       vv(2)=pizda(2,1)-pizda(1,2)
8896       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8897       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8898 C Cartesian derivatives.
8899       do iii=1,2
8900         do kkk=1,5
8901           do lll=1,3
8902 #ifdef MOMENT
8903             if (iii.eq.1) then
8904               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8905             else
8906               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8907             endif
8908 #endif
8909             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8910      &        auxvec(1))
8911             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8912             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8913      &        auxvec(1))
8914             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8915             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8916      &        pizda(1,1))
8917             vv(1)=pizda(1,1)+pizda(2,2)
8918             vv(2)=pizda(2,1)-pizda(1,2)
8919             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8920 #ifdef MOMENT
8921             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8922 #else
8923             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8924 #endif
8925             if (swap) then
8926               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8927             else
8928               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8929             endif
8930 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8931           enddo
8932         enddo
8933       enddo
8934       return
8935       end
8936 c----------------------------------------------------------------------------
8937       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8938       implicit real*8 (a-h,o-z)
8939       include 'DIMENSIONS'
8940       include 'COMMON.IOUNITS'
8941       include 'COMMON.CHAIN'
8942       include 'COMMON.DERIV'
8943       include 'COMMON.INTERACT'
8944       include 'COMMON.CONTACTS'
8945       include 'COMMON.TORSION'
8946       include 'COMMON.VAR'
8947       include 'COMMON.GEO'
8948       include 'COMMON.FFIELD'
8949       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8950      & auxvec1(2),auxmat1(2,2)
8951       logical swap
8952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8953 C                                                                              C
8954 C      Parallel       Antiparallel                                             C
8955 C                                                                              C
8956 C          o             o                                                     C
8957 C         /l\   /   \   /j\                                                    C
8958 C        /   \ /     \ /   \                                                   C
8959 C       /| o |o       o| o |\                                                  C
8960 C     \ j|/k\|      \  |/k\|l                                                  C
8961 C      \ /   \       \ /   \                                                   C
8962 C       o     \       o     \                                                  C
8963 C       i             i                                                        C
8964 C                                                                              C
8965 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8966 C
8967 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8968 C           energy moment and not to the cluster cumulant.
8969 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8970       iti=itortyp(itype(i))
8971       itj=itortyp(itype(j))
8972       if (j.lt.nres-1) then
8973         itj1=itortyp(itype(j+1))
8974       else
8975         itj1=ntortyp
8976       endif
8977       itk=itortyp(itype(k))
8978       if (k.lt.nres-1) then
8979         itk1=itortyp(itype(k+1))
8980       else
8981         itk1=ntortyp
8982       endif
8983       itl=itortyp(itype(l))
8984       if (l.lt.nres-1) then
8985         itl1=itortyp(itype(l+1))
8986       else
8987         itl1=ntortyp
8988       endif
8989 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8990 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8991 cd     & ' itl',itl,' itl1',itl1
8992 #ifdef MOMENT
8993       if (imat.eq.1) then
8994         s1=dip(3,jj,i)*dip(3,kk,k)
8995       else
8996         s1=dip(2,jj,j)*dip(2,kk,l)
8997       endif
8998 #endif
8999       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9000       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9001       if (j.eq.l+1) then
9002         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9003         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9004       else
9005         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9006         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9007       endif
9008       call transpose2(EUg(1,1,k),auxmat(1,1))
9009       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9010       vv(1)=pizda(1,1)-pizda(2,2)
9011       vv(2)=pizda(2,1)+pizda(1,2)
9012       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9013 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9014 #ifdef MOMENT
9015       eello6_graph4=-(s1+s2+s3+s4)
9016 #else
9017       eello6_graph4=-(s2+s3+s4)
9018 #endif
9019 C Derivatives in gamma(i-1)
9020       if (i.gt.1) then
9021 #ifdef MOMENT
9022         if (imat.eq.1) then
9023           s1=dipderg(2,jj,i)*dip(3,kk,k)
9024         else
9025           s1=dipderg(4,jj,j)*dip(2,kk,l)
9026         endif
9027 #endif
9028         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9029         if (j.eq.l+1) then
9030           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9031           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9032         else
9033           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9034           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9035         endif
9036         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9037         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9038 cd          write (2,*) 'turn6 derivatives'
9039 #ifdef MOMENT
9040           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9041 #else
9042           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9043 #endif
9044         else
9045 #ifdef MOMENT
9046           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9047 #else
9048           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9049 #endif
9050         endif
9051       endif
9052 C Derivatives in gamma(k-1)
9053 #ifdef MOMENT
9054       if (imat.eq.1) then
9055         s1=dip(3,jj,i)*dipderg(2,kk,k)
9056       else
9057         s1=dip(2,jj,j)*dipderg(4,kk,l)
9058       endif
9059 #endif
9060       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9061       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9062       if (j.eq.l+1) then
9063         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9064         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9065       else
9066         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9067         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9068       endif
9069       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9070       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9071       vv(1)=pizda(1,1)-pizda(2,2)
9072       vv(2)=pizda(2,1)+pizda(1,2)
9073       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9074       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9075 #ifdef MOMENT
9076         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9077 #else
9078         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9079 #endif
9080       else
9081 #ifdef MOMENT
9082         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9083 #else
9084         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9085 #endif
9086       endif
9087 C Derivatives in gamma(j-1) or gamma(l-1)
9088       if (l.eq.j+1 .and. l.gt.1) then
9089         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9090         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9091         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9092         vv(1)=pizda(1,1)-pizda(2,2)
9093         vv(2)=pizda(2,1)+pizda(1,2)
9094         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9095         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9096       else if (j.gt.1) then
9097         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9098         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9099         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9100         vv(1)=pizda(1,1)-pizda(2,2)
9101         vv(2)=pizda(2,1)+pizda(1,2)
9102         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9103         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9104           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9105         else
9106           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9107         endif
9108       endif
9109 C Cartesian derivatives.
9110       do iii=1,2
9111         do kkk=1,5
9112           do lll=1,3
9113 #ifdef MOMENT
9114             if (iii.eq.1) then
9115               if (imat.eq.1) then
9116                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9117               else
9118                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9119               endif
9120             else
9121               if (imat.eq.1) then
9122                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9123               else
9124                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9125               endif
9126             endif
9127 #endif
9128             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9129      &        auxvec(1))
9130             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9131             if (j.eq.l+1) then
9132               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9133      &          b1(1,itj1),auxvec(1))
9134               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9135             else
9136               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9137      &          b1(1,itl1),auxvec(1))
9138               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9139             endif
9140             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9141      &        pizda(1,1))
9142             vv(1)=pizda(1,1)-pizda(2,2)
9143             vv(2)=pizda(2,1)+pizda(1,2)
9144             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9145             if (swap) then
9146               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9147 #ifdef MOMENT
9148                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9149      &             -(s1+s2+s4)
9150 #else
9151                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9152      &             -(s2+s4)
9153 #endif
9154                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9155               else
9156 #ifdef MOMENT
9157                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9158 #else
9159                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9160 #endif
9161                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9162               endif
9163             else
9164 #ifdef MOMENT
9165               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9166 #else
9167               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9168 #endif
9169               if (l.eq.j+1) then
9170                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9171               else
9172                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9173               endif
9174             endif
9175           enddo
9176         enddo
9177       enddo
9178       return
9179       end
9180 c----------------------------------------------------------------------------
9181       double precision function eello_turn6(i,jj,kk)
9182       implicit real*8 (a-h,o-z)
9183       include 'DIMENSIONS'
9184       include 'COMMON.IOUNITS'
9185       include 'COMMON.CHAIN'
9186       include 'COMMON.DERIV'
9187       include 'COMMON.INTERACT'
9188       include 'COMMON.CONTACTS'
9189       include 'COMMON.TORSION'
9190       include 'COMMON.VAR'
9191       include 'COMMON.GEO'
9192       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9193      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9194      &  ggg1(3),ggg2(3)
9195       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9196      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9197 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9198 C           the respective energy moment and not to the cluster cumulant.
9199       s1=0.0d0
9200       s8=0.0d0
9201       s13=0.0d0
9202 c
9203       eello_turn6=0.0d0
9204       j=i+4
9205       k=i+1
9206       l=i+3
9207       iti=itortyp(itype(i))
9208       itk=itortyp(itype(k))
9209       itk1=itortyp(itype(k+1))
9210       itl=itortyp(itype(l))
9211       itj=itortyp(itype(j))
9212 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9213 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9214 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9215 cd        eello6=0.0d0
9216 cd        return
9217 cd      endif
9218 cd      write (iout,*)
9219 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9220 cd     &   ' and',k,l
9221 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9222       do iii=1,2
9223         do kkk=1,5
9224           do lll=1,3
9225             derx_turn(lll,kkk,iii)=0.0d0
9226           enddo
9227         enddo
9228       enddo
9229 cd      eij=1.0d0
9230 cd      ekl=1.0d0
9231 cd      ekont=1.0d0
9232       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9233 cd      eello6_5=0.0d0
9234 cd      write (2,*) 'eello6_5',eello6_5
9235 #ifdef MOMENT
9236       call transpose2(AEA(1,1,1),auxmat(1,1))
9237       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9238       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9239       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9240 #endif
9241       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9242       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9243       s2 = scalar2(b1(1,itk),vtemp1(1))
9244 #ifdef MOMENT
9245       call transpose2(AEA(1,1,2),atemp(1,1))
9246       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9247       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9248       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9249 #endif
9250       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9251       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9252       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9253 #ifdef MOMENT
9254       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9255       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9256       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9257       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9258       ss13 = scalar2(b1(1,itk),vtemp4(1))
9259       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9260 #endif
9261 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9262 c      s1=0.0d0
9263 c      s2=0.0d0
9264 c      s8=0.0d0
9265 c      s12=0.0d0
9266 c      s13=0.0d0
9267       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9268 C Derivatives in gamma(i+2)
9269       s1d =0.0d0
9270       s8d =0.0d0
9271 #ifdef MOMENT
9272       call transpose2(AEA(1,1,1),auxmatd(1,1))
9273       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9274       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9275       call transpose2(AEAderg(1,1,2),atempd(1,1))
9276       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9277       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9278 #endif
9279       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9280       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9281       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9282 c      s1d=0.0d0
9283 c      s2d=0.0d0
9284 c      s8d=0.0d0
9285 c      s12d=0.0d0
9286 c      s13d=0.0d0
9287       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9288 C Derivatives in gamma(i+3)
9289 #ifdef MOMENT
9290       call transpose2(AEA(1,1,1),auxmatd(1,1))
9291       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9292       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9293       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9294 #endif
9295       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9296       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9297       s2d = scalar2(b1(1,itk),vtemp1d(1))
9298 #ifdef MOMENT
9299       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9300       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9301 #endif
9302       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9303 #ifdef MOMENT
9304       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9305       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9306       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9307 #endif
9308 c      s1d=0.0d0
9309 c      s2d=0.0d0
9310 c      s8d=0.0d0
9311 c      s12d=0.0d0
9312 c      s13d=0.0d0
9313 #ifdef MOMENT
9314       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9315      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9316 #else
9317       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9318      &               -0.5d0*ekont*(s2d+s12d)
9319 #endif
9320 C Derivatives in gamma(i+4)
9321       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9322       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9323       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9324 #ifdef MOMENT
9325       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9326       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9327       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9328 #endif
9329 c      s1d=0.0d0
9330 c      s2d=0.0d0
9331 c      s8d=0.0d0
9332 C      s12d=0.0d0
9333 c      s13d=0.0d0
9334 #ifdef MOMENT
9335       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9336 #else
9337       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9338 #endif
9339 C Derivatives in gamma(i+5)
9340 #ifdef MOMENT
9341       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9342       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9343       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9344 #endif
9345       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9346       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9347       s2d = scalar2(b1(1,itk),vtemp1d(1))
9348 #ifdef MOMENT
9349       call transpose2(AEA(1,1,2),atempd(1,1))
9350       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9351       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9352 #endif
9353       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9354       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9355 #ifdef MOMENT
9356       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9357       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9358       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9359 #endif
9360 c      s1d=0.0d0
9361 c      s2d=0.0d0
9362 c      s8d=0.0d0
9363 c      s12d=0.0d0
9364 c      s13d=0.0d0
9365 #ifdef MOMENT
9366       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9367      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9368 #else
9369       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9370      &               -0.5d0*ekont*(s2d+s12d)
9371 #endif
9372 C Cartesian derivatives
9373       do iii=1,2
9374         do kkk=1,5
9375           do lll=1,3
9376 #ifdef MOMENT
9377             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9378             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9379             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9380 #endif
9381             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9382             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9383      &          vtemp1d(1))
9384             s2d = scalar2(b1(1,itk),vtemp1d(1))
9385 #ifdef MOMENT
9386             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9387             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9388             s8d = -(atempd(1,1)+atempd(2,2))*
9389      &           scalar2(cc(1,1,itl),vtemp2(1))
9390 #endif
9391             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9392      &           auxmatd(1,1))
9393             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9394             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9395 c      s1d=0.0d0
9396 c      s2d=0.0d0
9397 c      s8d=0.0d0
9398 c      s12d=0.0d0
9399 c      s13d=0.0d0
9400 #ifdef MOMENT
9401             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9402      &        - 0.5d0*(s1d+s2d)
9403 #else
9404             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9405      &        - 0.5d0*s2d
9406 #endif
9407 #ifdef MOMENT
9408             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9409      &        - 0.5d0*(s8d+s12d)
9410 #else
9411             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9412      &        - 0.5d0*s12d
9413 #endif
9414           enddo
9415         enddo
9416       enddo
9417 #ifdef MOMENT
9418       do kkk=1,5
9419         do lll=1,3
9420           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9421      &      achuj_tempd(1,1))
9422           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9423           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9424           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9425           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9426           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9427      &      vtemp4d(1))
9428           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9429           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9430           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9431         enddo
9432       enddo
9433 #endif
9434 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9435 cd     &  16*eel_turn6_num
9436 cd      goto 1112
9437       if (j.lt.nres-1) then
9438         j1=j+1
9439         j2=j-1
9440       else
9441         j1=j-1
9442         j2=j-2
9443       endif
9444       if (l.lt.nres-1) then
9445         l1=l+1
9446         l2=l-1
9447       else
9448         l1=l-1
9449         l2=l-2
9450       endif
9451       do ll=1,3
9452 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9453 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9454 cgrad        ghalf=0.5d0*ggg1(ll)
9455 cd        ghalf=0.0d0
9456         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9457         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9458         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9459      &    +ekont*derx_turn(ll,2,1)
9460         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9461         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9462      &    +ekont*derx_turn(ll,4,1)
9463         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9464         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9465         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9466 cgrad        ghalf=0.5d0*ggg2(ll)
9467 cd        ghalf=0.0d0
9468         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9469      &    +ekont*derx_turn(ll,2,2)
9470         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9471         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9472      &    +ekont*derx_turn(ll,4,2)
9473         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9474         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9475         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9476       enddo
9477 cd      goto 1112
9478 cgrad      do m=i+1,j-1
9479 cgrad        do ll=1,3
9480 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9481 cgrad        enddo
9482 cgrad      enddo
9483 cgrad      do m=k+1,l-1
9484 cgrad        do ll=1,3
9485 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9486 cgrad        enddo
9487 cgrad      enddo
9488 cgrad1112  continue
9489 cgrad      do m=i+2,j2
9490 cgrad        do ll=1,3
9491 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9492 cgrad        enddo
9493 cgrad      enddo
9494 cgrad      do m=k+2,l2
9495 cgrad        do ll=1,3
9496 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9497 cgrad        enddo
9498 cgrad      enddo
9499 cd      do iii=1,nres-3
9500 cd        write (2,*) iii,g_corr6_loc(iii)
9501 cd      enddo
9502       eello_turn6=ekont*eel_turn6
9503 cd      write (2,*) 'ekont',ekont
9504 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9505       return
9506       end
9507
9508 C-----------------------------------------------------------------------------
9509       double precision function scalar(u,v)
9510 !DIR$ INLINEALWAYS scalar
9511 #ifndef OSF
9512 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9513 #endif
9514       implicit none
9515       double precision u(3),v(3)
9516 cd      double precision sc
9517 cd      integer i
9518 cd      sc=0.0d0
9519 cd      do i=1,3
9520 cd        sc=sc+u(i)*v(i)
9521 cd      enddo
9522 cd      scalar=sc
9523
9524       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9525       return
9526       end
9527 crc-------------------------------------------------
9528       SUBROUTINE MATVEC2(A1,V1,V2)
9529 !DIR$ INLINEALWAYS MATVEC2
9530 #ifndef OSF
9531 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9532 #endif
9533       implicit real*8 (a-h,o-z)
9534       include 'DIMENSIONS'
9535       DIMENSION A1(2,2),V1(2),V2(2)
9536 c      DO 1 I=1,2
9537 c        VI=0.0
9538 c        DO 3 K=1,2
9539 c    3     VI=VI+A1(I,K)*V1(K)
9540 c        Vaux(I)=VI
9541 c    1 CONTINUE
9542
9543       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9544       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9545
9546       v2(1)=vaux1
9547       v2(2)=vaux2
9548       END
9549 C---------------------------------------
9550       SUBROUTINE MATMAT2(A1,A2,A3)
9551 #ifndef OSF
9552 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9553 #endif
9554       implicit real*8 (a-h,o-z)
9555       include 'DIMENSIONS'
9556       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9557 c      DIMENSION AI3(2,2)
9558 c        DO  J=1,2
9559 c          A3IJ=0.0
9560 c          DO K=1,2
9561 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9562 c          enddo
9563 c          A3(I,J)=A3IJ
9564 c       enddo
9565 c      enddo
9566
9567       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9568       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9569       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9570       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9571
9572       A3(1,1)=AI3_11
9573       A3(2,1)=AI3_21
9574       A3(1,2)=AI3_12
9575       A3(2,2)=AI3_22
9576       END
9577
9578 c-------------------------------------------------------------------------
9579       double precision function scalar2(u,v)
9580 !DIR$ INLINEALWAYS scalar2
9581       implicit none
9582       double precision u(2),v(2)
9583       double precision sc
9584       integer i
9585       scalar2=u(1)*v(1)+u(2)*v(2)
9586       return
9587       end
9588
9589 C-----------------------------------------------------------------------------
9590
9591       subroutine transpose2(a,at)
9592 !DIR$ INLINEALWAYS transpose2
9593 #ifndef OSF
9594 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9595 #endif
9596       implicit none
9597       double precision a(2,2),at(2,2)
9598       at(1,1)=a(1,1)
9599       at(1,2)=a(2,1)
9600       at(2,1)=a(1,2)
9601       at(2,2)=a(2,2)
9602       return
9603       end
9604 c--------------------------------------------------------------------------
9605       subroutine transpose(n,a,at)
9606       implicit none
9607       integer n,i,j
9608       double precision a(n,n),at(n,n)
9609       do i=1,n
9610         do j=1,n
9611           at(j,i)=a(i,j)
9612         enddo
9613       enddo
9614       return
9615       end
9616 C---------------------------------------------------------------------------
9617       subroutine prodmat3(a1,a2,kk,transp,prod)
9618 !DIR$ INLINEALWAYS prodmat3
9619 #ifndef OSF
9620 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9621 #endif
9622       implicit none
9623       integer i,j
9624       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9625       logical transp
9626 crc      double precision auxmat(2,2),prod_(2,2)
9627
9628       if (transp) then
9629 crc        call transpose2(kk(1,1),auxmat(1,1))
9630 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9631 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9632
9633            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9634      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9635            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9636      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9637            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9638      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9639            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9640      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9641
9642       else
9643 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9644 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9645
9646            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9647      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9648            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9649      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9650            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9651      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9652            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9653      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9654
9655       endif
9656 c      call transpose2(a2(1,1),a2t(1,1))
9657
9658 crc      print *,transp
9659 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9660 crc      print *,((prod(i,j),i=1,2),j=1,2)
9661
9662       return
9663       end
9664