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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+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 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255 c      write(iout,*) 'nphi=',nphi,nres
2256 #ifdef PARMAT
2257       do i=ivec_start+2,ivec_end+2
2258 #else
2259       do i=3,nres+1
2260 #endif
2261 #ifdef NEWCORR
2262         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2263           iti = itortyp(itype(i-2))
2264         else
2265           iti=ntortyp+1
2266         endif
2267 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2268         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2269           iti1 = itortyp(itype(i-1))
2270         else
2271           iti1=ntortyp+1
2272         endif
2273 c        write(iout,*),i
2274         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2275      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2276      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2278      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2279      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2280 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2283      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2284      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2285 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2288      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2289      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2290 c        if (ggb1(1,i).eq.0.0d0) then
2291 c        write(iout,*) 'i=',i,ggb1(1,i),
2292 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2293 c     &bnew1(2,1,iti)*cos(theta(i)),
2294 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2295 c        endif
2296         b1(2,i-2)=bnew1(1,2,iti)
2297         gtb1(2,i-2)=0.0
2298         b2(2,i-2)=bnew2(1,2,iti)
2299         gtb2(2,i-2)=0.0
2300 c        EE(1,1,iti)=0.0d0
2301 c        EE(2,2,iti)=0.0d0
2302 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2303 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2304 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2305 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2306        b1tilde(1,i-2)=b1(1,i-2)
2307        b1tilde(2,i-2)=-b1(2,i-2)
2308        b2tilde(1,i-2)=b2(1,i-2)
2309        b2tilde(2,i-2)=-b2(2,i-2)
2310 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2311 c       write(iout,*)  'b1=',b1(1,i-2)
2312 c       write (iout,*) 'theta=', theta(i-1)
2313        enddo
2314 #ifdef PARMAT
2315       do i=ivec_start+2,ivec_end+2
2316 #else
2317       do i=3,nres+1
2318 #endif
2319 #endif
2320         if (i .lt. nres+1) then
2321           sin1=dsin(phi(i))
2322           cos1=dcos(phi(i))
2323           sintab(i-2)=sin1
2324           costab(i-2)=cos1
2325           obrot(1,i-2)=cos1
2326           obrot(2,i-2)=sin1
2327           sin2=dsin(2*phi(i))
2328           cos2=dcos(2*phi(i))
2329           sintab2(i-2)=sin2
2330           costab2(i-2)=cos2
2331           obrot2(1,i-2)=cos2
2332           obrot2(2,i-2)=sin2
2333           Ug(1,1,i-2)=-cos1
2334           Ug(1,2,i-2)=-sin1
2335           Ug(2,1,i-2)=-sin1
2336           Ug(2,2,i-2)= cos1
2337           Ug2(1,1,i-2)=-cos2
2338           Ug2(1,2,i-2)=-sin2
2339           Ug2(2,1,i-2)=-sin2
2340           Ug2(2,2,i-2)= cos2
2341         else
2342           costab(i-2)=1.0d0
2343           sintab(i-2)=0.0d0
2344           obrot(1,i-2)=1.0d0
2345           obrot(2,i-2)=0.0d0
2346           obrot2(1,i-2)=0.0d0
2347           obrot2(2,i-2)=0.0d0
2348           Ug(1,1,i-2)=1.0d0
2349           Ug(1,2,i-2)=0.0d0
2350           Ug(2,1,i-2)=0.0d0
2351           Ug(2,2,i-2)=1.0d0
2352           Ug2(1,1,i-2)=0.0d0
2353           Ug2(1,2,i-2)=0.0d0
2354           Ug2(2,1,i-2)=0.0d0
2355           Ug2(2,2,i-2)=0.0d0
2356         endif
2357         if (i .gt. 3 .and. i .lt. nres+1) then
2358           obrot_der(1,i-2)=-sin1
2359           obrot_der(2,i-2)= cos1
2360           Ugder(1,1,i-2)= sin1
2361           Ugder(1,2,i-2)=-cos1
2362           Ugder(2,1,i-2)=-cos1
2363           Ugder(2,2,i-2)=-sin1
2364           dwacos2=cos2+cos2
2365           dwasin2=sin2+sin2
2366           obrot2_der(1,i-2)=-dwasin2
2367           obrot2_der(2,i-2)= dwacos2
2368           Ug2der(1,1,i-2)= dwasin2
2369           Ug2der(1,2,i-2)=-dwacos2
2370           Ug2der(2,1,i-2)=-dwacos2
2371           Ug2der(2,2,i-2)=-dwasin2
2372         else
2373           obrot_der(1,i-2)=0.0d0
2374           obrot_der(2,i-2)=0.0d0
2375           Ugder(1,1,i-2)=0.0d0
2376           Ugder(1,2,i-2)=0.0d0
2377           Ugder(2,1,i-2)=0.0d0
2378           Ugder(2,2,i-2)=0.0d0
2379           obrot2_der(1,i-2)=0.0d0
2380           obrot2_der(2,i-2)=0.0d0
2381           Ug2der(1,1,i-2)=0.0d0
2382           Ug2der(1,2,i-2)=0.0d0
2383           Ug2der(2,1,i-2)=0.0d0
2384           Ug2der(2,2,i-2)=0.0d0
2385         endif
2386 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2387 #ifndef NEWCORR
2388         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2389           iti = itortyp(itype(i-2))
2390         else
2391           iti=ntortyp+1
2392         endif
2393 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2394         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2395           iti1 = itortyp(itype(i-1))
2396         else
2397           iti1=ntortyp+1
2398         endif
2399 #endif
2400 cd        write (iout,*) '*******i',i,' iti1',iti
2401 cd        write (iout,*) 'b1',b1(:,iti)
2402 cd        write (iout,*) 'b2',b2(:,iti)
2403 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2404 c        if (i .gt. iatel_s+2) then
2405         if (i .gt. nnt+2) then
2406           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2407 #ifdef NEWCORR
2408           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2409 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2410 #endif
2411           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2412           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2413      &    then
2414           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2415           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2416           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2417           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2418           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2419           endif
2420         else
2421           do k=1,2
2422             Ub2(k,i-2)=0.0d0
2423             Ctobr(k,i-2)=0.0d0
2424             Dtobr2(k,i-2)=0.0d0
2425             do l=1,2
2426               EUg(l,k,i-2)=0.0d0
2427               CUg(l,k,i-2)=0.0d0
2428               DUg(l,k,i-2)=0.0d0
2429               DtUg2(l,k,i-2)=0.0d0
2430             enddo
2431           enddo
2432         endif
2433         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2434         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2435         do k=1,2
2436           muder(k,i-2)=Ub2der(k,i-2)
2437         enddo
2438 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2439         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2440           if (itype(i-1).le.ntyp) then
2441             iti1 = itortyp(itype(i-1))
2442           else
2443             iti1=ntortyp+1
2444           endif
2445         else
2446           iti1=ntortyp+1
2447         endif
2448         do k=1,2
2449           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2450         enddo
2451 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2452 cd        write (iout,*) 'mu1',mu1(:,i-2)
2453 cd        write (iout,*) 'mu2',mu2(:,i-2)
2454         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2455      &  then
2456         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2457         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2458         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2459         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2460         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2461 C Vectors and matrices dependent on a single virtual-bond dihedral.
2462         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2463         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2464         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2465         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2466         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2467         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2468         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2469         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2470         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2471         endif
2472       enddo
2473 C Matrices dependent on two consecutive virtual-bond dihedrals.
2474 C The order of matrices is from left to right.
2475       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2476      &then
2477 c      do i=max0(ivec_start,2),ivec_end
2478       do i=2,nres-1
2479         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2480         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2481         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2482         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2483         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2484         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2485         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2486         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2487       enddo
2488       endif
2489 #if defined(MPI) && defined(PARMAT)
2490 #ifdef DEBUG
2491 c      if (fg_rank.eq.0) then
2492         write (iout,*) "Arrays UG and UGDER before GATHER"
2493         do i=1,nres-1
2494           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2495      &     ((ug(l,k,i),l=1,2),k=1,2),
2496      &     ((ugder(l,k,i),l=1,2),k=1,2)
2497         enddo
2498         write (iout,*) "Arrays UG2 and UG2DER"
2499         do i=1,nres-1
2500           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2501      &     ((ug2(l,k,i),l=1,2),k=1,2),
2502      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2503         enddo
2504         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2505         do i=1,nres-1
2506           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2507      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2508      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2509         enddo
2510         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2511         do i=1,nres-1
2512           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2513      &     costab(i),sintab(i),costab2(i),sintab2(i)
2514         enddo
2515         write (iout,*) "Array MUDER"
2516         do i=1,nres-1
2517           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2518         enddo
2519 c      endif
2520 #endif
2521       if (nfgtasks.gt.1) then
2522         time00=MPI_Wtime()
2523 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2524 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2525 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2526 #ifdef MATGATHER
2527         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2534      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2535      &   FG_COMM1,IERR)
2536         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2543      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2544      &   FG_COMM1,IERR)
2545         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2546      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2547      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2548         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2549      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2550      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2551         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2552      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2553      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2554         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2555      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2556      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2557         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2558      &  then
2559         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2560      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2563      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2564      &   FG_COMM1,IERR)
2565         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2566      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2567      &   FG_COMM1,IERR)
2568        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2569      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2572      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2573      &   FG_COMM1,IERR)
2574         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2575      &   ivec_count(fg_rank1),
2576      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2577      &   FG_COMM1,IERR)
2578         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2579      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2582      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2583      &   FG_COMM1,IERR)
2584         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2589      &   FG_COMM1,IERR)
2590         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2591      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2592      &   FG_COMM1,IERR)
2593         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2594      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2597      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2598      &   FG_COMM1,IERR)
2599         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2600      &   ivec_count(fg_rank1),
2601      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2602      &   FG_COMM1,IERR)
2603         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2604      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2605      &   FG_COMM1,IERR)
2606        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2611      &   FG_COMM1,IERR)
2612        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2614      &   FG_COMM1,IERR)
2615         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2616      &   ivec_count(fg_rank1),
2617      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2618      &   FG_COMM1,IERR)
2619         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2620      &   ivec_count(fg_rank1),
2621      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2622      &   FG_COMM1,IERR)
2623         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2624      &   ivec_count(fg_rank1),
2625      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2626      &   MPI_MAT2,FG_COMM1,IERR)
2627         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2628      &   ivec_count(fg_rank1),
2629      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2630      &   MPI_MAT2,FG_COMM1,IERR)
2631         endif
2632 #else
2633 c Passes matrix info through the ring
2634       isend=fg_rank1
2635       irecv=fg_rank1-1
2636       if (irecv.lt.0) irecv=nfgtasks1-1
2637       iprev=irecv
2638       inext=fg_rank1+1
2639       if (inext.ge.nfgtasks1) inext=0
2640       do i=1,nfgtasks1-1
2641 c        write (iout,*) "isend",isend," irecv",irecv
2642 c        call flush(iout)
2643         lensend=lentyp(isend)
2644         lenrecv=lentyp(irecv)
2645 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2646 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2647 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2648 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2649 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2650 c        write (iout,*) "Gather ROTAT1"
2651 c        call flush(iout)
2652 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2653 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2654 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2655 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2656 c        write (iout,*) "Gather ROTAT2"
2657 c        call flush(iout)
2658         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2659      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2660      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2661      &   iprev,4400+irecv,FG_COMM,status,IERR)
2662 c        write (iout,*) "Gather ROTAT_OLD"
2663 c        call flush(iout)
2664         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2665      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2666      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2667      &   iprev,5500+irecv,FG_COMM,status,IERR)
2668 c        write (iout,*) "Gather PRECOMP11"
2669 c        call flush(iout)
2670         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2671      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2672      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2673      &   iprev,6600+irecv,FG_COMM,status,IERR)
2674 c        write (iout,*) "Gather PRECOMP12"
2675 c        call flush(iout)
2676         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2677      &  then
2678         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2679      &   MPI_ROTAT2(lensend),inext,7700+isend,
2680      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2681      &   iprev,7700+irecv,FG_COMM,status,IERR)
2682 c        write (iout,*) "Gather PRECOMP21"
2683 c        call flush(iout)
2684         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2685      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2686      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2687      &   iprev,8800+irecv,FG_COMM,status,IERR)
2688 c        write (iout,*) "Gather PRECOMP22"
2689 c        call flush(iout)
2690         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2691      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2692      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2693      &   MPI_PRECOMP23(lenrecv),
2694      &   iprev,9900+irecv,FG_COMM,status,IERR)
2695 c        write (iout,*) "Gather PRECOMP23"
2696 c        call flush(iout)
2697         endif
2698         isend=irecv
2699         irecv=irecv-1
2700         if (irecv.lt.0) irecv=nfgtasks1-1
2701       enddo
2702 #endif
2703         time_gather=time_gather+MPI_Wtime()-time00
2704       endif
2705 #ifdef DEBUG
2706 c      if (fg_rank.eq.0) then
2707         write (iout,*) "Arrays UG and UGDER"
2708         do i=1,nres-1
2709           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2710      &     ((ug(l,k,i),l=1,2),k=1,2),
2711      &     ((ugder(l,k,i),l=1,2),k=1,2)
2712         enddo
2713         write (iout,*) "Arrays UG2 and UG2DER"
2714         do i=1,nres-1
2715           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2716      &     ((ug2(l,k,i),l=1,2),k=1,2),
2717      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2718         enddo
2719         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2720         do i=1,nres-1
2721           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2722      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2723      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2724         enddo
2725         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2726         do i=1,nres-1
2727           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2728      &     costab(i),sintab(i),costab2(i),sintab2(i)
2729         enddo
2730         write (iout,*) "Array MUDER"
2731         do i=1,nres-1
2732           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2733         enddo
2734 c      endif
2735 #endif
2736 #endif
2737 cd      do i=1,nres
2738 cd        iti = itortyp(itype(i))
2739 cd        write (iout,*) i
2740 cd        do j=1,2
2741 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2742 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2743 cd        enddo
2744 cd      enddo
2745       return
2746       end
2747 C--------------------------------------------------------------------------
2748       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2749 C
2750 C This subroutine calculates the average interaction energy and its gradient
2751 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2752 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2753 C The potential depends both on the distance of peptide-group centers and on
2754 C the orientation of the CA-CA virtual bonds.
2755 C
2756       implicit real*8 (a-h,o-z)
2757 #ifdef MPI
2758       include 'mpif.h'
2759 #endif
2760       include 'DIMENSIONS'
2761       include 'COMMON.CONTROL'
2762       include 'COMMON.SETUP'
2763       include 'COMMON.IOUNITS'
2764       include 'COMMON.GEO'
2765       include 'COMMON.VAR'
2766       include 'COMMON.LOCAL'
2767       include 'COMMON.CHAIN'
2768       include 'COMMON.DERIV'
2769       include 'COMMON.INTERACT'
2770       include 'COMMON.CONTACTS'
2771       include 'COMMON.TORSION'
2772       include 'COMMON.VECTORS'
2773       include 'COMMON.FFIELD'
2774       include 'COMMON.TIME1'
2775       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2776      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2777       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2778      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2779       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2780      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2781      &    num_conti,j1,j2
2782 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2783 #ifdef MOMENT
2784       double precision scal_el /1.0d0/
2785 #else
2786       double precision scal_el /0.5d0/
2787 #endif
2788 C 12/13/98
2789 C 13-go grudnia roku pamietnego...
2790       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2791      &                   0.0d0,1.0d0,0.0d0,
2792      &                   0.0d0,0.0d0,1.0d0/
2793 cd      write(iout,*) 'In EELEC'
2794 cd      do i=1,nloctyp
2795 cd        write(iout,*) 'Type',i
2796 cd        write(iout,*) 'B1',B1(:,i)
2797 cd        write(iout,*) 'B2',B2(:,i)
2798 cd        write(iout,*) 'CC',CC(:,:,i)
2799 cd        write(iout,*) 'DD',DD(:,:,i)
2800 cd        write(iout,*) 'EE',EE(:,:,i)
2801 cd      enddo
2802 cd      call check_vecgrad
2803 cd      stop
2804       if (icheckgrad.eq.1) then
2805         do i=1,nres-1
2806           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2807           do k=1,3
2808             dc_norm(k,i)=dc(k,i)*fac
2809           enddo
2810 c          write (iout,*) 'i',i,' fac',fac
2811         enddo
2812       endif
2813       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2814      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2815      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2816 c        call vec_and_deriv
2817 #ifdef TIMING
2818         time01=MPI_Wtime()
2819 #endif
2820         call set_matrices
2821 #ifdef TIMING
2822         time_mat=time_mat+MPI_Wtime()-time01
2823 #endif
2824       endif
2825 cd      do i=1,nres-1
2826 cd        write (iout,*) 'i=',i
2827 cd        do k=1,3
2828 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2829 cd        enddo
2830 cd        do k=1,3
2831 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2832 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2833 cd        enddo
2834 cd      enddo
2835       t_eelecij=0.0d0
2836       ees=0.0D0
2837       evdw1=0.0D0
2838       eel_loc=0.0d0
2839       eello_turn3=0.0d0
2840       eello_turn4=0.0d0
2841       ind=0
2842       do i=1,nres
2843         num_cont_hb(i)=0
2844       enddo
2845 cd      print '(a)','Enter EELEC'
2846 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2847       do i=1,nres
2848         gel_loc_loc(i)=0.0d0
2849         gcorr_loc(i)=0.0d0
2850       enddo
2851 c
2852 c
2853 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2854 C
2855 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2856 C
2857       do i=iturn3_start,iturn3_end
2858         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2859      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2860         dxi=dc(1,i)
2861         dyi=dc(2,i)
2862         dzi=dc(3,i)
2863         dx_normi=dc_norm(1,i)
2864         dy_normi=dc_norm(2,i)
2865         dz_normi=dc_norm(3,i)
2866         xmedi=c(1,i)+0.5d0*dxi
2867         ymedi=c(2,i)+0.5d0*dyi
2868         zmedi=c(3,i)+0.5d0*dzi
2869         num_conti=0
2870 c TU ZLE
2871 c        call eelecij(i,i+2,ees,evdw1,eel_loc)
2872         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2873         num_cont_hb(i)=num_conti
2874       enddo
2875       do i=iturn4_start,iturn4_end
2876         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2877      &    .or. itype(i+3).eq.ntyp1
2878      &    .or. itype(i+4).eq.ntyp1) cycle
2879         dxi=dc(1,i)
2880         dyi=dc(2,i)
2881         dzi=dc(3,i)
2882         dx_normi=dc_norm(1,i)
2883         dy_normi=dc_norm(2,i)
2884         dz_normi=dc_norm(3,i)
2885         xmedi=c(1,i)+0.5d0*dxi
2886         ymedi=c(2,i)+0.5d0*dyi
2887         zmedi=c(3,i)+0.5d0*dzi
2888         num_conti=num_cont_hb(i)
2889 c TU ZLE
2890 c        call eelecij(i,i+3,ees,evdw1,eel_loc)
2891         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2892      &   call eturn4(i,eello_turn4)
2893         num_cont_hb(i)=num_conti
2894       enddo   ! i
2895 c
2896 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2897 c
2898 c      do i=iatel_s,iatel_e
2899        do i=7,7
2900         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2901         dxi=dc(1,i)
2902         dyi=dc(2,i)
2903         dzi=dc(3,i)
2904         dx_normi=dc_norm(1,i)
2905         dy_normi=dc_norm(2,i)
2906         dz_normi=dc_norm(3,i)
2907         xmedi=c(1,i)+0.5d0*dxi
2908         ymedi=c(2,i)+0.5d0*dyi
2909         zmedi=c(3,i)+0.5d0*dzi
2910 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2911         num_conti=num_cont_hb(i)
2912 c        do j=ielstart(i),ielend(i)
2913          do j=13,13
2914 c          write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2915           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2916           call eelecij(i,j,ees,evdw1,eel_loc)
2917         enddo ! j
2918         num_cont_hb(i)=num_conti
2919       enddo   ! i
2920 c      write (iout,*) "Number of loop steps in EELEC:",ind
2921 cd      do i=1,nres
2922 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2923 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2924 cd      enddo
2925 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2926 ccc      eel_loc=eel_loc+eello_turn3
2927 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2928       return
2929       end
2930 C-------------------------------------------------------------------------------
2931       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2932       implicit real*8 (a-h,o-z)
2933       include 'DIMENSIONS'
2934 #ifdef MPI
2935       include "mpif.h"
2936 #endif
2937       include 'COMMON.CONTROL'
2938       include 'COMMON.IOUNITS'
2939       include 'COMMON.GEO'
2940       include 'COMMON.VAR'
2941       include 'COMMON.LOCAL'
2942       include 'COMMON.CHAIN'
2943       include 'COMMON.DERIV'
2944       include 'COMMON.INTERACT'
2945       include 'COMMON.CONTACTS'
2946       include 'COMMON.TORSION'
2947       include 'COMMON.VECTORS'
2948       include 'COMMON.FFIELD'
2949       include 'COMMON.TIME1'
2950       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2951      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2952       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2953      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2954      &    gmuij2(4),gmuji2(4)
2955       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2956      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2957      &    num_conti,j1,j2
2958 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2959 #ifdef MOMENT
2960       double precision scal_el /1.0d0/
2961 #else
2962       double precision scal_el /0.5d0/
2963 #endif
2964 C 12/13/98
2965 C 13-go grudnia roku pamietnego...
2966       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2967      &                   0.0d0,1.0d0,0.0d0,
2968      &                   0.0d0,0.0d0,1.0d0/
2969 c          time00=MPI_Wtime()
2970 cd      write (iout,*) "eelecij",i,j
2971 c          ind=ind+1
2972           iteli=itel(i)
2973           itelj=itel(j)
2974           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2975           aaa=app(iteli,itelj)
2976           bbb=bpp(iteli,itelj)
2977           ael6i=ael6(iteli,itelj)
2978           ael3i=ael3(iteli,itelj)
2979           dxj=dc(1,j)
2980           dyj=dc(2,j)
2981           dzj=dc(3,j)
2982           dx_normj=dc_norm(1,j)
2983           dy_normj=dc_norm(2,j)
2984           dz_normj=dc_norm(3,j)
2985           xj=c(1,j)+0.5D0*dxj-xmedi
2986           yj=c(2,j)+0.5D0*dyj-ymedi
2987           zj=c(3,j)+0.5D0*dzj-zmedi
2988           rij=xj*xj+yj*yj+zj*zj
2989           rrmij=1.0D0/rij
2990           rij=dsqrt(rij)
2991           rmij=1.0D0/rij
2992           r3ij=rrmij*rmij
2993           r6ij=r3ij*r3ij
2994           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2995           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2996           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2997           fac=cosa-3.0D0*cosb*cosg
2998           ev1=aaa*r6ij*r6ij
2999 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3000           if (j.eq.i+2) ev1=scal_el*ev1
3001           ev2=bbb*r6ij
3002           fac3=ael6i*r6ij
3003           fac4=ael3i*r3ij
3004           evdwij=ev1+ev2
3005           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3006           el2=fac4*fac
3007           eesij=el1+el2
3008 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3009           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3010           ees=ees+eesij
3011           evdw1=evdw1+evdwij
3012 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3013 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3014 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3015 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3016
3017           if (energy_dec) then
3018               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3019      &'evdw1',i,j,evdwij
3020      &,iteli,itelj,aaa,evdw1
3021               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3022           endif
3023
3024 C
3025 C Calculate contributions to the Cartesian gradient.
3026 C
3027 #ifdef SPLITELE
3028           facvdw=-6*rrmij*(ev1+evdwij)
3029           facel=-3*rrmij*(el1+eesij)
3030           fac1=fac
3031           erij(1)=xj*rmij
3032           erij(2)=yj*rmij
3033           erij(3)=zj*rmij
3034 *
3035 * Radial derivatives. First process both termini of the fragment (i,j)
3036 *
3037           ggg(1)=facel*xj
3038           ggg(2)=facel*yj
3039           ggg(3)=facel*zj
3040 c          do k=1,3
3041 c            ghalf=0.5D0*ggg(k)
3042 c            gelc(k,i)=gelc(k,i)+ghalf
3043 c            gelc(k,j)=gelc(k,j)+ghalf
3044 c          enddo
3045 c 9/28/08 AL Gradient compotents will be summed only at the end
3046           do k=1,3
3047             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3048             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3049           enddo
3050 *
3051 * Loop over residues i+1 thru j-1.
3052 *
3053 cgrad          do k=i+1,j-1
3054 cgrad            do l=1,3
3055 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3056 cgrad            enddo
3057 cgrad          enddo
3058           ggg(1)=facvdw*xj
3059           ggg(2)=facvdw*yj
3060           ggg(3)=facvdw*zj
3061 c          do k=1,3
3062 c            ghalf=0.5D0*ggg(k)
3063 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3064 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3065 c          enddo
3066 c 9/28/08 AL Gradient compotents will be summed only at the end
3067           do k=1,3
3068             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3069             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3070           enddo
3071 *
3072 * Loop over residues i+1 thru j-1.
3073 *
3074 cgrad          do k=i+1,j-1
3075 cgrad            do l=1,3
3076 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3077 cgrad            enddo
3078 cgrad          enddo
3079 #else
3080           facvdw=ev1+evdwij
3081           facel=el1+eesij
3082           fac1=fac
3083           fac=-3*rrmij*(facvdw+facvdw+facel)
3084           erij(1)=xj*rmij
3085           erij(2)=yj*rmij
3086           erij(3)=zj*rmij
3087 *
3088 * Radial derivatives. First process both termini of the fragment (i,j)
3089 *
3090           ggg(1)=fac*xj
3091           ggg(2)=fac*yj
3092           ggg(3)=fac*zj
3093 c          do k=1,3
3094 c            ghalf=0.5D0*ggg(k)
3095 c            gelc(k,i)=gelc(k,i)+ghalf
3096 c            gelc(k,j)=gelc(k,j)+ghalf
3097 c          enddo
3098 c 9/28/08 AL Gradient compotents will be summed only at the end
3099           do k=1,3
3100             gelc_long(k,j)=gelc(k,j)+ggg(k)
3101             gelc_long(k,i)=gelc(k,i)-ggg(k)
3102           enddo
3103 *
3104 * Loop over residues i+1 thru j-1.
3105 *
3106 cgrad          do k=i+1,j-1
3107 cgrad            do l=1,3
3108 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3109 cgrad            enddo
3110 cgrad          enddo
3111 c 9/28/08 AL Gradient compotents will be summed only at the end
3112           ggg(1)=facvdw*xj
3113           ggg(2)=facvdw*yj
3114           ggg(3)=facvdw*zj
3115           do k=1,3
3116             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3117             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3118           enddo
3119 #endif
3120 *
3121 * Angular part
3122 *
3123           ecosa=2.0D0*fac3*fac1+fac4
3124           fac4=-3.0D0*fac4
3125           fac3=-6.0D0*fac3
3126           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3127           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3128           do k=1,3
3129             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3130             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3131           enddo
3132 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3133 cd   &          (dcosg(k),k=1,3)
3134           do k=1,3
3135             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3136           enddo
3137 c          do k=1,3
3138 c            ghalf=0.5D0*ggg(k)
3139 c            gelc(k,i)=gelc(k,i)+ghalf
3140 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3141 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3142 c            gelc(k,j)=gelc(k,j)+ghalf
3143 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3144 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3145 c          enddo
3146 cgrad          do k=i+1,j-1
3147 cgrad            do l=1,3
3148 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3149 cgrad            enddo
3150 cgrad          enddo
3151           do k=1,3
3152             gelc(k,i)=gelc(k,i)
3153      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3154      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3155             gelc(k,j)=gelc(k,j)
3156      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3157      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3158             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3159             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3160           enddo
3161           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3162      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3163      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3164 C
3165 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3166 C   energy of a peptide unit is assumed in the form of a second-order
3167 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3168 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3169 C   are computed for EVERY pair of non-contiguous peptide groups.
3170 C
3171
3172           if (j.lt.nres-1) then
3173             j1=j+1
3174             j2=j-1
3175           else
3176             j1=j-1
3177             j2=j-2
3178           endif
3179           kkk=0
3180           lll=0
3181           do k=1,2
3182             do l=1,2
3183               kkk=kkk+1
3184               muij(kkk)=mu(k,i)*mu(l,j)
3185 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3186 #ifdef NEWCORR
3187              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3188 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3189              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3190              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3191 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3192              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3193 #endif
3194             enddo
3195           enddo
3196 cd         write (iout,*) 'EELEC: i',i,' j',j
3197 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3198 cd          write(iout,*) 'muij',muij
3199           ury=scalar(uy(1,i),erij)
3200           urz=scalar(uz(1,i),erij)
3201           vry=scalar(uy(1,j),erij)
3202           vrz=scalar(uz(1,j),erij)
3203           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3204           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3205           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3206           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3207           fac=dsqrt(-ael6i)*r3ij
3208           a22=a22*fac
3209           a23=a23*fac
3210           a32=a32*fac
3211           a33=a33*fac
3212 cd          write (iout,'(4i5,4f10.5)')
3213 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3214 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3215 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3216 cd     &      uy(:,j),uz(:,j)
3217 cd          write (iout,'(4f10.5)')
3218 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3219 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3220 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3221 cd           write (iout,'(9f10.5/)')
3222 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3223 C Derivatives of the elements of A in virtual-bond vectors
3224           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3225           do k=1,3
3226             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3227             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3228             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3229             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3230             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3231             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3232             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3233             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3234             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3235             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3236             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3237             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3238           enddo
3239 C Compute radial contributions to the gradient
3240           facr=-3.0d0*rrmij
3241           a22der=a22*facr
3242           a23der=a23*facr
3243           a32der=a32*facr
3244           a33der=a33*facr
3245           agg(1,1)=a22der*xj
3246           agg(2,1)=a22der*yj
3247           agg(3,1)=a22der*zj
3248           agg(1,2)=a23der*xj
3249           agg(2,2)=a23der*yj
3250           agg(3,2)=a23der*zj
3251           agg(1,3)=a32der*xj
3252           agg(2,3)=a32der*yj
3253           agg(3,3)=a32der*zj
3254           agg(1,4)=a33der*xj
3255           agg(2,4)=a33der*yj
3256           agg(3,4)=a33der*zj
3257 C Add the contributions coming from er
3258           fac3=-3.0d0*fac
3259           do k=1,3
3260             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3261             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3262             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3263             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3264           enddo
3265           do k=1,3
3266 C Derivatives in DC(i)
3267 cgrad            ghalf1=0.5d0*agg(k,1)
3268 cgrad            ghalf2=0.5d0*agg(k,2)
3269 cgrad            ghalf3=0.5d0*agg(k,3)
3270 cgrad            ghalf4=0.5d0*agg(k,4)
3271             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3272      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3273             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3274      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3275             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3276      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3277             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3278      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3279 C Derivatives in DC(i+1)
3280             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3281      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3282             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3283      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3284             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3285      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3286             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3287      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3288 C Derivatives in DC(j)
3289             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3290      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3291             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3292      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3293             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3294      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3295             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3296      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3297 C Derivatives in DC(j+1) or DC(nres-1)
3298             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3299      &      -3.0d0*vryg(k,3)*ury)
3300             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3301      &      -3.0d0*vrzg(k,3)*ury)
3302             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3303      &      -3.0d0*vryg(k,3)*urz)
3304             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3305      &      -3.0d0*vrzg(k,3)*urz)
3306 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3307 cgrad              do l=1,4
3308 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3309 cgrad              enddo
3310 cgrad            endif
3311           enddo
3312           acipa(1,1)=a22
3313           acipa(1,2)=a23
3314           acipa(2,1)=a32
3315           acipa(2,2)=a33
3316           a22=-a22
3317           a23=-a23
3318           do l=1,2
3319             do k=1,3
3320               agg(k,l)=-agg(k,l)
3321               aggi(k,l)=-aggi(k,l)
3322               aggi1(k,l)=-aggi1(k,l)
3323               aggj(k,l)=-aggj(k,l)
3324               aggj1(k,l)=-aggj1(k,l)
3325             enddo
3326           enddo
3327           if (j.lt.nres-1) then
3328             a22=-a22
3329             a32=-a32
3330             do l=1,3,2
3331               do k=1,3
3332                 agg(k,l)=-agg(k,l)
3333                 aggi(k,l)=-aggi(k,l)
3334                 aggi1(k,l)=-aggi1(k,l)
3335                 aggj(k,l)=-aggj(k,l)
3336                 aggj1(k,l)=-aggj1(k,l)
3337               enddo
3338             enddo
3339           else
3340             a22=-a22
3341             a23=-a23
3342             a32=-a32
3343             a33=-a33
3344             do l=1,4
3345               do k=1,3
3346                 agg(k,l)=-agg(k,l)
3347                 aggi(k,l)=-aggi(k,l)
3348                 aggi1(k,l)=-aggi1(k,l)
3349                 aggj(k,l)=-aggj(k,l)
3350                 aggj1(k,l)=-aggj1(k,l)
3351               enddo
3352             enddo
3353           endif
3354           ENDIF ! WCORR
3355           IF (wel_loc.gt.0.0d0) THEN
3356 C Contribution to the local-electrostatic energy coming from the i-j pair
3357           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3358      &     +a33*muij(4)
3359 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3360 C Calculate patrial derivative for theta angle
3361 #ifdef NEWCORR
3362          geel_loc_ij=a22*gmuij1(1)
3363      &     +a23*gmuij1(2)
3364      &     +a32*gmuij1(3)
3365      &     +a33*gmuij1(4)
3366 c         write(iout,*) "derivative over thatai"
3367 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3368 c     &   a33*gmuij1(4)
3369          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3370      &      geel_loc_ij*wel_loc
3371 c         write(iout,*) "derivative over thatai-1"
3372 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3373 c     &   a33*gmuij2(4)
3374          geel_loc_ij=
3375      &     a22*gmuij2(1)
3376      &     +a23*gmuij2(2)
3377      &     +a32*gmuij2(3)
3378      &     +a33*gmuij2(4)
3379          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3380      &      geel_loc_ij*wel_loc
3381 c  Derivative over j residue
3382          geel_loc_ji=a22*gmuji1(1)
3383      &     +a23*gmuji1(2)
3384      &     +a32*gmuji1(3)
3385      &     +a33*gmuji1(4)
3386 c         write(iout,*) "derivative over thataj"
3387 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3388 c     &   a33*gmuji1(4)
3389
3390         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3391      &      geel_loc_ji*wel_loc
3392          geel_loc_ji=
3393      &     +a22*gmuji2(1)
3394      &     +a23*gmuji2(2)
3395      &     +a32*gmuji2(3)
3396      &     +a33*gmuji2(4)
3397 c         write(iout,*) "derivative over thataj-1"
3398 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3399 c     &   a33*gmuji2(4)
3400          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3401      &      geel_loc_ji*wel_loc
3402 #endif
3403 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3404
3405           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3406      &            'eelloc',i,j,eel_loc_ij
3407 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3408
3409           eel_loc=eel_loc+eel_loc_ij
3410 C Partial derivatives in virtual-bond dihedral angles gamma
3411           if (i.gt.1)
3412      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3413      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3414      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3415           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3416      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3417      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3418 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3419           do l=1,3
3420             ggg(l)=agg(l,1)*muij(1)+
3421      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3422             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3423             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3424 cgrad            ghalf=0.5d0*ggg(l)
3425 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3426 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3427           enddo
3428 cgrad          do k=i+1,j2
3429 cgrad            do l=1,3
3430 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3431 cgrad            enddo
3432 cgrad          enddo
3433 C Remaining derivatives of eello
3434           do l=1,3
3435             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3436      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3437             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3438      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3439             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3440      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3441             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3442      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3443           enddo
3444           ENDIF
3445 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3446 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3447           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3448      &       .and. num_conti.le.maxconts) then
3449 c            write (iout,*) i,j," entered corr"
3450 C
3451 C Calculate the contact function. The ith column of the array JCONT will
3452 C contain the numbers of atoms that make contacts with the atom I (of numbers
3453 C greater than I). The arrays FACONT and GACONT will contain the values of
3454 C the contact function and its derivative.
3455 c           r0ij=1.02D0*rpp(iteli,itelj)
3456 c           r0ij=1.11D0*rpp(iteli,itelj)
3457             r0ij=2.20D0*rpp(iteli,itelj)
3458 c           r0ij=1.55D0*rpp(iteli,itelj)
3459             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3460             if (fcont.gt.0.0D0) then
3461               num_conti=num_conti+1
3462               if (num_conti.gt.maxconts) then
3463                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3464      &                         ' will skip next contacts for this conf.'
3465               else
3466                 jcont_hb(num_conti,i)=j
3467 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3468 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3469                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3470      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3471 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3472 C  terms.
3473                 d_cont(num_conti,i)=rij
3474 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3475 C     --- Electrostatic-interaction matrix ---
3476                 a_chuj(1,1,num_conti,i)=a22
3477                 a_chuj(1,2,num_conti,i)=a23
3478                 a_chuj(2,1,num_conti,i)=a32
3479                 a_chuj(2,2,num_conti,i)=a33
3480 C     --- Gradient of rij
3481                 do kkk=1,3
3482                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3483                 enddo
3484                 kkll=0
3485                 do k=1,2
3486                   do l=1,2
3487                     kkll=kkll+1
3488                     do m=1,3
3489                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3490                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3491                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3492                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3493                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3494                     enddo
3495                   enddo
3496                 enddo
3497                 ENDIF
3498                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3499 C Calculate contact energies
3500                 cosa4=4.0D0*cosa
3501                 wij=cosa-3.0D0*cosb*cosg
3502                 cosbg1=cosb+cosg
3503                 cosbg2=cosb-cosg
3504 c               fac3=dsqrt(-ael6i)/r0ij**3
3505                 fac3=dsqrt(-ael6i)*r3ij
3506 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3507                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3508                 if (ees0tmp.gt.0) then
3509                   ees0pij=dsqrt(ees0tmp)
3510                 else
3511                   ees0pij=0
3512                 endif
3513 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3514                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3515                 if (ees0tmp.gt.0) then
3516                   ees0mij=dsqrt(ees0tmp)
3517                 else
3518                   ees0mij=0
3519                 endif
3520 c               ees0mij=0.0D0
3521                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3522                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3523 C Diagnostics. Comment out or remove after debugging!
3524 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3525 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3526 c               ees0m(num_conti,i)=0.0D0
3527 C End diagnostics.
3528 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3529 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3530 C Angular derivatives of the contact function
3531                 ees0pij1=fac3/ees0pij
3532                 ees0mij1=fac3/ees0mij
3533                 fac3p=-3.0D0*fac3*rrmij
3534                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3535                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3536 c               ees0mij1=0.0D0
3537                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3538                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3539                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3540                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3541                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3542                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3543                 ecosap=ecosa1+ecosa2
3544                 ecosbp=ecosb1+ecosb2
3545                 ecosgp=ecosg1+ecosg2
3546                 ecosam=ecosa1-ecosa2
3547                 ecosbm=ecosb1-ecosb2
3548                 ecosgm=ecosg1-ecosg2
3549 C Diagnostics
3550 c               ecosap=ecosa1
3551 c               ecosbp=ecosb1
3552 c               ecosgp=ecosg1
3553 c               ecosam=0.0D0
3554 c               ecosbm=0.0D0
3555 c               ecosgm=0.0D0
3556 C End diagnostics
3557                 facont_hb(num_conti,i)=fcont
3558                 fprimcont=fprimcont/rij
3559 cd              facont_hb(num_conti,i)=1.0D0
3560 C Following line is for diagnostics.
3561 cd              fprimcont=0.0D0
3562                 do k=1,3
3563                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3564                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3565                 enddo
3566                 do k=1,3
3567                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3568                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3569                 enddo
3570                 gggp(1)=gggp(1)+ees0pijp*xj
3571                 gggp(2)=gggp(2)+ees0pijp*yj
3572                 gggp(3)=gggp(3)+ees0pijp*zj
3573                 gggm(1)=gggm(1)+ees0mijp*xj
3574                 gggm(2)=gggm(2)+ees0mijp*yj
3575                 gggm(3)=gggm(3)+ees0mijp*zj
3576 C Derivatives due to the contact function
3577                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3578                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3579                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3580                 do k=1,3
3581 c
3582 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3583 c          following the change of gradient-summation algorithm.
3584 c
3585 cgrad                  ghalfp=0.5D0*gggp(k)
3586 cgrad                  ghalfm=0.5D0*gggm(k)
3587                   gacontp_hb1(k,num_conti,i)=!ghalfp
3588      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3589      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3590                   gacontp_hb2(k,num_conti,i)=!ghalfp
3591      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3592      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3593                   gacontp_hb3(k,num_conti,i)=gggp(k)
3594                   gacontm_hb1(k,num_conti,i)=!ghalfm
3595      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3596      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3597                   gacontm_hb2(k,num_conti,i)=!ghalfm
3598      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3599      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3600                   gacontm_hb3(k,num_conti,i)=gggm(k)
3601                 enddo
3602 C Diagnostics. Comment out or remove after debugging!
3603 cdiag           do k=1,3
3604 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3605 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3606 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3607 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3608 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3609 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3610 cdiag           enddo
3611               ENDIF ! wcorr
3612               endif  ! num_conti.le.maxconts
3613             endif  ! fcont.gt.0
3614           endif    ! j.gt.i+1
3615           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3616             do k=1,4
3617               do l=1,3
3618                 ghalf=0.5d0*agg(l,k)
3619                 aggi(l,k)=aggi(l,k)+ghalf
3620                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3621                 aggj(l,k)=aggj(l,k)+ghalf
3622               enddo
3623             enddo
3624             if (j.eq.nres-1 .and. i.lt.j-2) then
3625               do k=1,4
3626                 do l=1,3
3627                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3628                 enddo
3629               enddo
3630             endif
3631           endif
3632 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3633       return
3634       end
3635 C-----------------------------------------------------------------------------
3636       subroutine eturn3(i,eello_turn3)
3637 C Third- and fourth-order contributions from turns
3638       implicit real*8 (a-h,o-z)
3639       include 'DIMENSIONS'
3640       include 'COMMON.IOUNITS'
3641       include 'COMMON.GEO'
3642       include 'COMMON.VAR'
3643       include 'COMMON.LOCAL'
3644       include 'COMMON.CHAIN'
3645       include 'COMMON.DERIV'
3646       include 'COMMON.INTERACT'
3647       include 'COMMON.CONTACTS'
3648       include 'COMMON.TORSION'
3649       include 'COMMON.VECTORS'
3650       include 'COMMON.FFIELD'
3651       include 'COMMON.CONTROL'
3652       dimension ggg(3)
3653       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3654      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3655      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3656       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3657      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3658       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3659      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3660      &    num_conti,j1,j2
3661       j=i+2
3662 c      write (iout,*) "eturn3",i,j,j1,j2
3663       a_temp(1,1)=a22
3664       a_temp(1,2)=a23
3665       a_temp(2,1)=a32
3666       a_temp(2,2)=a33
3667 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3668 C
3669 C               Third-order contributions
3670 C
3671 C                 (i+2)o----(i+3)
3672 C                      | |
3673 C                      | |
3674 C                 (i+1)o----i
3675 C
3676 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3677 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3678         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3679         call transpose2(auxmat(1,1),auxmat1(1,1))
3680         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3681         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3682         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3683      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3684 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3685 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3686 cd     &    ' eello_turn3_num',4*eello_turn3_num
3687 C Derivatives in gamma(i)
3688         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3689         call transpose2(auxmat2(1,1),auxmat3(1,1))
3690         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3691         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3692 C Derivatives in gamma(i+1)
3693         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3694         call transpose2(auxmat2(1,1),auxmat3(1,1))
3695         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3696         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3697      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3698 C Cartesian derivatives
3699         do l=1,3
3700 c            ghalf1=0.5d0*agg(l,1)
3701 c            ghalf2=0.5d0*agg(l,2)
3702 c            ghalf3=0.5d0*agg(l,3)
3703 c            ghalf4=0.5d0*agg(l,4)
3704           a_temp(1,1)=aggi(l,1)!+ghalf1
3705           a_temp(1,2)=aggi(l,2)!+ghalf2
3706           a_temp(2,1)=aggi(l,3)!+ghalf3
3707           a_temp(2,2)=aggi(l,4)!+ghalf4
3708           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3709           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3710      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3711           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3712           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3713           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3714           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3715           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3716           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3717      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3718           a_temp(1,1)=aggj(l,1)!+ghalf1
3719           a_temp(1,2)=aggj(l,2)!+ghalf2
3720           a_temp(2,1)=aggj(l,3)!+ghalf3
3721           a_temp(2,2)=aggj(l,4)!+ghalf4
3722           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3723           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3724      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3725           a_temp(1,1)=aggj1(l,1)
3726           a_temp(1,2)=aggj1(l,2)
3727           a_temp(2,1)=aggj1(l,3)
3728           a_temp(2,2)=aggj1(l,4)
3729           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3730           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3731      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3732         enddo
3733       return
3734       end
3735 C-------------------------------------------------------------------------------
3736       subroutine eturn4(i,eello_turn4)
3737 C Third- and fourth-order contributions from turns
3738       implicit real*8 (a-h,o-z)
3739       include 'DIMENSIONS'
3740       include 'COMMON.IOUNITS'
3741       include 'COMMON.GEO'
3742       include 'COMMON.VAR'
3743       include 'COMMON.LOCAL'
3744       include 'COMMON.CHAIN'
3745       include 'COMMON.DERIV'
3746       include 'COMMON.INTERACT'
3747       include 'COMMON.CONTACTS'
3748       include 'COMMON.TORSION'
3749       include 'COMMON.VECTORS'
3750       include 'COMMON.FFIELD'
3751       include 'COMMON.CONTROL'
3752       dimension ggg(3)
3753       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3754      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3755      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2)
3756       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3757      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3758       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3759      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3760      &    num_conti,j1,j2
3761       j=i+3
3762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3763 C
3764 C               Fourth-order contributions
3765 C
3766 C                 (i+3)o----(i+4)
3767 C                     /  |
3768 C               (i+2)o   |
3769 C                     \  |
3770 C                 (i+1)o----i
3771 C
3772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3773 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3774 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3775         a_temp(1,1)=a22
3776         a_temp(1,2)=a23
3777         a_temp(2,1)=a32
3778         a_temp(2,2)=a33
3779         iti1=itortyp(itype(i+1))
3780         iti2=itortyp(itype(i+2))
3781         iti3=itortyp(itype(i+3))
3782 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3783         call transpose2(EUg(1,1,i+1),e1t(1,1))
3784         call transpose2(Eug(1,1,i+2),e2t(1,1))
3785         call transpose2(Eug(1,1,i+3),e3t(1,1))
3786         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3787         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3788         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3789 c        s1=0.0
3790 c        gs1=0.0
3791         s1=scalar2(b1(1,i+2),auxvec(1))
3792 c        gs1=scalar2(gtb1(1,i+2),auxgvec(1))
3793         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3794         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3795         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3796 c        s2=0.0
3797 c        gs2=0.0
3798         s2=scalar2(b1(1,i+1),auxvec(1))
3799 c        gs2=scalar2(gtb1(1,i+1),auxgvec(1))
3800 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),ggb1(1,i+2),
3801 c     &  ggb1(1,i+1)
3802         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3803         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3804         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3805         eello_turn4=eello_turn4-(s1+s2+s3)
3806 #ifdef NEWCORR
3807 c        geel_loc_ij=-(gs1+gs2)
3808 c         gloc(nphi+i,icg)=gloc(nphi+i,icg)-
3809 c     &   gs1
3810 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3811 c     &   gs2
3812 #endif
3813         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3814      &      'eturn4',i,j,-(s1+s2+s3)
3815 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3816 cd     &    ' eello_turn4_num',8*eello_turn4_num
3817 C Derivatives in gamma(i)
3818         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3819         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3820         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3821         s1=scalar2(b1(1,i+2),auxvec(1))
3822         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3823         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3824         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3825 C Derivatives in gamma(i+1)
3826         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3827         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3828         s2=scalar2(b1(1,i+1),auxvec(1))
3829         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3830         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3831         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3832         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3833 C Derivatives in gamma(i+2)
3834         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3835         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3836         s1=scalar2(b1(1,i+2),auxvec(1))
3837         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3838         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3839         s2=scalar2(b1(1,i+1),auxvec(1))
3840         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3841         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3842         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3843         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3844 C Cartesian derivatives
3845 C Derivatives of this turn contributions in DC(i+2)
3846         if (j.lt.nres-1) then
3847           do l=1,3
3848             a_temp(1,1)=agg(l,1)
3849             a_temp(1,2)=agg(l,2)
3850             a_temp(2,1)=agg(l,3)
3851             a_temp(2,2)=agg(l,4)
3852             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3853             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3854             s1=scalar2(b1(1,i+2),auxvec(1))
3855             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3856             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3857             s2=scalar2(b1(1,i+1),auxvec(1))
3858             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3859             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3860             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3861             ggg(l)=-(s1+s2+s3)
3862             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3863           enddo
3864         endif
3865 C Remaining derivatives of this turn contribution
3866         do l=1,3
3867           a_temp(1,1)=aggi(l,1)
3868           a_temp(1,2)=aggi(l,2)
3869           a_temp(2,1)=aggi(l,3)
3870           a_temp(2,2)=aggi(l,4)
3871           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3872           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3873           s1=scalar2(b1(1,i+2),auxvec(1))
3874           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3875           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3876           s2=scalar2(b1(1,i+1),auxvec(1))
3877           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3878           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3879           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3880           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3881           a_temp(1,1)=aggi1(l,1)
3882           a_temp(1,2)=aggi1(l,2)
3883           a_temp(2,1)=aggi1(l,3)
3884           a_temp(2,2)=aggi1(l,4)
3885           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3886           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3887           s1=scalar2(b1(1,i+2),auxvec(1))
3888           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3889           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3890           s2=scalar2(b1(1,i+1),auxvec(1))
3891           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3892           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3893           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3894           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3895           a_temp(1,1)=aggj(l,1)
3896           a_temp(1,2)=aggj(l,2)
3897           a_temp(2,1)=aggj(l,3)
3898           a_temp(2,2)=aggj(l,4)
3899           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3900           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3901           s1=scalar2(b1(1,i+2),auxvec(1))
3902           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3903           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3904           s2=scalar2(b1(1,i+1),auxvec(1))
3905           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3906           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3907           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3909           a_temp(1,1)=aggj1(l,1)
3910           a_temp(1,2)=aggj1(l,2)
3911           a_temp(2,1)=aggj1(l,3)
3912           a_temp(2,2)=aggj1(l,4)
3913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3915           s1=scalar2(b1(1,i+2),auxvec(1))
3916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3918           s2=scalar2(b1(1,i+1),auxvec(1))
3919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3923           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3924         enddo
3925       return
3926       end
3927 C-----------------------------------------------------------------------------
3928       subroutine vecpr(u,v,w)
3929       implicit real*8(a-h,o-z)
3930       dimension u(3),v(3),w(3)
3931       w(1)=u(2)*v(3)-u(3)*v(2)
3932       w(2)=-u(1)*v(3)+u(3)*v(1)
3933       w(3)=u(1)*v(2)-u(2)*v(1)
3934       return
3935       end
3936 C-----------------------------------------------------------------------------
3937       subroutine unormderiv(u,ugrad,unorm,ungrad)
3938 C This subroutine computes the derivatives of a normalized vector u, given
3939 C the derivatives computed without normalization conditions, ugrad. Returns
3940 C ungrad.
3941       implicit none
3942       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3943       double precision vec(3)
3944       double precision scalar
3945       integer i,j
3946 c      write (2,*) 'ugrad',ugrad
3947 c      write (2,*) 'u',u
3948       do i=1,3
3949         vec(i)=scalar(ugrad(1,i),u(1))
3950       enddo
3951 c      write (2,*) 'vec',vec
3952       do i=1,3
3953         do j=1,3
3954           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3955         enddo
3956       enddo
3957 c      write (2,*) 'ungrad',ungrad
3958       return
3959       end
3960 C-----------------------------------------------------------------------------
3961       subroutine escp_soft_sphere(evdw2,evdw2_14)
3962 C
3963 C This subroutine calculates the excluded-volume interaction energy between
3964 C peptide-group centers and side chains and its gradient in virtual-bond and
3965 C side-chain vectors.
3966 C
3967       implicit real*8 (a-h,o-z)
3968       include 'DIMENSIONS'
3969       include 'COMMON.GEO'
3970       include 'COMMON.VAR'
3971       include 'COMMON.LOCAL'
3972       include 'COMMON.CHAIN'
3973       include 'COMMON.DERIV'
3974       include 'COMMON.INTERACT'
3975       include 'COMMON.FFIELD'
3976       include 'COMMON.IOUNITS'
3977       include 'COMMON.CONTROL'
3978       dimension ggg(3)
3979       evdw2=0.0D0
3980       evdw2_14=0.0d0
3981       r0_scp=4.5d0
3982 cd    print '(a)','Enter ESCP'
3983 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3984       do i=iatscp_s,iatscp_e
3985         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3986         iteli=itel(i)
3987         xi=0.5D0*(c(1,i)+c(1,i+1))
3988         yi=0.5D0*(c(2,i)+c(2,i+1))
3989         zi=0.5D0*(c(3,i)+c(3,i+1))
3990
3991         do iint=1,nscp_gr(i)
3992
3993         do j=iscpstart(i,iint),iscpend(i,iint)
3994           if (itype(j).eq.ntyp1) cycle
3995           itypj=iabs(itype(j))
3996 C Uncomment following three lines for SC-p interactions
3997 c         xj=c(1,nres+j)-xi
3998 c         yj=c(2,nres+j)-yi
3999 c         zj=c(3,nres+j)-zi
4000 C Uncomment following three lines for Ca-p interactions
4001           xj=c(1,j)-xi
4002           yj=c(2,j)-yi
4003           zj=c(3,j)-zi
4004           rij=xj*xj+yj*yj+zj*zj
4005           r0ij=r0_scp
4006           r0ijsq=r0ij*r0ij
4007           if (rij.lt.r0ijsq) then
4008             evdwij=0.25d0*(rij-r0ijsq)**2
4009             fac=rij-r0ijsq
4010           else
4011             evdwij=0.0d0
4012             fac=0.0d0
4013           endif
4014           evdw2=evdw2+evdwij
4015 C
4016 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4017 C
4018           ggg(1)=xj*fac
4019           ggg(2)=yj*fac
4020           ggg(3)=zj*fac
4021 cgrad          if (j.lt.i) then
4022 cd          write (iout,*) 'j<i'
4023 C Uncomment following three lines for SC-p interactions
4024 c           do k=1,3
4025 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4026 c           enddo
4027 cgrad          else
4028 cd          write (iout,*) 'j>i'
4029 cgrad            do k=1,3
4030 cgrad              ggg(k)=-ggg(k)
4031 C Uncomment following line for SC-p interactions
4032 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4033 cgrad            enddo
4034 cgrad          endif
4035 cgrad          do k=1,3
4036 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4037 cgrad          enddo
4038 cgrad          kstart=min0(i+1,j)
4039 cgrad          kend=max0(i-1,j-1)
4040 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4041 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4042 cgrad          do k=kstart,kend
4043 cgrad            do l=1,3
4044 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4045 cgrad            enddo
4046 cgrad          enddo
4047           do k=1,3
4048             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4049             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4050           enddo
4051         enddo
4052
4053         enddo ! iint
4054       enddo ! i
4055       return
4056       end
4057 C-----------------------------------------------------------------------------
4058       subroutine escp(evdw2,evdw2_14)
4059 C
4060 C This subroutine calculates the excluded-volume interaction energy between
4061 C peptide-group centers and side chains and its gradient in virtual-bond and
4062 C side-chain vectors.
4063 C
4064       implicit real*8 (a-h,o-z)
4065       include 'DIMENSIONS'
4066       include 'COMMON.GEO'
4067       include 'COMMON.VAR'
4068       include 'COMMON.LOCAL'
4069       include 'COMMON.CHAIN'
4070       include 'COMMON.DERIV'
4071       include 'COMMON.INTERACT'
4072       include 'COMMON.FFIELD'
4073       include 'COMMON.IOUNITS'
4074       include 'COMMON.CONTROL'
4075       dimension ggg(3)
4076       evdw2=0.0D0
4077       evdw2_14=0.0d0
4078 cd    print '(a)','Enter ESCP'
4079 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4080       do i=iatscp_s,iatscp_e
4081         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4082         iteli=itel(i)
4083         xi=0.5D0*(c(1,i)+c(1,i+1))
4084         yi=0.5D0*(c(2,i)+c(2,i+1))
4085         zi=0.5D0*(c(3,i)+c(3,i+1))
4086
4087         do iint=1,nscp_gr(i)
4088
4089         do j=iscpstart(i,iint),iscpend(i,iint)
4090           itypj=iabs(itype(j))
4091           if (itypj.eq.ntyp1) cycle
4092 C Uncomment following three lines for SC-p interactions
4093 c         xj=c(1,nres+j)-xi
4094 c         yj=c(2,nres+j)-yi
4095 c         zj=c(3,nres+j)-zi
4096 C Uncomment following three lines for Ca-p interactions
4097           xj=c(1,j)-xi
4098           yj=c(2,j)-yi
4099           zj=c(3,j)-zi
4100           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4101           fac=rrij**expon2
4102           e1=fac*fac*aad(itypj,iteli)
4103           e2=fac*bad(itypj,iteli)
4104           if (iabs(j-i) .le. 2) then
4105             e1=scal14*e1
4106             e2=scal14*e2
4107             evdw2_14=evdw2_14+e1+e2
4108           endif
4109           evdwij=e1+e2
4110           evdw2=evdw2+evdwij
4111           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4112      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4113      &       bad(itypj,iteli)
4114 C
4115 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4116 C
4117           fac=-(evdwij+e1)*rrij
4118           ggg(1)=xj*fac
4119           ggg(2)=yj*fac
4120           ggg(3)=zj*fac
4121 cgrad          if (j.lt.i) then
4122 cd          write (iout,*) 'j<i'
4123 C Uncomment following three lines for SC-p interactions
4124 c           do k=1,3
4125 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4126 c           enddo
4127 cgrad          else
4128 cd          write (iout,*) 'j>i'
4129 cgrad            do k=1,3
4130 cgrad              ggg(k)=-ggg(k)
4131 C Uncomment following line for SC-p interactions
4132 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4133 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4134 cgrad            enddo
4135 cgrad          endif
4136 cgrad          do k=1,3
4137 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4138 cgrad          enddo
4139 cgrad          kstart=min0(i+1,j)
4140 cgrad          kend=max0(i-1,j-1)
4141 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4142 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4143 cgrad          do k=kstart,kend
4144 cgrad            do l=1,3
4145 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4146 cgrad            enddo
4147 cgrad          enddo
4148           do k=1,3
4149             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4150             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4151           enddo
4152         enddo
4153
4154         enddo ! iint
4155       enddo ! i
4156       do i=1,nct
4157         do j=1,3
4158           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4159           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4160           gradx_scp(j,i)=expon*gradx_scp(j,i)
4161         enddo
4162       enddo
4163 C******************************************************************************
4164 C
4165 C                              N O T E !!!
4166 C
4167 C To save time the factor EXPON has been extracted from ALL components
4168 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4169 C use!
4170 C
4171 C******************************************************************************
4172       return
4173       end
4174 C--------------------------------------------------------------------------
4175       subroutine edis(ehpb)
4176 C
4177 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4178 C
4179       implicit real*8 (a-h,o-z)
4180       include 'DIMENSIONS'
4181       include 'COMMON.SBRIDGE'
4182       include 'COMMON.CHAIN'
4183       include 'COMMON.DERIV'
4184       include 'COMMON.VAR'
4185       include 'COMMON.INTERACT'
4186       include 'COMMON.IOUNITS'
4187       dimension ggg(3)
4188       ehpb=0.0D0
4189 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4190 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4191       if (link_end.eq.0) return
4192       do i=link_start,link_end
4193 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4194 C CA-CA distance used in regularization of structure.
4195         ii=ihpb(i)
4196         jj=jhpb(i)
4197 C iii and jjj point to the residues for which the distance is assigned.
4198         if (ii.gt.nres) then
4199           iii=ii-nres
4200           jjj=jj-nres
4201         else
4202           iii=ii
4203           jjj=jj
4204         endif
4205 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4206 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4207 C    distance and angle dependent SS bond potential.
4208         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4209      & iabs(itype(jjj)).eq.1) then
4210           call ssbond_ene(iii,jjj,eij)
4211           ehpb=ehpb+2*eij
4212 cd          write (iout,*) "eij",eij
4213         else
4214 C Calculate the distance between the two points and its difference from the
4215 C target distance.
4216         dd=dist(ii,jj)
4217         rdis=dd-dhpb(i)
4218 C Get the force constant corresponding to this distance.
4219         waga=forcon(i)
4220 C Calculate the contribution to energy.
4221         ehpb=ehpb+waga*rdis*rdis
4222 C
4223 C Evaluate gradient.
4224 C
4225         fac=waga*rdis/dd
4226 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4227 cd   &   ' waga=',waga,' fac=',fac
4228         do j=1,3
4229           ggg(j)=fac*(c(j,jj)-c(j,ii))
4230         enddo
4231 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4232 C If this is a SC-SC distance, we need to calculate the contributions to the
4233 C Cartesian gradient in the SC vectors (ghpbx).
4234         if (iii.lt.ii) then
4235           do j=1,3
4236             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4237             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4238           enddo
4239         endif
4240 cgrad        do j=iii,jjj-1
4241 cgrad          do k=1,3
4242 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4243 cgrad          enddo
4244 cgrad        enddo
4245         do k=1,3
4246           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4247           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4248         enddo
4249         endif
4250       enddo
4251       ehpb=0.5D0*ehpb
4252       return
4253       end
4254 C--------------------------------------------------------------------------
4255       subroutine ssbond_ene(i,j,eij)
4256 C
4257 C Calculate the distance and angle dependent SS-bond potential energy
4258 C using a free-energy function derived based on RHF/6-31G** ab initio
4259 C calculations of diethyl disulfide.
4260 C
4261 C A. Liwo and U. Kozlowska, 11/24/03
4262 C
4263       implicit real*8 (a-h,o-z)
4264       include 'DIMENSIONS'
4265       include 'COMMON.SBRIDGE'
4266       include 'COMMON.CHAIN'
4267       include 'COMMON.DERIV'
4268       include 'COMMON.LOCAL'
4269       include 'COMMON.INTERACT'
4270       include 'COMMON.VAR'
4271       include 'COMMON.IOUNITS'
4272       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4273       itypi=iabs(itype(i))
4274       xi=c(1,nres+i)
4275       yi=c(2,nres+i)
4276       zi=c(3,nres+i)
4277       dxi=dc_norm(1,nres+i)
4278       dyi=dc_norm(2,nres+i)
4279       dzi=dc_norm(3,nres+i)
4280 c      dsci_inv=dsc_inv(itypi)
4281       dsci_inv=vbld_inv(nres+i)
4282       itypj=iabs(itype(j))
4283 c      dscj_inv=dsc_inv(itypj)
4284       dscj_inv=vbld_inv(nres+j)
4285       xj=c(1,nres+j)-xi
4286       yj=c(2,nres+j)-yi
4287       zj=c(3,nres+j)-zi
4288       dxj=dc_norm(1,nres+j)
4289       dyj=dc_norm(2,nres+j)
4290       dzj=dc_norm(3,nres+j)
4291       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4292       rij=dsqrt(rrij)
4293       erij(1)=xj*rij
4294       erij(2)=yj*rij
4295       erij(3)=zj*rij
4296       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4297       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4298       om12=dxi*dxj+dyi*dyj+dzi*dzj
4299       do k=1,3
4300         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4301         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4302       enddo
4303       rij=1.0d0/rij
4304       deltad=rij-d0cm
4305       deltat1=1.0d0-om1
4306       deltat2=1.0d0+om2
4307       deltat12=om2-om1+2.0d0
4308       cosphi=om12-om1*om2
4309       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4310      &  +akct*deltad*deltat12
4311      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4312 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4313 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4314 c     &  " deltat12",deltat12," eij",eij
4315       ed=2*akcm*deltad+akct*deltat12
4316       pom1=akct*deltad
4317       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4318       eom1=-2*akth*deltat1-pom1-om2*pom2
4319       eom2= 2*akth*deltat2+pom1-om1*pom2
4320       eom12=pom2
4321       do k=1,3
4322         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4323         ghpbx(k,i)=ghpbx(k,i)-ggk
4324      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4325      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4326         ghpbx(k,j)=ghpbx(k,j)+ggk
4327      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4328      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4329         ghpbc(k,i)=ghpbc(k,i)-ggk
4330         ghpbc(k,j)=ghpbc(k,j)+ggk
4331       enddo
4332 C
4333 C Calculate the components of the gradient in DC and X
4334 C
4335 cgrad      do k=i,j-1
4336 cgrad        do l=1,3
4337 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4338 cgrad        enddo
4339 cgrad      enddo
4340       return
4341       end
4342 C--------------------------------------------------------------------------
4343       subroutine ebond(estr)
4344 c
4345 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4346 c
4347       implicit real*8 (a-h,o-z)
4348       include 'DIMENSIONS'
4349       include 'COMMON.LOCAL'
4350       include 'COMMON.GEO'
4351       include 'COMMON.INTERACT'
4352       include 'COMMON.DERIV'
4353       include 'COMMON.VAR'
4354       include 'COMMON.CHAIN'
4355       include 'COMMON.IOUNITS'
4356       include 'COMMON.NAMES'
4357       include 'COMMON.FFIELD'
4358       include 'COMMON.CONTROL'
4359       include 'COMMON.SETUP'
4360       double precision u(3),ud(3)
4361       estr=0.0d0
4362       estr1=0.0d0
4363       do i=ibondp_start,ibondp_end
4364         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4365           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4366           do j=1,3
4367           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4368      &      *dc(j,i-1)/vbld(i)
4369           enddo
4370           if (energy_dec) write(iout,*)
4371      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4372         else
4373         diff = vbld(i)-vbldp0
4374         if (energy_dec) write (iout,*)
4375      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4376         estr=estr+diff*diff
4377         do j=1,3
4378           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4379         enddo
4380 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4381         endif
4382       enddo
4383       estr=0.5d0*AKP*estr+estr1
4384 c
4385 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4386 c
4387       do i=ibond_start,ibond_end
4388         iti=iabs(itype(i))
4389         if (iti.ne.10 .and. iti.ne.ntyp1) then
4390           nbi=nbondterm(iti)
4391           if (nbi.eq.1) then
4392             diff=vbld(i+nres)-vbldsc0(1,iti)
4393             if (energy_dec) write (iout,*)
4394      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4395      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4396             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4397             do j=1,3
4398               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4399             enddo
4400           else
4401             do j=1,nbi
4402               diff=vbld(i+nres)-vbldsc0(j,iti)
4403               ud(j)=aksc(j,iti)*diff
4404               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4405             enddo
4406             uprod=u(1)
4407             do j=2,nbi
4408               uprod=uprod*u(j)
4409             enddo
4410             usum=0.0d0
4411             usumsqder=0.0d0
4412             do j=1,nbi
4413               uprod1=1.0d0
4414               uprod2=1.0d0
4415               do k=1,nbi
4416                 if (k.ne.j) then
4417                   uprod1=uprod1*u(k)
4418                   uprod2=uprod2*u(k)*u(k)
4419                 endif
4420               enddo
4421               usum=usum+uprod1
4422               usumsqder=usumsqder+ud(j)*uprod2
4423             enddo
4424             estr=estr+uprod/usum
4425             do j=1,3
4426              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4427             enddo
4428           endif
4429         endif
4430       enddo
4431       return
4432       end
4433 #ifdef CRYST_THETA
4434 C--------------------------------------------------------------------------
4435       subroutine ebend(etheta)
4436 C
4437 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4438 C angles gamma and its derivatives in consecutive thetas and gammas.
4439 C
4440       implicit real*8 (a-h,o-z)
4441       include 'DIMENSIONS'
4442       include 'COMMON.LOCAL'
4443       include 'COMMON.GEO'
4444       include 'COMMON.INTERACT'
4445       include 'COMMON.DERIV'
4446       include 'COMMON.VAR'
4447       include 'COMMON.CHAIN'
4448       include 'COMMON.IOUNITS'
4449       include 'COMMON.NAMES'
4450       include 'COMMON.FFIELD'
4451       include 'COMMON.CONTROL'
4452       common /calcthet/ term1,term2,termm,diffak,ratak,
4453      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4454      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4455       double precision y(2),z(2)
4456       delta=0.02d0*pi
4457 c      time11=dexp(-2*time)
4458 c      time12=1.0d0
4459       etheta=0.0D0
4460 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4461       do i=ithet_start,ithet_end
4462         if (itype(i-1).eq.ntyp1) cycle
4463 C Zero the energy function and its derivative at 0 or pi.
4464         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4465         it=itype(i-1)
4466         ichir1=isign(1,itype(i-2))
4467         ichir2=isign(1,itype(i))
4468          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4469          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4470          if (itype(i-1).eq.10) then
4471           itype1=isign(10,itype(i-2))
4472           ichir11=isign(1,itype(i-2))
4473           ichir12=isign(1,itype(i-2))
4474           itype2=isign(10,itype(i))
4475           ichir21=isign(1,itype(i))
4476           ichir22=isign(1,itype(i))
4477          endif
4478
4479         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4480 #ifdef OSF
4481           phii=phi(i)
4482           if (phii.ne.phii) phii=150.0
4483 #else
4484           phii=phi(i)
4485 #endif
4486           y(1)=dcos(phii)
4487           y(2)=dsin(phii)
4488         else
4489           y(1)=0.0D0
4490           y(2)=0.0D0
4491         endif
4492         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4493 #ifdef OSF
4494           phii1=phi(i+1)
4495           if (phii1.ne.phii1) phii1=150.0
4496           phii1=pinorm(phii1)
4497           z(1)=cos(phii1)
4498 #else
4499           phii1=phi(i+1)
4500           z(1)=dcos(phii1)
4501 #endif
4502           z(2)=dsin(phii1)
4503         else
4504           z(1)=0.0D0
4505           z(2)=0.0D0
4506         endif
4507 C Calculate the "mean" value of theta from the part of the distribution
4508 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4509 C In following comments this theta will be referred to as t_c.
4510         thet_pred_mean=0.0d0
4511         do k=1,2
4512             athetk=athet(k,it,ichir1,ichir2)
4513             bthetk=bthet(k,it,ichir1,ichir2)
4514           if (it.eq.10) then
4515              athetk=athet(k,itype1,ichir11,ichir12)
4516              bthetk=bthet(k,itype2,ichir21,ichir22)
4517           endif
4518          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4519         enddo
4520         dthett=thet_pred_mean*ssd
4521         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4522 C Derivatives of the "mean" values in gamma1 and gamma2.
4523         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4524      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4525          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4526      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4527          if (it.eq.10) then
4528       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4529      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4530         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4531      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4532          endif
4533         if (theta(i).gt.pi-delta) then
4534           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4535      &         E_tc0)
4536           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4537           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4538           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4539      &        E_theta)
4540           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4541      &        E_tc)
4542         else if (theta(i).lt.delta) then
4543           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4544           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4545           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4546      &        E_theta)
4547           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4548           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4549      &        E_tc)
4550         else
4551           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4552      &        E_theta,E_tc)
4553         endif
4554         etheta=etheta+ethetai
4555         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4556      &      'ebend',i,ethetai
4557         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4558         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4559         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4560       enddo
4561 C Ufff.... We've done all this!!!
4562       return
4563       end
4564 C---------------------------------------------------------------------------
4565       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4566      &     E_tc)
4567       implicit real*8 (a-h,o-z)
4568       include 'DIMENSIONS'
4569       include 'COMMON.LOCAL'
4570       include 'COMMON.IOUNITS'
4571       common /calcthet/ term1,term2,termm,diffak,ratak,
4572      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4573      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4574 C Calculate the contributions to both Gaussian lobes.
4575 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4576 C The "polynomial part" of the "standard deviation" of this part of
4577 C the distribution.
4578         sig=polthet(3,it)
4579         do j=2,0,-1
4580           sig=sig*thet_pred_mean+polthet(j,it)
4581         enddo
4582 C Derivative of the "interior part" of the "standard deviation of the"
4583 C gamma-dependent Gaussian lobe in t_c.
4584         sigtc=3*polthet(3,it)
4585         do j=2,1,-1
4586           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4587         enddo
4588         sigtc=sig*sigtc
4589 C Set the parameters of both Gaussian lobes of the distribution.
4590 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4591         fac=sig*sig+sigc0(it)
4592         sigcsq=fac+fac
4593         sigc=1.0D0/sigcsq
4594 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4595         sigsqtc=-4.0D0*sigcsq*sigtc
4596 c       print *,i,sig,sigtc,sigsqtc
4597 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4598         sigtc=-sigtc/(fac*fac)
4599 C Following variable is sigma(t_c)**(-2)
4600         sigcsq=sigcsq*sigcsq
4601         sig0i=sig0(it)
4602         sig0inv=1.0D0/sig0i**2
4603         delthec=thetai-thet_pred_mean
4604         delthe0=thetai-theta0i
4605         term1=-0.5D0*sigcsq*delthec*delthec
4606         term2=-0.5D0*sig0inv*delthe0*delthe0
4607 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4608 C NaNs in taking the logarithm. We extract the largest exponent which is added
4609 C to the energy (this being the log of the distribution) at the end of energy
4610 C term evaluation for this virtual-bond angle.
4611         if (term1.gt.term2) then
4612           termm=term1
4613           term2=dexp(term2-termm)
4614           term1=1.0d0
4615         else
4616           termm=term2
4617           term1=dexp(term1-termm)
4618           term2=1.0d0
4619         endif
4620 C The ratio between the gamma-independent and gamma-dependent lobes of
4621 C the distribution is a Gaussian function of thet_pred_mean too.
4622         diffak=gthet(2,it)-thet_pred_mean
4623         ratak=diffak/gthet(3,it)**2
4624         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4625 C Let's differentiate it in thet_pred_mean NOW.
4626         aktc=ak*ratak
4627 C Now put together the distribution terms to make complete distribution.
4628         termexp=term1+ak*term2
4629         termpre=sigc+ak*sig0i
4630 C Contribution of the bending energy from this theta is just the -log of
4631 C the sum of the contributions from the two lobes and the pre-exponential
4632 C factor. Simple enough, isn't it?
4633         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4634 C NOW the derivatives!!!
4635 C 6/6/97 Take into account the deformation.
4636         E_theta=(delthec*sigcsq*term1
4637      &       +ak*delthe0*sig0inv*term2)/termexp
4638         E_tc=((sigtc+aktc*sig0i)/termpre
4639      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4640      &       aktc*term2)/termexp)
4641       return
4642       end
4643 c-----------------------------------------------------------------------------
4644       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4645       implicit real*8 (a-h,o-z)
4646       include 'DIMENSIONS'
4647       include 'COMMON.LOCAL'
4648       include 'COMMON.IOUNITS'
4649       common /calcthet/ term1,term2,termm,diffak,ratak,
4650      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4651      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4652       delthec=thetai-thet_pred_mean
4653       delthe0=thetai-theta0i
4654 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4655       t3 = thetai-thet_pred_mean
4656       t6 = t3**2
4657       t9 = term1
4658       t12 = t3*sigcsq
4659       t14 = t12+t6*sigsqtc
4660       t16 = 1.0d0
4661       t21 = thetai-theta0i
4662       t23 = t21**2
4663       t26 = term2
4664       t27 = t21*t26
4665       t32 = termexp
4666       t40 = t32**2
4667       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4668      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4669      & *(-t12*t9-ak*sig0inv*t27)
4670       return
4671       end
4672 #else
4673 C--------------------------------------------------------------------------
4674       subroutine ebend(etheta)
4675 C
4676 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4677 C angles gamma and its derivatives in consecutive thetas and gammas.
4678 C ab initio-derived potentials from
4679 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4680 C
4681       implicit real*8 (a-h,o-z)
4682       include 'DIMENSIONS'
4683       include 'COMMON.LOCAL'
4684       include 'COMMON.GEO'
4685       include 'COMMON.INTERACT'
4686       include 'COMMON.DERIV'
4687       include 'COMMON.VAR'
4688       include 'COMMON.CHAIN'
4689       include 'COMMON.IOUNITS'
4690       include 'COMMON.NAMES'
4691       include 'COMMON.FFIELD'
4692       include 'COMMON.CONTROL'
4693       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4694      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4695      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4696      & sinph1ph2(maxdouble,maxdouble)
4697       logical lprn /.false./, lprn1 /.false./
4698       etheta=0.0D0
4699       do i=ithet_start,ithet_end
4700         if (itype(i-1).eq.ntyp1) cycle
4701         if (iabs(itype(i+1)).eq.20) iblock=2
4702         if (iabs(itype(i+1)).ne.20) iblock=1
4703         dethetai=0.0d0
4704         dephii=0.0d0
4705         dephii1=0.0d0
4706         theti2=0.5d0*theta(i)
4707         ityp2=ithetyp((itype(i-1)))
4708         do k=1,nntheterm
4709           coskt(k)=dcos(k*theti2)
4710           sinkt(k)=dsin(k*theti2)
4711         enddo
4712         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4713 #ifdef OSF
4714           phii=phi(i)
4715           if (phii.ne.phii) phii=150.0
4716 #else
4717           phii=phi(i)
4718 #endif
4719           ityp1=ithetyp((itype(i-2)))
4720 C propagation of chirality for glycine type
4721           do k=1,nsingle
4722             cosph1(k)=dcos(k*phii)
4723             sinph1(k)=dsin(k*phii)
4724           enddo
4725         else
4726           phii=0.0d0
4727           ityp1=nthetyp+1
4728           do k=1,nsingle
4729             cosph1(k)=0.0d0
4730             sinph1(k)=0.0d0
4731           enddo
4732         endif
4733         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4734 #ifdef OSF
4735           phii1=phi(i+1)
4736           if (phii1.ne.phii1) phii1=150.0
4737           phii1=pinorm(phii1)
4738 #else
4739           phii1=phi(i+1)
4740 #endif
4741           ityp3=ithetyp((itype(i)))
4742           do k=1,nsingle
4743             cosph2(k)=dcos(k*phii1)
4744             sinph2(k)=dsin(k*phii1)
4745           enddo
4746         else
4747           phii1=0.0d0
4748           ityp3=nthetyp+1
4749           do k=1,nsingle
4750             cosph2(k)=0.0d0
4751             sinph2(k)=0.0d0
4752           enddo
4753         endif
4754         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4755         do k=1,ndouble
4756           do l=1,k-1
4757             ccl=cosph1(l)*cosph2(k-l)
4758             ssl=sinph1(l)*sinph2(k-l)
4759             scl=sinph1(l)*cosph2(k-l)
4760             csl=cosph1(l)*sinph2(k-l)
4761             cosph1ph2(l,k)=ccl-ssl
4762             cosph1ph2(k,l)=ccl+ssl
4763             sinph1ph2(l,k)=scl+csl
4764             sinph1ph2(k,l)=scl-csl
4765           enddo
4766         enddo
4767         if (lprn) then
4768         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4769      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4770         write (iout,*) "coskt and sinkt"
4771         do k=1,nntheterm
4772           write (iout,*) k,coskt(k),sinkt(k)
4773         enddo
4774         endif
4775         do k=1,ntheterm
4776           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4777           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4778      &      *coskt(k)
4779           if (lprn)
4780      &    write (iout,*) "k",k,"
4781      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4782      &     " ethetai",ethetai
4783         enddo
4784         if (lprn) then
4785         write (iout,*) "cosph and sinph"
4786         do k=1,nsingle
4787           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4788         enddo
4789         write (iout,*) "cosph1ph2 and sinph2ph2"
4790         do k=2,ndouble
4791           do l=1,k-1
4792             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4793      &         sinph1ph2(l,k),sinph1ph2(k,l)
4794           enddo
4795         enddo
4796         write(iout,*) "ethetai",ethetai
4797         endif
4798         do m=1,ntheterm2
4799           do k=1,nsingle
4800             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4801      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4802      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4803      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4804             ethetai=ethetai+sinkt(m)*aux
4805             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4806             dephii=dephii+k*sinkt(m)*(
4807      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4808      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4809             dephii1=dephii1+k*sinkt(m)*(
4810      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4811      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4812             if (lprn)
4813      &      write (iout,*) "m",m," k",k," bbthet",
4814      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4815      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4816      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4817      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4818           enddo
4819         enddo
4820         if (lprn)
4821      &  write(iout,*) "ethetai",ethetai
4822         do m=1,ntheterm3
4823           do k=2,ndouble
4824             do l=1,k-1
4825               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4826      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4827      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4828      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4829               ethetai=ethetai+sinkt(m)*aux
4830               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4831               dephii=dephii+l*sinkt(m)*(
4832      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4833      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4834      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4835      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4836               dephii1=dephii1+(k-l)*sinkt(m)*(
4837      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4838      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4839      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4840      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4841               if (lprn) then
4842               write (iout,*) "m",m," k",k," l",l," ffthet",
4843      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4844      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4845      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4846      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4847      &            " ethetai",ethetai
4848               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4849      &            cosph1ph2(k,l)*sinkt(m),
4850      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4851               endif
4852             enddo
4853           enddo
4854         enddo
4855 10      continue
4856 c        lprn1=.true.
4857         if (lprn1)
4858      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4859      &   i,theta(i)*rad2deg,phii*rad2deg,
4860      &   phii1*rad2deg,ethetai
4861 c        lprn1=.false.
4862         etheta=etheta+ethetai
4863         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4864         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4865         gloc(nphi+i-2,icg)=wang*dethetai
4866       enddo
4867       return
4868       end
4869 #endif
4870 #ifdef CRYST_SC
4871 c-----------------------------------------------------------------------------
4872       subroutine esc(escloc)
4873 C Calculate the local energy of a side chain and its derivatives in the
4874 C corresponding virtual-bond valence angles THETA and the spherical angles
4875 C ALPHA and OMEGA.
4876       implicit real*8 (a-h,o-z)
4877       include 'DIMENSIONS'
4878       include 'COMMON.GEO'
4879       include 'COMMON.LOCAL'
4880       include 'COMMON.VAR'
4881       include 'COMMON.INTERACT'
4882       include 'COMMON.DERIV'
4883       include 'COMMON.CHAIN'
4884       include 'COMMON.IOUNITS'
4885       include 'COMMON.NAMES'
4886       include 'COMMON.FFIELD'
4887       include 'COMMON.CONTROL'
4888       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4889      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4890       common /sccalc/ time11,time12,time112,theti,it,nlobit
4891       delta=0.02d0*pi
4892       escloc=0.0D0
4893 c     write (iout,'(a)') 'ESC'
4894       do i=loc_start,loc_end
4895         it=itype(i)
4896         if (it.eq.ntyp1) cycle
4897         if (it.eq.10) goto 1
4898         nlobit=nlob(iabs(it))
4899 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4900 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4901         theti=theta(i+1)-pipol
4902         x(1)=dtan(theti)
4903         x(2)=alph(i)
4904         x(3)=omeg(i)
4905
4906         if (x(2).gt.pi-delta) then
4907           xtemp(1)=x(1)
4908           xtemp(2)=pi-delta
4909           xtemp(3)=x(3)
4910           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4911           xtemp(2)=pi
4912           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4913           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4914      &        escloci,dersc(2))
4915           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4916      &        ddersc0(1),dersc(1))
4917           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4918      &        ddersc0(3),dersc(3))
4919           xtemp(2)=pi-delta
4920           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4921           xtemp(2)=pi
4922           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4923           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4924      &            dersc0(2),esclocbi,dersc02)
4925           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4926      &            dersc12,dersc01)
4927           call splinthet(x(2),0.5d0*delta,ss,ssd)
4928           dersc0(1)=dersc01
4929           dersc0(2)=dersc02
4930           dersc0(3)=0.0d0
4931           do k=1,3
4932             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4933           enddo
4934           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4935 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4936 c    &             esclocbi,ss,ssd
4937           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4938 c         escloci=esclocbi
4939 c         write (iout,*) escloci
4940         else if (x(2).lt.delta) then
4941           xtemp(1)=x(1)
4942           xtemp(2)=delta
4943           xtemp(3)=x(3)
4944           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4945           xtemp(2)=0.0d0
4946           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4947           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4948      &        escloci,dersc(2))
4949           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4950      &        ddersc0(1),dersc(1))
4951           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4952      &        ddersc0(3),dersc(3))
4953           xtemp(2)=delta
4954           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4955           xtemp(2)=0.0d0
4956           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4957           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4958      &            dersc0(2),esclocbi,dersc02)
4959           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4960      &            dersc12,dersc01)
4961           dersc0(1)=dersc01
4962           dersc0(2)=dersc02
4963           dersc0(3)=0.0d0
4964           call splinthet(x(2),0.5d0*delta,ss,ssd)
4965           do k=1,3
4966             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4967           enddo
4968           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4969 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4970 c    &             esclocbi,ss,ssd
4971           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4972 c         write (iout,*) escloci
4973         else
4974           call enesc(x,escloci,dersc,ddummy,.false.)
4975         endif
4976
4977         escloc=escloc+escloci
4978         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4979      &     'escloc',i,escloci
4980 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4981
4982         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4983      &   wscloc*dersc(1)
4984         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4985         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4986     1   continue
4987       enddo
4988       return
4989       end
4990 C---------------------------------------------------------------------------
4991       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4992       implicit real*8 (a-h,o-z)
4993       include 'DIMENSIONS'
4994       include 'COMMON.GEO'
4995       include 'COMMON.LOCAL'
4996       include 'COMMON.IOUNITS'
4997       common /sccalc/ time11,time12,time112,theti,it,nlobit
4998       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4999       double precision contr(maxlob,-1:1)
5000       logical mixed
5001 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5002         escloc_i=0.0D0
5003         do j=1,3
5004           dersc(j)=0.0D0
5005           if (mixed) ddersc(j)=0.0d0
5006         enddo
5007         x3=x(3)
5008
5009 C Because of periodicity of the dependence of the SC energy in omega we have
5010 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5011 C To avoid underflows, first compute & store the exponents.
5012
5013         do iii=-1,1
5014
5015           x(3)=x3+iii*dwapi
5016
5017           do j=1,nlobit
5018             do k=1,3
5019               z(k)=x(k)-censc(k,j,it)
5020             enddo
5021             do k=1,3
5022               Axk=0.0D0
5023               do l=1,3
5024                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5025               enddo
5026               Ax(k,j,iii)=Axk
5027             enddo
5028             expfac=0.0D0
5029             do k=1,3
5030               expfac=expfac+Ax(k,j,iii)*z(k)
5031             enddo
5032             contr(j,iii)=expfac
5033           enddo ! j
5034
5035         enddo ! iii
5036
5037         x(3)=x3
5038 C As in the case of ebend, we want to avoid underflows in exponentiation and
5039 C subsequent NaNs and INFs in energy calculation.
5040 C Find the largest exponent
5041         emin=contr(1,-1)
5042         do iii=-1,1
5043           do j=1,nlobit
5044             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5045           enddo
5046         enddo
5047         emin=0.5D0*emin
5048 cd      print *,'it=',it,' emin=',emin
5049
5050 C Compute the contribution to SC energy and derivatives
5051         do iii=-1,1
5052
5053           do j=1,nlobit
5054 #ifdef OSF
5055             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5056             if(adexp.ne.adexp) adexp=1.0
5057             expfac=dexp(adexp)
5058 #else
5059             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5060 #endif
5061 cd          print *,'j=',j,' expfac=',expfac
5062             escloc_i=escloc_i+expfac
5063             do k=1,3
5064               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5065             enddo
5066             if (mixed) then
5067               do k=1,3,2
5068                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5069      &            +gaussc(k,2,j,it))*expfac
5070               enddo
5071             endif
5072           enddo
5073
5074         enddo ! iii
5075
5076         dersc(1)=dersc(1)/cos(theti)**2
5077         ddersc(1)=ddersc(1)/cos(theti)**2
5078         ddersc(3)=ddersc(3)
5079
5080         escloci=-(dlog(escloc_i)-emin)
5081         do j=1,3
5082           dersc(j)=dersc(j)/escloc_i
5083         enddo
5084         if (mixed) then
5085           do j=1,3,2
5086             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5087           enddo
5088         endif
5089       return
5090       end
5091 C------------------------------------------------------------------------------
5092       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5093       implicit real*8 (a-h,o-z)
5094       include 'DIMENSIONS'
5095       include 'COMMON.GEO'
5096       include 'COMMON.LOCAL'
5097       include 'COMMON.IOUNITS'
5098       common /sccalc/ time11,time12,time112,theti,it,nlobit
5099       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5100       double precision contr(maxlob)
5101       logical mixed
5102
5103       escloc_i=0.0D0
5104
5105       do j=1,3
5106         dersc(j)=0.0D0
5107       enddo
5108
5109       do j=1,nlobit
5110         do k=1,2
5111           z(k)=x(k)-censc(k,j,it)
5112         enddo
5113         z(3)=dwapi
5114         do k=1,3
5115           Axk=0.0D0
5116           do l=1,3
5117             Axk=Axk+gaussc(l,k,j,it)*z(l)
5118           enddo
5119           Ax(k,j)=Axk
5120         enddo
5121         expfac=0.0D0
5122         do k=1,3
5123           expfac=expfac+Ax(k,j)*z(k)
5124         enddo
5125         contr(j)=expfac
5126       enddo ! j
5127
5128 C As in the case of ebend, we want to avoid underflows in exponentiation and
5129 C subsequent NaNs and INFs in energy calculation.
5130 C Find the largest exponent
5131       emin=contr(1)
5132       do j=1,nlobit
5133         if (emin.gt.contr(j)) emin=contr(j)
5134       enddo
5135       emin=0.5D0*emin
5136
5137 C Compute the contribution to SC energy and derivatives
5138
5139       dersc12=0.0d0
5140       do j=1,nlobit
5141         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5142         escloc_i=escloc_i+expfac
5143         do k=1,2
5144           dersc(k)=dersc(k)+Ax(k,j)*expfac
5145         enddo
5146         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5147      &            +gaussc(1,2,j,it))*expfac
5148         dersc(3)=0.0d0
5149       enddo
5150
5151       dersc(1)=dersc(1)/cos(theti)**2
5152       dersc12=dersc12/cos(theti)**2
5153       escloci=-(dlog(escloc_i)-emin)
5154       do j=1,2
5155         dersc(j)=dersc(j)/escloc_i
5156       enddo
5157       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5158       return
5159       end
5160 #else
5161 c----------------------------------------------------------------------------------
5162       subroutine esc(escloc)
5163 C Calculate the local energy of a side chain and its derivatives in the
5164 C corresponding virtual-bond valence angles THETA and the spherical angles
5165 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5166 C added by Urszula Kozlowska. 07/11/2007
5167 C
5168       implicit real*8 (a-h,o-z)
5169       include 'DIMENSIONS'
5170       include 'COMMON.GEO'
5171       include 'COMMON.LOCAL'
5172       include 'COMMON.VAR'
5173       include 'COMMON.SCROT'
5174       include 'COMMON.INTERACT'
5175       include 'COMMON.DERIV'
5176       include 'COMMON.CHAIN'
5177       include 'COMMON.IOUNITS'
5178       include 'COMMON.NAMES'
5179       include 'COMMON.FFIELD'
5180       include 'COMMON.CONTROL'
5181       include 'COMMON.VECTORS'
5182       double precision x_prime(3),y_prime(3),z_prime(3)
5183      &    , sumene,dsc_i,dp2_i,x(65),
5184      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5185      &    de_dxx,de_dyy,de_dzz,de_dt
5186       double precision s1_t,s1_6_t,s2_t,s2_6_t
5187       double precision
5188      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5189      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5190      & dt_dCi(3),dt_dCi1(3)
5191       common /sccalc/ time11,time12,time112,theti,it,nlobit
5192       delta=0.02d0*pi
5193       escloc=0.0D0
5194       do i=loc_start,loc_end
5195         if (itype(i).eq.ntyp1) cycle
5196         costtab(i+1) =dcos(theta(i+1))
5197         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5198         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5199         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5200         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5201         cosfac=dsqrt(cosfac2)
5202         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5203         sinfac=dsqrt(sinfac2)
5204         it=iabs(itype(i))
5205         if (it.eq.10) goto 1
5206 c
5207 C  Compute the axes of tghe local cartesian coordinates system; store in
5208 c   x_prime, y_prime and z_prime
5209 c
5210         do j=1,3
5211           x_prime(j) = 0.00
5212           y_prime(j) = 0.00
5213           z_prime(j) = 0.00
5214         enddo
5215 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5216 C     &   dc_norm(3,i+nres)
5217         do j = 1,3
5218           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5219           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5220         enddo
5221         do j = 1,3
5222           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5223         enddo
5224 c       write (2,*) "i",i
5225 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5226 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5227 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5228 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5229 c      & " xy",scalar(x_prime(1),y_prime(1)),
5230 c      & " xz",scalar(x_prime(1),z_prime(1)),
5231 c      & " yy",scalar(y_prime(1),y_prime(1)),
5232 c      & " yz",scalar(y_prime(1),z_prime(1)),
5233 c      & " zz",scalar(z_prime(1),z_prime(1))
5234 c
5235 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5236 C to local coordinate system. Store in xx, yy, zz.
5237 c
5238         xx=0.0d0
5239         yy=0.0d0
5240         zz=0.0d0
5241         do j = 1,3
5242           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5243           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5244           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5245         enddo
5246
5247         xxtab(i)=xx
5248         yytab(i)=yy
5249         zztab(i)=zz
5250 C
5251 C Compute the energy of the ith side cbain
5252 C
5253 c        write (2,*) "xx",xx," yy",yy," zz",zz
5254         it=iabs(itype(i))
5255         do j = 1,65
5256           x(j) = sc_parmin(j,it)
5257         enddo
5258 #ifdef CHECK_COORD
5259 Cc diagnostics - remove later
5260         xx1 = dcos(alph(2))
5261         yy1 = dsin(alph(2))*dcos(omeg(2))
5262         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5263         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5264      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5265      &    xx1,yy1,zz1
5266 C,"  --- ", xx_w,yy_w,zz_w
5267 c end diagnostics
5268 #endif
5269         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5270      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5271      &   + x(10)*yy*zz
5272         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5273      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5274      & + x(20)*yy*zz
5275         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5276      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5277      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5278      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5279      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5280      &  +x(40)*xx*yy*zz
5281         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5282      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5283      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5284      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5285      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5286      &  +x(60)*xx*yy*zz
5287         dsc_i   = 0.743d0+x(61)
5288         dp2_i   = 1.9d0+x(62)
5289         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5290      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5291         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5292      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5293         s1=(1+x(63))/(0.1d0 + dscp1)
5294         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5295         s2=(1+x(65))/(0.1d0 + dscp2)
5296         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5297         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5298      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5299 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5300 c     &   sumene4,
5301 c     &   dscp1,dscp2,sumene
5302 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5303         escloc = escloc + sumene
5304 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5305 c     & ,zz,xx,yy
5306 c#define DEBUG
5307 #ifdef DEBUG
5308 C
5309 C This section to check the numerical derivatives of the energy of ith side
5310 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5311 C #define DEBUG in the code to turn it on.
5312 C
5313         write (2,*) "sumene               =",sumene
5314         aincr=1.0d-7
5315         xxsave=xx
5316         xx=xx+aincr
5317         write (2,*) xx,yy,zz
5318         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5319         de_dxx_num=(sumenep-sumene)/aincr
5320         xx=xxsave
5321         write (2,*) "xx+ sumene from enesc=",sumenep
5322         yysave=yy
5323         yy=yy+aincr
5324         write (2,*) xx,yy,zz
5325         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5326         de_dyy_num=(sumenep-sumene)/aincr
5327         yy=yysave
5328         write (2,*) "yy+ sumene from enesc=",sumenep
5329         zzsave=zz
5330         zz=zz+aincr
5331         write (2,*) xx,yy,zz
5332         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5333         de_dzz_num=(sumenep-sumene)/aincr
5334         zz=zzsave
5335         write (2,*) "zz+ sumene from enesc=",sumenep
5336         costsave=cost2tab(i+1)
5337         sintsave=sint2tab(i+1)
5338         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5339         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5340         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5341         de_dt_num=(sumenep-sumene)/aincr
5342         write (2,*) " t+ sumene from enesc=",sumenep
5343         cost2tab(i+1)=costsave
5344         sint2tab(i+1)=sintsave
5345 C End of diagnostics section.
5346 #endif
5347 C
5348 C Compute the gradient of esc
5349 C
5350 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5351         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5352         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5353         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5354         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5355         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5356         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5357         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5358         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5359         pom1=(sumene3*sint2tab(i+1)+sumene1)
5360      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5361         pom2=(sumene4*cost2tab(i+1)+sumene2)
5362      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5363         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5364         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5365      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5366      &  +x(40)*yy*zz
5367         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5368         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5369      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5370      &  +x(60)*yy*zz
5371         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5372      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5373      &        +(pom1+pom2)*pom_dx
5374 #ifdef DEBUG
5375         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5376 #endif
5377 C
5378         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5379         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5380      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5381      &  +x(40)*xx*zz
5382         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5383         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5384      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5385      &  +x(59)*zz**2 +x(60)*xx*zz
5386         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5387      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5388      &        +(pom1-pom2)*pom_dy
5389 #ifdef DEBUG
5390         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5391 #endif
5392 C
5393         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5394      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5395      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5396      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5397      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5398      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5399      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5400      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5401 #ifdef DEBUG
5402         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5403 #endif
5404 C
5405         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5406      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5407      &  +pom1*pom_dt1+pom2*pom_dt2
5408 #ifdef DEBUG
5409         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5410 #endif
5411 c#undef DEBUG
5412 c
5413 C
5414        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5415        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5416        cosfac2xx=cosfac2*xx
5417        sinfac2yy=sinfac2*yy
5418        do k = 1,3
5419          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5420      &      vbld_inv(i+1)
5421          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5422      &      vbld_inv(i)
5423          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5424          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5425 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5426 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5427 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5428 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5429          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5430          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5431          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5432          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5433          dZZ_Ci1(k)=0.0d0
5434          dZZ_Ci(k)=0.0d0
5435          do j=1,3
5436            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5437      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5438            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5439      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5440          enddo
5441
5442          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5443          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5444          dZZ_XYZ(k)=vbld_inv(i+nres)*
5445      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5446 c
5447          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5448          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5449        enddo
5450
5451        do k=1,3
5452          dXX_Ctab(k,i)=dXX_Ci(k)
5453          dXX_C1tab(k,i)=dXX_Ci1(k)
5454          dYY_Ctab(k,i)=dYY_Ci(k)
5455          dYY_C1tab(k,i)=dYY_Ci1(k)
5456          dZZ_Ctab(k,i)=dZZ_Ci(k)
5457          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5458          dXX_XYZtab(k,i)=dXX_XYZ(k)
5459          dYY_XYZtab(k,i)=dYY_XYZ(k)
5460          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5461        enddo
5462
5463        do k = 1,3
5464 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5465 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5466 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5467 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5468 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5469 c     &    dt_dci(k)
5470 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5471 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5472          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5473      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5474          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5475      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5476          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5477      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5478        enddo
5479 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5480 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5481
5482 C to check gradient call subroutine check_grad
5483
5484     1 continue
5485       enddo
5486       return
5487       end
5488 c------------------------------------------------------------------------------
5489       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5490       implicit none
5491       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5492      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5493       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5494      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5495      &   + x(10)*yy*zz
5496       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5497      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5498      & + x(20)*yy*zz
5499       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5500      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5501      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5502      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5503      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5504      &  +x(40)*xx*yy*zz
5505       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5506      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5507      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5508      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5509      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5510      &  +x(60)*xx*yy*zz
5511       dsc_i   = 0.743d0+x(61)
5512       dp2_i   = 1.9d0+x(62)
5513       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5514      &          *(xx*cost2+yy*sint2))
5515       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5516      &          *(xx*cost2-yy*sint2))
5517       s1=(1+x(63))/(0.1d0 + dscp1)
5518       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5519       s2=(1+x(65))/(0.1d0 + dscp2)
5520       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5521       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5522      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5523       enesc=sumene
5524       return
5525       end
5526 #endif
5527 c------------------------------------------------------------------------------
5528       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5529 C
5530 C This procedure calculates two-body contact function g(rij) and its derivative:
5531 C
5532 C           eps0ij                                     !       x < -1
5533 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5534 C            0                                         !       x > 1
5535 C
5536 C where x=(rij-r0ij)/delta
5537 C
5538 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5539 C
5540       implicit none
5541       double precision rij,r0ij,eps0ij,fcont,fprimcont
5542       double precision x,x2,x4,delta
5543 c     delta=0.02D0*r0ij
5544 c      delta=0.2D0*r0ij
5545       x=(rij-r0ij)/delta
5546       if (x.lt.-1.0D0) then
5547         fcont=eps0ij
5548         fprimcont=0.0D0
5549       else if (x.le.1.0D0) then
5550         x2=x*x
5551         x4=x2*x2
5552         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5553         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5554       else
5555         fcont=0.0D0
5556         fprimcont=0.0D0
5557       endif
5558       return
5559       end
5560 c------------------------------------------------------------------------------
5561       subroutine splinthet(theti,delta,ss,ssder)
5562       implicit real*8 (a-h,o-z)
5563       include 'DIMENSIONS'
5564       include 'COMMON.VAR'
5565       include 'COMMON.GEO'
5566       thetup=pi-delta
5567       thetlow=delta
5568       if (theti.gt.pipol) then
5569         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5570       else
5571         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5572         ssder=-ssder
5573       endif
5574       return
5575       end
5576 c------------------------------------------------------------------------------
5577       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5578       implicit none
5579       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5580       double precision ksi,ksi2,ksi3,a1,a2,a3
5581       a1=fprim0*delta/(f1-f0)
5582       a2=3.0d0-2.0d0*a1
5583       a3=a1-2.0d0
5584       ksi=(x-x0)/delta
5585       ksi2=ksi*ksi
5586       ksi3=ksi2*ksi
5587       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5588       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5589       return
5590       end
5591 c------------------------------------------------------------------------------
5592       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5593       implicit none
5594       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5595       double precision ksi,ksi2,ksi3,a1,a2,a3
5596       ksi=(x-x0)/delta
5597       ksi2=ksi*ksi
5598       ksi3=ksi2*ksi
5599       a1=fprim0x*delta
5600       a2=3*(f1x-f0x)-2*fprim0x*delta
5601       a3=fprim0x*delta-2*(f1x-f0x)
5602       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5603       return
5604       end
5605 C-----------------------------------------------------------------------------
5606 #ifdef CRYST_TOR
5607 C-----------------------------------------------------------------------------
5608       subroutine etor(etors,edihcnstr)
5609       implicit real*8 (a-h,o-z)
5610       include 'DIMENSIONS'
5611       include 'COMMON.VAR'
5612       include 'COMMON.GEO'
5613       include 'COMMON.LOCAL'
5614       include 'COMMON.TORSION'
5615       include 'COMMON.INTERACT'
5616       include 'COMMON.DERIV'
5617       include 'COMMON.CHAIN'
5618       include 'COMMON.NAMES'
5619       include 'COMMON.IOUNITS'
5620       include 'COMMON.FFIELD'
5621       include 'COMMON.TORCNSTR'
5622       include 'COMMON.CONTROL'
5623       logical lprn
5624 C Set lprn=.true. for debugging
5625       lprn=.false.
5626 c      lprn=.true.
5627       etors=0.0D0
5628       do i=iphi_start,iphi_end
5629       etors_ii=0.0D0
5630         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5631      &      .or. itype(i).eq.ntyp1) cycle
5632         itori=itortyp(itype(i-2))
5633         itori1=itortyp(itype(i-1))
5634         phii=phi(i)
5635         gloci=0.0D0
5636 C Proline-Proline pair is a special case...
5637         if (itori.eq.3 .and. itori1.eq.3) then
5638           if (phii.gt.-dwapi3) then
5639             cosphi=dcos(3*phii)
5640             fac=1.0D0/(1.0D0-cosphi)
5641             etorsi=v1(1,3,3)*fac
5642             etorsi=etorsi+etorsi
5643             etors=etors+etorsi-v1(1,3,3)
5644             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5645             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5646           endif
5647           do j=1,3
5648             v1ij=v1(j+1,itori,itori1)
5649             v2ij=v2(j+1,itori,itori1)
5650             cosphi=dcos(j*phii)
5651             sinphi=dsin(j*phii)
5652             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5653             if (energy_dec) etors_ii=etors_ii+
5654      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5655             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5656           enddo
5657         else
5658           do j=1,nterm_old
5659             v1ij=v1(j,itori,itori1)
5660             v2ij=v2(j,itori,itori1)
5661             cosphi=dcos(j*phii)
5662             sinphi=dsin(j*phii)
5663             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5664             if (energy_dec) etors_ii=etors_ii+
5665      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5666             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5667           enddo
5668         endif
5669         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5670              'etor',i,etors_ii
5671         if (lprn)
5672      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5673      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5674      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5675         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5676 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5677       enddo
5678 ! 6/20/98 - dihedral angle constraints
5679       edihcnstr=0.0d0
5680       do i=1,ndih_constr
5681         itori=idih_constr(i)
5682         phii=phi(itori)
5683         difi=phii-phi0(i)
5684         if (difi.gt.drange(i)) then
5685           difi=difi-drange(i)
5686           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5687           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5688         else if (difi.lt.-drange(i)) then
5689           difi=difi+drange(i)
5690           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5691           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5692         endif
5693 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5694 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5695       enddo
5696 !      write (iout,*) 'edihcnstr',edihcnstr
5697       return
5698       end
5699 c------------------------------------------------------------------------------
5700       subroutine etor_d(etors_d)
5701       etors_d=0.0d0
5702       return
5703       end
5704 c----------------------------------------------------------------------------
5705 #else
5706       subroutine etor(etors,edihcnstr)
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.INTERACT'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.CHAIN'
5716       include 'COMMON.NAMES'
5717       include 'COMMON.IOUNITS'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.TORCNSTR'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c     lprn=.true.
5725       etors=0.0D0
5726       do i=iphi_start,iphi_end
5727         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5728      &       .or. itype(i).eq.ntyp1) cycle
5729         etors_ii=0.0D0
5730          if (iabs(itype(i)).eq.20) then
5731          iblock=2
5732          else
5733          iblock=1
5734          endif
5735         itori=itortyp(itype(i-2))
5736         itori1=itortyp(itype(i-1))
5737         phii=phi(i)
5738         gloci=0.0D0
5739 C Regular cosine and sine terms
5740         do j=1,nterm(itori,itori1,iblock)
5741           v1ij=v1(j,itori,itori1,iblock)
5742           v2ij=v2(j,itori,itori1,iblock)
5743           cosphi=dcos(j*phii)
5744           sinphi=dsin(j*phii)
5745           etors=etors+v1ij*cosphi+v2ij*sinphi
5746           if (energy_dec) etors_ii=etors_ii+
5747      &                v1ij*cosphi+v2ij*sinphi
5748           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5749         enddo
5750 C Lorentz terms
5751 C                         v1
5752 C  E = SUM ----------------------------------- - v1
5753 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5754 C
5755         cosphi=dcos(0.5d0*phii)
5756         sinphi=dsin(0.5d0*phii)
5757         do j=1,nlor(itori,itori1,iblock)
5758           vl1ij=vlor1(j,itori,itori1)
5759           vl2ij=vlor2(j,itori,itori1)
5760           vl3ij=vlor3(j,itori,itori1)
5761           pom=vl2ij*cosphi+vl3ij*sinphi
5762           pom1=1.0d0/(pom*pom+1.0d0)
5763           etors=etors+vl1ij*pom1
5764           if (energy_dec) etors_ii=etors_ii+
5765      &                vl1ij*pom1
5766           pom=-pom*pom1*pom1
5767           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5768         enddo
5769 C Subtract the constant term
5770         etors=etors-v0(itori,itori1,iblock)
5771           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5772      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5773         if (lprn)
5774      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5775      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5776      &  (v1(j,itori,itori1,iblock),j=1,6),
5777      &  (v2(j,itori,itori1,iblock),j=1,6)
5778         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5779 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5780       enddo
5781 ! 6/20/98 - dihedral angle constraints
5782       edihcnstr=0.0d0
5783 c      do i=1,ndih_constr
5784       do i=idihconstr_start,idihconstr_end
5785         itori=idih_constr(i)
5786         phii=phi(itori)
5787         difi=pinorm(phii-phi0(i))
5788         if (difi.gt.drange(i)) then
5789           difi=difi-drange(i)
5790           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5791           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5792         else if (difi.lt.-drange(i)) then
5793           difi=difi+drange(i)
5794           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5795           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5796         else
5797           difi=0.0
5798         endif
5799 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5800 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5801 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5802       enddo
5803 cd       write (iout,*) 'edihcnstr',edihcnstr
5804       return
5805       end
5806 c----------------------------------------------------------------------------
5807       subroutine etor_d(etors_d)
5808 C 6/23/01 Compute double torsional energy
5809       implicit real*8 (a-h,o-z)
5810       include 'DIMENSIONS'
5811       include 'COMMON.VAR'
5812       include 'COMMON.GEO'
5813       include 'COMMON.LOCAL'
5814       include 'COMMON.TORSION'
5815       include 'COMMON.INTERACT'
5816       include 'COMMON.DERIV'
5817       include 'COMMON.CHAIN'
5818       include 'COMMON.NAMES'
5819       include 'COMMON.IOUNITS'
5820       include 'COMMON.FFIELD'
5821       include 'COMMON.TORCNSTR'
5822       logical lprn
5823 C Set lprn=.true. for debugging
5824       lprn=.false.
5825 c     lprn=.true.
5826       etors_d=0.0D0
5827 c      write(iout,*) "a tu??"
5828       do i=iphid_start,iphid_end
5829         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5830      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5831         itori=itortyp(itype(i-2))
5832         itori1=itortyp(itype(i-1))
5833         itori2=itortyp(itype(i))
5834         phii=phi(i)
5835         phii1=phi(i+1)
5836         gloci1=0.0D0
5837         gloci2=0.0D0
5838         iblock=1
5839         if (iabs(itype(i+1)).eq.20) iblock=2
5840
5841 C Regular cosine and sine terms
5842         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5843           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5844           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5845           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5846           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5847           cosphi1=dcos(j*phii)
5848           sinphi1=dsin(j*phii)
5849           cosphi2=dcos(j*phii1)
5850           sinphi2=dsin(j*phii1)
5851           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5852      &     v2cij*cosphi2+v2sij*sinphi2
5853           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5854           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5855         enddo
5856         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5857           do l=1,k-1
5858             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5859             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5860             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5861             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5862             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5863             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5864             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5865             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5866             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5867      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5868             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5869      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5870             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5871      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5872           enddo
5873         enddo
5874         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5875         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5876       enddo
5877       return
5878       end
5879 #endif
5880 c------------------------------------------------------------------------------
5881       subroutine eback_sc_corr(esccor)
5882 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5883 c        conformational states; temporarily implemented as differences
5884 c        between UNRES torsional potentials (dependent on three types of
5885 c        residues) and the torsional potentials dependent on all 20 types
5886 c        of residues computed from AM1  energy surfaces of terminally-blocked
5887 c        amino-acid residues.
5888       implicit real*8 (a-h,o-z)
5889       include 'DIMENSIONS'
5890       include 'COMMON.VAR'
5891       include 'COMMON.GEO'
5892       include 'COMMON.LOCAL'
5893       include 'COMMON.TORSION'
5894       include 'COMMON.SCCOR'
5895       include 'COMMON.INTERACT'
5896       include 'COMMON.DERIV'
5897       include 'COMMON.CHAIN'
5898       include 'COMMON.NAMES'
5899       include 'COMMON.IOUNITS'
5900       include 'COMMON.FFIELD'
5901       include 'COMMON.CONTROL'
5902       logical lprn
5903 C Set lprn=.true. for debugging
5904       lprn=.false.
5905 c      lprn=.true.
5906 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5907       esccor=0.0D0
5908       do i=itau_start,itau_end
5909         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5910         esccor_ii=0.0D0
5911         isccori=isccortyp(itype(i-2))
5912         isccori1=isccortyp(itype(i-1))
5913 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5914         phii=phi(i)
5915         do intertyp=1,3 !intertyp
5916 cc Added 09 May 2012 (Adasko)
5917 cc  Intertyp means interaction type of backbone mainchain correlation:
5918 c   1 = SC...Ca...Ca...Ca
5919 c   2 = Ca...Ca...Ca...SC
5920 c   3 = SC...Ca...Ca...SCi
5921         gloci=0.0D0
5922         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5923      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5924      &      (itype(i-1).eq.ntyp1)))
5925      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5926      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5927      &     .or.(itype(i).eq.ntyp1)))
5928      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5929      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5930      &      (itype(i-3).eq.ntyp1)))) cycle
5931         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5932         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5933      & cycle
5934        do j=1,nterm_sccor(isccori,isccori1)
5935           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5936           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5937           cosphi=dcos(j*tauangle(intertyp,i))
5938           sinphi=dsin(j*tauangle(intertyp,i))
5939           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5940           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5941         enddo
5942 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5943         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5944         if (lprn)
5945      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5946      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5947      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5948      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5949         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5950        enddo !intertyp
5951       enddo
5952
5953       return
5954       end
5955 c----------------------------------------------------------------------------
5956       subroutine multibody(ecorr)
5957 C This subroutine calculates multi-body contributions to energy following
5958 C the idea of Skolnick et al. If side chains I and J make a contact and
5959 C at the same time side chains I+1 and J+1 make a contact, an extra
5960 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5961       implicit real*8 (a-h,o-z)
5962       include 'DIMENSIONS'
5963       include 'COMMON.IOUNITS'
5964       include 'COMMON.DERIV'
5965       include 'COMMON.INTERACT'
5966       include 'COMMON.CONTACTS'
5967       double precision gx(3),gx1(3)
5968       logical lprn
5969
5970 C Set lprn=.true. for debugging
5971       lprn=.false.
5972
5973       if (lprn) then
5974         write (iout,'(a)') 'Contact function values:'
5975         do i=nnt,nct-2
5976           write (iout,'(i2,20(1x,i2,f10.5))')
5977      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5978         enddo
5979       endif
5980       ecorr=0.0D0
5981       do i=nnt,nct
5982         do j=1,3
5983           gradcorr(j,i)=0.0D0
5984           gradxorr(j,i)=0.0D0
5985         enddo
5986       enddo
5987       do i=nnt,nct-2
5988
5989         DO ISHIFT = 3,4
5990
5991         i1=i+ishift
5992         num_conti=num_cont(i)
5993         num_conti1=num_cont(i1)
5994         do jj=1,num_conti
5995           j=jcont(jj,i)
5996           do kk=1,num_conti1
5997             j1=jcont(kk,i1)
5998             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5999 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6000 cd   &                   ' ishift=',ishift
6001 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6002 C The system gains extra energy.
6003               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6004             endif   ! j1==j+-ishift
6005           enddo     ! kk
6006         enddo       ! jj
6007
6008         ENDDO ! ISHIFT
6009
6010       enddo         ! i
6011       return
6012       end
6013 c------------------------------------------------------------------------------
6014       double precision function esccorr(i,j,k,l,jj,kk)
6015       implicit real*8 (a-h,o-z)
6016       include 'DIMENSIONS'
6017       include 'COMMON.IOUNITS'
6018       include 'COMMON.DERIV'
6019       include 'COMMON.INTERACT'
6020       include 'COMMON.CONTACTS'
6021       double precision gx(3),gx1(3)
6022       logical lprn
6023       lprn=.false.
6024       eij=facont(jj,i)
6025       ekl=facont(kk,k)
6026 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6027 C Calculate the multi-body contribution to energy.
6028 C Calculate multi-body contributions to the gradient.
6029 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6030 cd   & k,l,(gacont(m,kk,k),m=1,3)
6031       do m=1,3
6032         gx(m) =ekl*gacont(m,jj,i)
6033         gx1(m)=eij*gacont(m,kk,k)
6034         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6035         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6036         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6037         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6038       enddo
6039       do m=i,j-1
6040         do ll=1,3
6041           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6042         enddo
6043       enddo
6044       do m=k,l-1
6045         do ll=1,3
6046           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6047         enddo
6048       enddo
6049       esccorr=-eij*ekl
6050       return
6051       end
6052 c------------------------------------------------------------------------------
6053       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6054 C This subroutine calculates multi-body contributions to hydrogen-bonding
6055       implicit real*8 (a-h,o-z)
6056       include 'DIMENSIONS'
6057       include 'COMMON.IOUNITS'
6058 #ifdef MPI
6059       include "mpif.h"
6060       parameter (max_cont=maxconts)
6061       parameter (max_dim=26)
6062       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6063       double precision zapas(max_dim,maxconts,max_fg_procs),
6064      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6065       common /przechowalnia/ zapas
6066       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6067      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6068 #endif
6069       include 'COMMON.SETUP'
6070       include 'COMMON.FFIELD'
6071       include 'COMMON.DERIV'
6072       include 'COMMON.INTERACT'
6073       include 'COMMON.CONTACTS'
6074       include 'COMMON.CONTROL'
6075       include 'COMMON.LOCAL'
6076       double precision gx(3),gx1(3),time00
6077       logical lprn,ldone
6078
6079 C Set lprn=.true. for debugging
6080       lprn=.false.
6081 #ifdef MPI
6082       n_corr=0
6083       n_corr1=0
6084       if (nfgtasks.le.1) goto 30
6085       if (lprn) then
6086         write (iout,'(a)') 'Contact function values before RECEIVE:'
6087         do i=nnt,nct-2
6088           write (iout,'(2i3,50(1x,i2,f5.2))')
6089      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6090      &    j=1,num_cont_hb(i))
6091         enddo
6092       endif
6093       call flush(iout)
6094       do i=1,ntask_cont_from
6095         ncont_recv(i)=0
6096       enddo
6097       do i=1,ntask_cont_to
6098         ncont_sent(i)=0
6099       enddo
6100 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6101 c     & ntask_cont_to
6102 C Make the list of contacts to send to send to other procesors
6103 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6104 c      call flush(iout)
6105       do i=iturn3_start,iturn3_end
6106 c        write (iout,*) "make contact list turn3",i," num_cont",
6107 c     &    num_cont_hb(i)
6108         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6109       enddo
6110       do i=iturn4_start,iturn4_end
6111 c        write (iout,*) "make contact list turn4",i," num_cont",
6112 c     &   num_cont_hb(i)
6113         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6114       enddo
6115       do ii=1,nat_sent
6116         i=iat_sent(ii)
6117 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6118 c     &    num_cont_hb(i)
6119         do j=1,num_cont_hb(i)
6120         do k=1,4
6121           jjc=jcont_hb(j,i)
6122           iproc=iint_sent_local(k,jjc,ii)
6123 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6124           if (iproc.gt.0) then
6125             ncont_sent(iproc)=ncont_sent(iproc)+1
6126             nn=ncont_sent(iproc)
6127             zapas(1,nn,iproc)=i
6128             zapas(2,nn,iproc)=jjc
6129             zapas(3,nn,iproc)=facont_hb(j,i)
6130             zapas(4,nn,iproc)=ees0p(j,i)
6131             zapas(5,nn,iproc)=ees0m(j,i)
6132             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6133             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6134             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6135             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6136             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6137             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6138             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6139             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6140             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6141             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6142             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6143             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6144             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6145             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6146             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6147             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6148             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6149             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6150             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6151             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6152             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6153           endif
6154         enddo
6155         enddo
6156       enddo
6157       if (lprn) then
6158       write (iout,*)
6159      &  "Numbers of contacts to be sent to other processors",
6160      &  (ncont_sent(i),i=1,ntask_cont_to)
6161       write (iout,*) "Contacts sent"
6162       do ii=1,ntask_cont_to
6163         nn=ncont_sent(ii)
6164         iproc=itask_cont_to(ii)
6165         write (iout,*) nn," contacts to processor",iproc,
6166      &   " of CONT_TO_COMM group"
6167         do i=1,nn
6168           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6169         enddo
6170       enddo
6171       call flush(iout)
6172       endif
6173       CorrelType=477
6174       CorrelID=fg_rank+1
6175       CorrelType1=478
6176       CorrelID1=nfgtasks+fg_rank+1
6177       ireq=0
6178 C Receive the numbers of needed contacts from other processors
6179       do ii=1,ntask_cont_from
6180         iproc=itask_cont_from(ii)
6181         ireq=ireq+1
6182         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6183      &    FG_COMM,req(ireq),IERR)
6184       enddo
6185 c      write (iout,*) "IRECV ended"
6186 c      call flush(iout)
6187 C Send the number of contacts needed by other processors
6188       do ii=1,ntask_cont_to
6189         iproc=itask_cont_to(ii)
6190         ireq=ireq+1
6191         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6192      &    FG_COMM,req(ireq),IERR)
6193       enddo
6194 c      write (iout,*) "ISEND ended"
6195 c      write (iout,*) "number of requests (nn)",ireq
6196       call flush(iout)
6197       if (ireq.gt.0)
6198      &  call MPI_Waitall(ireq,req,status_array,ierr)
6199 c      write (iout,*)
6200 c     &  "Numbers of contacts to be received from other processors",
6201 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6202 c      call flush(iout)
6203 C Receive contacts
6204       ireq=0
6205       do ii=1,ntask_cont_from
6206         iproc=itask_cont_from(ii)
6207         nn=ncont_recv(ii)
6208 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6209 c     &   " of CONT_TO_COMM group"
6210         call flush(iout)
6211         if (nn.gt.0) then
6212           ireq=ireq+1
6213           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6214      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6215 c          write (iout,*) "ireq,req",ireq,req(ireq)
6216         endif
6217       enddo
6218 C Send the contacts to processors that need them
6219       do ii=1,ntask_cont_to
6220         iproc=itask_cont_to(ii)
6221         nn=ncont_sent(ii)
6222 c        write (iout,*) nn," contacts to processor",iproc,
6223 c     &   " of CONT_TO_COMM group"
6224         if (nn.gt.0) then
6225           ireq=ireq+1
6226           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6227      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6228 c          write (iout,*) "ireq,req",ireq,req(ireq)
6229 c          do i=1,nn
6230 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6231 c          enddo
6232         endif
6233       enddo
6234 c      write (iout,*) "number of requests (contacts)",ireq
6235 c      write (iout,*) "req",(req(i),i=1,4)
6236 c      call flush(iout)
6237       if (ireq.gt.0)
6238      & call MPI_Waitall(ireq,req,status_array,ierr)
6239       do iii=1,ntask_cont_from
6240         iproc=itask_cont_from(iii)
6241         nn=ncont_recv(iii)
6242         if (lprn) then
6243         write (iout,*) "Received",nn," contacts from processor",iproc,
6244      &   " of CONT_FROM_COMM group"
6245         call flush(iout)
6246         do i=1,nn
6247           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6248         enddo
6249         call flush(iout)
6250         endif
6251         do i=1,nn
6252           ii=zapas_recv(1,i,iii)
6253 c Flag the received contacts to prevent double-counting
6254           jj=-zapas_recv(2,i,iii)
6255 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6256 c          call flush(iout)
6257           nnn=num_cont_hb(ii)+1
6258           num_cont_hb(ii)=nnn
6259           jcont_hb(nnn,ii)=jj
6260           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6261           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6262           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6263           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6264           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6265           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6266           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6267           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6268           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6269           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6270           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6271           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6272           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6273           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6274           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6275           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6276           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6277           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6278           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6279           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6280           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6281           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6282           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6283           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6284         enddo
6285       enddo
6286       call flush(iout)
6287       if (lprn) then
6288         write (iout,'(a)') 'Contact function values after receive:'
6289         do i=nnt,nct-2
6290           write (iout,'(2i3,50(1x,i3,f5.2))')
6291      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6292      &    j=1,num_cont_hb(i))
6293         enddo
6294         call flush(iout)
6295       endif
6296    30 continue
6297 #endif
6298       if (lprn) then
6299         write (iout,'(a)') 'Contact function values:'
6300         do i=nnt,nct-2
6301           write (iout,'(2i3,50(1x,i3,f5.2))')
6302      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6303      &    j=1,num_cont_hb(i))
6304         enddo
6305       endif
6306       ecorr=0.0D0
6307 C Remove the loop below after debugging !!!
6308       do i=nnt,nct
6309         do j=1,3
6310           gradcorr(j,i)=0.0D0
6311           gradxorr(j,i)=0.0D0
6312         enddo
6313       enddo
6314 C Calculate the local-electrostatic correlation terms
6315       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6316         i1=i+1
6317         num_conti=num_cont_hb(i)
6318         num_conti1=num_cont_hb(i+1)
6319         do jj=1,num_conti
6320           j=jcont_hb(jj,i)
6321           jp=iabs(j)
6322           do kk=1,num_conti1
6323             j1=jcont_hb(kk,i1)
6324             jp1=iabs(j1)
6325 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6326 c     &         ' jj=',jj,' kk=',kk
6327             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6328      &          .or. j.lt.0 .and. j1.gt.0) .and.
6329      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6330 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6331 C The system gains extra energy.
6332               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6333               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6334      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6335               n_corr=n_corr+1
6336             else if (j1.eq.j) then
6337 C Contacts I-J and I-(J+1) occur simultaneously.
6338 C The system loses extra energy.
6339 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6340             endif
6341           enddo ! kk
6342           do kk=1,num_conti
6343             j1=jcont_hb(kk,i)
6344 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6345 c    &         ' jj=',jj,' kk=',kk
6346             if (j1.eq.j+1) then
6347 C Contacts I-J and (I+1)-J occur simultaneously.
6348 C The system loses extra energy.
6349 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6350             endif ! j1==j+1
6351           enddo ! kk
6352         enddo ! jj
6353       enddo ! i
6354       return
6355       end
6356 c------------------------------------------------------------------------------
6357       subroutine add_hb_contact(ii,jj,itask)
6358       implicit real*8 (a-h,o-z)
6359       include "DIMENSIONS"
6360       include "COMMON.IOUNITS"
6361       integer max_cont
6362       integer max_dim
6363       parameter (max_cont=maxconts)
6364       parameter (max_dim=26)
6365       include "COMMON.CONTACTS"
6366       double precision zapas(max_dim,maxconts,max_fg_procs),
6367      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6368       common /przechowalnia/ zapas
6369       integer i,j,ii,jj,iproc,itask(4),nn
6370 c      write (iout,*) "itask",itask
6371       do i=1,2
6372         iproc=itask(i)
6373         if (iproc.gt.0) then
6374           do j=1,num_cont_hb(ii)
6375             jjc=jcont_hb(j,ii)
6376 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6377             if (jjc.eq.jj) then
6378               ncont_sent(iproc)=ncont_sent(iproc)+1
6379               nn=ncont_sent(iproc)
6380               zapas(1,nn,iproc)=ii
6381               zapas(2,nn,iproc)=jjc
6382               zapas(3,nn,iproc)=facont_hb(j,ii)
6383               zapas(4,nn,iproc)=ees0p(j,ii)
6384               zapas(5,nn,iproc)=ees0m(j,ii)
6385               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6386               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6387               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6388               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6389               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6390               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6391               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6392               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6393               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6394               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6395               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6396               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6397               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6398               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6399               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6400               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6401               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6402               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6403               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6404               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6405               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6406               exit
6407             endif
6408           enddo
6409         endif
6410       enddo
6411       return
6412       end
6413 c------------------------------------------------------------------------------
6414       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6415      &  n_corr1)
6416 C This subroutine calculates multi-body contributions to hydrogen-bonding
6417       implicit real*8 (a-h,o-z)
6418       include 'DIMENSIONS'
6419       include 'COMMON.IOUNITS'
6420 #ifdef MPI
6421       include "mpif.h"
6422       parameter (max_cont=maxconts)
6423       parameter (max_dim=70)
6424       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6425       double precision zapas(max_dim,maxconts,max_fg_procs),
6426      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6427       common /przechowalnia/ zapas
6428       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6429      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6430 #endif
6431       include 'COMMON.SETUP'
6432       include 'COMMON.FFIELD'
6433       include 'COMMON.DERIV'
6434       include 'COMMON.LOCAL'
6435       include 'COMMON.INTERACT'
6436       include 'COMMON.CONTACTS'
6437       include 'COMMON.CHAIN'
6438       include 'COMMON.CONTROL'
6439       double precision gx(3),gx1(3)
6440       integer num_cont_hb_old(maxres)
6441       logical lprn,ldone
6442       double precision eello4,eello5,eelo6,eello_turn6
6443       external eello4,eello5,eello6,eello_turn6
6444 C Set lprn=.true. for debugging
6445       lprn=.false.
6446       eturn6=0.0d0
6447 #ifdef MPI
6448       do i=1,nres
6449         num_cont_hb_old(i)=num_cont_hb(i)
6450       enddo
6451       n_corr=0
6452       n_corr1=0
6453       if (nfgtasks.le.1) goto 30
6454       if (lprn) then
6455         write (iout,'(a)') 'Contact function values before RECEIVE:'
6456         do i=nnt,nct-2
6457           write (iout,'(2i3,50(1x,i2,f5.2))')
6458      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6459      &    j=1,num_cont_hb(i))
6460         enddo
6461       endif
6462       call flush(iout)
6463       do i=1,ntask_cont_from
6464         ncont_recv(i)=0
6465       enddo
6466       do i=1,ntask_cont_to
6467         ncont_sent(i)=0
6468       enddo
6469 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6470 c     & ntask_cont_to
6471 C Make the list of contacts to send to send to other procesors
6472       do i=iturn3_start,iturn3_end
6473 c        write (iout,*) "make contact list turn3",i," num_cont",
6474 c     &    num_cont_hb(i)
6475         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6476       enddo
6477       do i=iturn4_start,iturn4_end
6478 c        write (iout,*) "make contact list turn4",i," num_cont",
6479 c     &   num_cont_hb(i)
6480         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6481       enddo
6482       do ii=1,nat_sent
6483         i=iat_sent(ii)
6484 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6485 c     &    num_cont_hb(i)
6486         do j=1,num_cont_hb(i)
6487         do k=1,4
6488           jjc=jcont_hb(j,i)
6489           iproc=iint_sent_local(k,jjc,ii)
6490 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6491           if (iproc.ne.0) then
6492             ncont_sent(iproc)=ncont_sent(iproc)+1
6493             nn=ncont_sent(iproc)
6494             zapas(1,nn,iproc)=i
6495             zapas(2,nn,iproc)=jjc
6496             zapas(3,nn,iproc)=d_cont(j,i)
6497             ind=3
6498             do kk=1,3
6499               ind=ind+1
6500               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6501             enddo
6502             do kk=1,2
6503               do ll=1,2
6504                 ind=ind+1
6505                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6506               enddo
6507             enddo
6508             do jj=1,5
6509               do kk=1,3
6510                 do ll=1,2
6511                   do mm=1,2
6512                     ind=ind+1
6513                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6514                   enddo
6515                 enddo
6516               enddo
6517             enddo
6518           endif
6519         enddo
6520         enddo
6521       enddo
6522       if (lprn) then
6523       write (iout,*)
6524      &  "Numbers of contacts to be sent to other processors",
6525      &  (ncont_sent(i),i=1,ntask_cont_to)
6526       write (iout,*) "Contacts sent"
6527       do ii=1,ntask_cont_to
6528         nn=ncont_sent(ii)
6529         iproc=itask_cont_to(ii)
6530         write (iout,*) nn," contacts to processor",iproc,
6531      &   " of CONT_TO_COMM group"
6532         do i=1,nn
6533           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6534         enddo
6535       enddo
6536       call flush(iout)
6537       endif
6538       CorrelType=477
6539       CorrelID=fg_rank+1
6540       CorrelType1=478
6541       CorrelID1=nfgtasks+fg_rank+1
6542       ireq=0
6543 C Receive the numbers of needed contacts from other processors
6544       do ii=1,ntask_cont_from
6545         iproc=itask_cont_from(ii)
6546         ireq=ireq+1
6547         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6548      &    FG_COMM,req(ireq),IERR)
6549       enddo
6550 c      write (iout,*) "IRECV ended"
6551 c      call flush(iout)
6552 C Send the number of contacts needed by other processors
6553       do ii=1,ntask_cont_to
6554         iproc=itask_cont_to(ii)
6555         ireq=ireq+1
6556         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6557      &    FG_COMM,req(ireq),IERR)
6558       enddo
6559 c      write (iout,*) "ISEND ended"
6560 c      write (iout,*) "number of requests (nn)",ireq
6561       call flush(iout)
6562       if (ireq.gt.0)
6563      &  call MPI_Waitall(ireq,req,status_array,ierr)
6564 c      write (iout,*)
6565 c     &  "Numbers of contacts to be received from other processors",
6566 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6567 c      call flush(iout)
6568 C Receive contacts
6569       ireq=0
6570       do ii=1,ntask_cont_from
6571         iproc=itask_cont_from(ii)
6572         nn=ncont_recv(ii)
6573 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6574 c     &   " of CONT_TO_COMM group"
6575         call flush(iout)
6576         if (nn.gt.0) then
6577           ireq=ireq+1
6578           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6579      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6580 c          write (iout,*) "ireq,req",ireq,req(ireq)
6581         endif
6582       enddo
6583 C Send the contacts to processors that need them
6584       do ii=1,ntask_cont_to
6585         iproc=itask_cont_to(ii)
6586         nn=ncont_sent(ii)
6587 c        write (iout,*) nn," contacts to processor",iproc,
6588 c     &   " of CONT_TO_COMM group"
6589         if (nn.gt.0) then
6590           ireq=ireq+1
6591           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6592      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6593 c          write (iout,*) "ireq,req",ireq,req(ireq)
6594 c          do i=1,nn
6595 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6596 c          enddo
6597         endif
6598       enddo
6599 c      write (iout,*) "number of requests (contacts)",ireq
6600 c      write (iout,*) "req",(req(i),i=1,4)
6601 c      call flush(iout)
6602       if (ireq.gt.0)
6603      & call MPI_Waitall(ireq,req,status_array,ierr)
6604       do iii=1,ntask_cont_from
6605         iproc=itask_cont_from(iii)
6606         nn=ncont_recv(iii)
6607         if (lprn) then
6608         write (iout,*) "Received",nn," contacts from processor",iproc,
6609      &   " of CONT_FROM_COMM group"
6610         call flush(iout)
6611         do i=1,nn
6612           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6613         enddo
6614         call flush(iout)
6615         endif
6616         do i=1,nn
6617           ii=zapas_recv(1,i,iii)
6618 c Flag the received contacts to prevent double-counting
6619           jj=-zapas_recv(2,i,iii)
6620 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6621 c          call flush(iout)
6622           nnn=num_cont_hb(ii)+1
6623           num_cont_hb(ii)=nnn
6624           jcont_hb(nnn,ii)=jj
6625           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6626           ind=3
6627           do kk=1,3
6628             ind=ind+1
6629             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6630           enddo
6631           do kk=1,2
6632             do ll=1,2
6633               ind=ind+1
6634               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6635             enddo
6636           enddo
6637           do jj=1,5
6638             do kk=1,3
6639               do ll=1,2
6640                 do mm=1,2
6641                   ind=ind+1
6642                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6643                 enddo
6644               enddo
6645             enddo
6646           enddo
6647         enddo
6648       enddo
6649       call flush(iout)
6650       if (lprn) then
6651         write (iout,'(a)') 'Contact function values after receive:'
6652         do i=nnt,nct-2
6653           write (iout,'(2i3,50(1x,i3,5f6.3))')
6654      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6655      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6656         enddo
6657         call flush(iout)
6658       endif
6659    30 continue
6660 #endif
6661       if (lprn) then
6662         write (iout,'(a)') 'Contact function values:'
6663         do i=nnt,nct-2
6664           write (iout,'(2i3,50(1x,i2,5f6.3))')
6665      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6666      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6667         enddo
6668       endif
6669       ecorr=0.0D0
6670       ecorr5=0.0d0
6671       ecorr6=0.0d0
6672 C Remove the loop below after debugging !!!
6673       do i=nnt,nct
6674         do j=1,3
6675           gradcorr(j,i)=0.0D0
6676           gradxorr(j,i)=0.0D0
6677         enddo
6678       enddo
6679 C Calculate the dipole-dipole interaction energies
6680       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6681       do i=iatel_s,iatel_e+1
6682         num_conti=num_cont_hb(i)
6683         do jj=1,num_conti
6684           j=jcont_hb(jj,i)
6685 #ifdef MOMENT
6686           call dipole(i,j,jj)
6687 #endif
6688         enddo
6689       enddo
6690       endif
6691 C Calculate the local-electrostatic correlation terms
6692 c                write (iout,*) "gradcorr5 in eello5 before loop"
6693 c                do iii=1,nres
6694 c                  write (iout,'(i5,3f10.5)')
6695 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6696 c                enddo
6697       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6698 c        write (iout,*) "corr loop i",i
6699         i1=i+1
6700         num_conti=num_cont_hb(i)
6701         num_conti1=num_cont_hb(i+1)
6702         do jj=1,num_conti
6703           j=jcont_hb(jj,i)
6704           jp=iabs(j)
6705           do kk=1,num_conti1
6706             j1=jcont_hb(kk,i1)
6707             jp1=iabs(j1)
6708 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6709 c     &         ' jj=',jj,' kk=',kk
6710 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6711             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6712      &          .or. j.lt.0 .and. j1.gt.0) .and.
6713      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6714 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6715 C The system gains extra energy.
6716               n_corr=n_corr+1
6717               sqd1=dsqrt(d_cont(jj,i))
6718               sqd2=dsqrt(d_cont(kk,i1))
6719               sred_geom = sqd1*sqd2
6720               IF (sred_geom.lt.cutoff_corr) THEN
6721                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6722      &            ekont,fprimcont)
6723 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6724 cd     &         ' jj=',jj,' kk=',kk
6725                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6726                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6727                 do l=1,3
6728                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6729                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6730                 enddo
6731                 n_corr1=n_corr1+1
6732 cd               write (iout,*) 'sred_geom=',sred_geom,
6733 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6734 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6735 cd               write (iout,*) "g_contij",g_contij
6736 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6737 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6738                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6739                 if (wcorr4.gt.0.0d0)
6740      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6741                   if (energy_dec.and.wcorr4.gt.0.0d0)
6742      1                 write (iout,'(a6,4i5,0pf7.3)')
6743      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6744 c                write (iout,*) "gradcorr5 before eello5"
6745 c                do iii=1,nres
6746 c                  write (iout,'(i5,3f10.5)')
6747 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6748 c                enddo
6749                 if (wcorr5.gt.0.0d0)
6750      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6751 c                write (iout,*) "gradcorr5 after eello5"
6752 c                do iii=1,nres
6753 c                  write (iout,'(i5,3f10.5)')
6754 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6755 c                enddo
6756                   if (energy_dec.and.wcorr5.gt.0.0d0)
6757      1                 write (iout,'(a6,4i5,0pf7.3)')
6758      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6759 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6760 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6761                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6762      &               .or. wturn6.eq.0.0d0))then
6763 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6764                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6765                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6766      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6767 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6768 cd     &            'ecorr6=',ecorr6
6769 cd                write (iout,'(4e15.5)') sred_geom,
6770 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6771 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6772 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6773                 else if (wturn6.gt.0.0d0
6774      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6775 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6776                   eturn6=eturn6+eello_turn6(i,jj,kk)
6777                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6778      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6779 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6780                 endif
6781               ENDIF
6782 1111          continue
6783             endif
6784           enddo ! kk
6785         enddo ! jj
6786       enddo ! i
6787       do i=1,nres
6788         num_cont_hb(i)=num_cont_hb_old(i)
6789       enddo
6790 c                write (iout,*) "gradcorr5 in eello5"
6791 c                do iii=1,nres
6792 c                  write (iout,'(i5,3f10.5)')
6793 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6794 c                enddo
6795       return
6796       end
6797 c------------------------------------------------------------------------------
6798       subroutine add_hb_contact_eello(ii,jj,itask)
6799       implicit real*8 (a-h,o-z)
6800       include "DIMENSIONS"
6801       include "COMMON.IOUNITS"
6802       integer max_cont
6803       integer max_dim
6804       parameter (max_cont=maxconts)
6805       parameter (max_dim=70)
6806       include "COMMON.CONTACTS"
6807       double precision zapas(max_dim,maxconts,max_fg_procs),
6808      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6809       common /przechowalnia/ zapas
6810       integer i,j,ii,jj,iproc,itask(4),nn
6811 c      write (iout,*) "itask",itask
6812       do i=1,2
6813         iproc=itask(i)
6814         if (iproc.gt.0) then
6815           do j=1,num_cont_hb(ii)
6816             jjc=jcont_hb(j,ii)
6817 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6818             if (jjc.eq.jj) then
6819               ncont_sent(iproc)=ncont_sent(iproc)+1
6820               nn=ncont_sent(iproc)
6821               zapas(1,nn,iproc)=ii
6822               zapas(2,nn,iproc)=jjc
6823               zapas(3,nn,iproc)=d_cont(j,ii)
6824               ind=3
6825               do kk=1,3
6826                 ind=ind+1
6827                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6828               enddo
6829               do kk=1,2
6830                 do ll=1,2
6831                   ind=ind+1
6832                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6833                 enddo
6834               enddo
6835               do jj=1,5
6836                 do kk=1,3
6837                   do ll=1,2
6838                     do mm=1,2
6839                       ind=ind+1
6840                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6841                     enddo
6842                   enddo
6843                 enddo
6844               enddo
6845               exit
6846             endif
6847           enddo
6848         endif
6849       enddo
6850       return
6851       end
6852 c------------------------------------------------------------------------------
6853       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6854       implicit real*8 (a-h,o-z)
6855       include 'DIMENSIONS'
6856       include 'COMMON.IOUNITS'
6857       include 'COMMON.DERIV'
6858       include 'COMMON.INTERACT'
6859       include 'COMMON.CONTACTS'
6860       double precision gx(3),gx1(3)
6861       logical lprn
6862       lprn=.false.
6863       eij=facont_hb(jj,i)
6864       ekl=facont_hb(kk,k)
6865       ees0pij=ees0p(jj,i)
6866       ees0pkl=ees0p(kk,k)
6867       ees0mij=ees0m(jj,i)
6868       ees0mkl=ees0m(kk,k)
6869       ekont=eij*ekl
6870       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6871 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6872 C Following 4 lines for diagnostics.
6873 cd    ees0pkl=0.0D0
6874 cd    ees0pij=1.0D0
6875 cd    ees0mkl=0.0D0
6876 cd    ees0mij=1.0D0
6877 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6878 c     & 'Contacts ',i,j,
6879 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6880 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6881 c     & 'gradcorr_long'
6882 C Calculate the multi-body contribution to energy.
6883 c      ecorr=ecorr+ekont*ees
6884 C Calculate multi-body contributions to the gradient.
6885       coeffpees0pij=coeffp*ees0pij
6886       coeffmees0mij=coeffm*ees0mij
6887       coeffpees0pkl=coeffp*ees0pkl
6888       coeffmees0mkl=coeffm*ees0mkl
6889       do ll=1,3
6890 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6891         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6892      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6893      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6894         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6895      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6896      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6897 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6898         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6899      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6900      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6901         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6902      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6903      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6904         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6905      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6906      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6907         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6908         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6909         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6910      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6911      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6912         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6913         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6914 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6915       enddo
6916 c      write (iout,*)
6917 cgrad      do m=i+1,j-1
6918 cgrad        do ll=1,3
6919 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6920 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6921 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6922 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6923 cgrad        enddo
6924 cgrad      enddo
6925 cgrad      do m=k+1,l-1
6926 cgrad        do ll=1,3
6927 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6928 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6929 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6930 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6931 cgrad        enddo
6932 cgrad      enddo
6933 c      write (iout,*) "ehbcorr",ekont*ees
6934       ehbcorr=ekont*ees
6935       return
6936       end
6937 #ifdef MOMENT
6938 C---------------------------------------------------------------------------
6939       subroutine dipole(i,j,jj)
6940       implicit real*8 (a-h,o-z)
6941       include 'DIMENSIONS'
6942       include 'COMMON.IOUNITS'
6943       include 'COMMON.CHAIN'
6944       include 'COMMON.FFIELD'
6945       include 'COMMON.DERIV'
6946       include 'COMMON.INTERACT'
6947       include 'COMMON.CONTACTS'
6948       include 'COMMON.TORSION'
6949       include 'COMMON.VAR'
6950       include 'COMMON.GEO'
6951       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6952      &  auxmat(2,2)
6953       iti1 = itortyp(itype(i+1))
6954       if (j.lt.nres-1) then
6955         itj1 = itortyp(itype(j+1))
6956       else
6957         itj1=ntortyp+1
6958       endif
6959       do iii=1,2
6960         dipi(iii,1)=Ub2(iii,i)
6961         dipderi(iii)=Ub2der(iii,i)
6962         dipi(iii,2)=b1(iii,i+1)
6963         dipj(iii,1)=Ub2(iii,j)
6964         dipderj(iii)=Ub2der(iii,j)
6965         dipj(iii,2)=b1(iii,j+1)
6966       enddo
6967       kkk=0
6968       do iii=1,2
6969         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6970         do jjj=1,2
6971           kkk=kkk+1
6972           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6973         enddo
6974       enddo
6975       do kkk=1,5
6976         do lll=1,3
6977           mmm=0
6978           do iii=1,2
6979             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6980      &        auxvec(1))
6981             do jjj=1,2
6982               mmm=mmm+1
6983               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6984             enddo
6985           enddo
6986         enddo
6987       enddo
6988       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6989       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6990       do iii=1,2
6991         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6992       enddo
6993       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6994       do iii=1,2
6995         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6996       enddo
6997       return
6998       end
6999 #endif
7000 C---------------------------------------------------------------------------
7001       subroutine calc_eello(i,j,k,l,jj,kk)
7002 C
7003 C This subroutine computes matrices and vectors needed to calculate
7004 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7005 C
7006       implicit real*8 (a-h,o-z)
7007       include 'DIMENSIONS'
7008       include 'COMMON.IOUNITS'
7009       include 'COMMON.CHAIN'
7010       include 'COMMON.DERIV'
7011       include 'COMMON.INTERACT'
7012       include 'COMMON.CONTACTS'
7013       include 'COMMON.TORSION'
7014       include 'COMMON.VAR'
7015       include 'COMMON.GEO'
7016       include 'COMMON.FFIELD'
7017       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7018      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7019       logical lprn
7020       common /kutas/ lprn
7021 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7022 cd     & ' jj=',jj,' kk=',kk
7023 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7024 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7025 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7026       do iii=1,2
7027         do jjj=1,2
7028           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7029           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7030         enddo
7031       enddo
7032       call transpose2(aa1(1,1),aa1t(1,1))
7033       call transpose2(aa2(1,1),aa2t(1,1))
7034       do kkk=1,5
7035         do lll=1,3
7036           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7037      &      aa1tder(1,1,lll,kkk))
7038           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7039      &      aa2tder(1,1,lll,kkk))
7040         enddo
7041       enddo
7042       if (l.eq.j+1) then
7043 C parallel orientation of the two CA-CA-CA frames.
7044         if (i.gt.1) then
7045           iti=itortyp(itype(i))
7046         else
7047           iti=ntortyp+1
7048         endif
7049         itk1=itortyp(itype(k+1))
7050         itj=itortyp(itype(j))
7051         if (l.lt.nres-1) then
7052           itl1=itortyp(itype(l+1))
7053         else
7054           itl1=ntortyp+1
7055         endif
7056 C A1 kernel(j+1) A2T
7057 cd        do iii=1,2
7058 cd          write (iout,'(3f10.5,5x,3f10.5)')
7059 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7060 cd        enddo
7061         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7062      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7063      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7064 C Following matrices are needed only for 6-th order cumulants
7065         IF (wcorr6.gt.0.0d0) THEN
7066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7067      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7068      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7070      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7071      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7072      &   ADtEAderx(1,1,1,1,1,1))
7073         lprn=.false.
7074         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7075      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7076      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7077      &   ADtEA1derx(1,1,1,1,1,1))
7078         ENDIF
7079 C End 6-th order cumulants
7080 cd        lprn=.false.
7081 cd        if (lprn) then
7082 cd        write (2,*) 'In calc_eello6'
7083 cd        do iii=1,2
7084 cd          write (2,*) 'iii=',iii
7085 cd          do kkk=1,5
7086 cd            write (2,*) 'kkk=',kkk
7087 cd            do jjj=1,2
7088 cd              write (2,'(3(2f10.5),5x)')
7089 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7090 cd            enddo
7091 cd          enddo
7092 cd        enddo
7093 cd        endif
7094         call transpose2(EUgder(1,1,k),auxmat(1,1))
7095         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7096         call transpose2(EUg(1,1,k),auxmat(1,1))
7097         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7098         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7099         do iii=1,2
7100           do kkk=1,5
7101             do lll=1,3
7102               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7103      &          EAEAderx(1,1,lll,kkk,iii,1))
7104             enddo
7105           enddo
7106         enddo
7107 C A1T kernel(i+1) A2
7108         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7109      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7110      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7111 C Following matrices are needed only for 6-th order cumulants
7112         IF (wcorr6.gt.0.0d0) THEN
7113         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7114      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7115      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7116         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7117      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7118      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7119      &   ADtEAderx(1,1,1,1,1,2))
7120         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7121      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7122      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7123      &   ADtEA1derx(1,1,1,1,1,2))
7124         ENDIF
7125 C End 6-th order cumulants
7126         call transpose2(EUgder(1,1,l),auxmat(1,1))
7127         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7128         call transpose2(EUg(1,1,l),auxmat(1,1))
7129         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7130         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7131         do iii=1,2
7132           do kkk=1,5
7133             do lll=1,3
7134               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7135      &          EAEAderx(1,1,lll,kkk,iii,2))
7136             enddo
7137           enddo
7138         enddo
7139 C AEAb1 and AEAb2
7140 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7141 C They are needed only when the fifth- or the sixth-order cumulants are
7142 C indluded.
7143         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7144         call transpose2(AEA(1,1,1),auxmat(1,1))
7145         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7146         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7147         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7148         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7149         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7150         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7151         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7152         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7153         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7154         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7155         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7156         call transpose2(AEA(1,1,2),auxmat(1,1))
7157         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7158         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7159         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7160         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7161         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7162         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7163         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7164         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7165         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7166         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7167         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7168 C Calculate the Cartesian derivatives of the vectors.
7169         do iii=1,2
7170           do kkk=1,5
7171             do lll=1,3
7172               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7173               call matvec2(auxmat(1,1),b1(1,i),
7174      &          AEAb1derx(1,lll,kkk,iii,1,1))
7175               call matvec2(auxmat(1,1),Ub2(1,i),
7176      &          AEAb2derx(1,lll,kkk,iii,1,1))
7177               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7178      &          AEAb1derx(1,lll,kkk,iii,2,1))
7179               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7180      &          AEAb2derx(1,lll,kkk,iii,2,1))
7181               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7182               call matvec2(auxmat(1,1),b1(1,j),
7183      &          AEAb1derx(1,lll,kkk,iii,1,2))
7184               call matvec2(auxmat(1,1),Ub2(1,j),
7185      &          AEAb2derx(1,lll,kkk,iii,1,2))
7186               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7187      &          AEAb1derx(1,lll,kkk,iii,2,2))
7188               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7189      &          AEAb2derx(1,lll,kkk,iii,2,2))
7190             enddo
7191           enddo
7192         enddo
7193         ENDIF
7194 C End vectors
7195       else
7196 C Antiparallel orientation of the two CA-CA-CA frames.
7197         if (i.gt.1) then
7198           iti=itortyp(itype(i))
7199         else
7200           iti=ntortyp+1
7201         endif
7202         itk1=itortyp(itype(k+1))
7203         itl=itortyp(itype(l))
7204         itj=itortyp(itype(j))
7205         if (j.lt.nres-1) then
7206           itj1=itortyp(itype(j+1))
7207         else
7208           itj1=ntortyp+1
7209         endif
7210 C A2 kernel(j-1)T A1T
7211         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7212      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7213      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7214 C Following matrices are needed only for 6-th order cumulants
7215         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7216      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7217         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7218      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7219      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7220         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7221      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7222      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7223      &   ADtEAderx(1,1,1,1,1,1))
7224         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7225      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7226      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7227      &   ADtEA1derx(1,1,1,1,1,1))
7228         ENDIF
7229 C End 6-th order cumulants
7230         call transpose2(EUgder(1,1,k),auxmat(1,1))
7231         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7232         call transpose2(EUg(1,1,k),auxmat(1,1))
7233         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7234         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7235         do iii=1,2
7236           do kkk=1,5
7237             do lll=1,3
7238               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7239      &          EAEAderx(1,1,lll,kkk,iii,1))
7240             enddo
7241           enddo
7242         enddo
7243 C A2T kernel(i+1)T A1
7244         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7245      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7246      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7247 C Following matrices are needed only for 6-th order cumulants
7248         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7249      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7250         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7251      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7252      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7253         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7254      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7255      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7256      &   ADtEAderx(1,1,1,1,1,2))
7257         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7258      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7259      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7260      &   ADtEA1derx(1,1,1,1,1,2))
7261         ENDIF
7262 C End 6-th order cumulants
7263         call transpose2(EUgder(1,1,j),auxmat(1,1))
7264         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7265         call transpose2(EUg(1,1,j),auxmat(1,1))
7266         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7267         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7268         do iii=1,2
7269           do kkk=1,5
7270             do lll=1,3
7271               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7272      &          EAEAderx(1,1,lll,kkk,iii,2))
7273             enddo
7274           enddo
7275         enddo
7276 C AEAb1 and AEAb2
7277 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7278 C They are needed only when the fifth- or the sixth-order cumulants are
7279 C indluded.
7280         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7281      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7282         call transpose2(AEA(1,1,1),auxmat(1,1))
7283         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7284         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7285         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7286         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7287         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7288         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7289         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7290         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7291         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7292         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7293         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7294         call transpose2(AEA(1,1,2),auxmat(1,1))
7295         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7296         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7297         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7298         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7299         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7300         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7301         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7302         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7303         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7304         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7305         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7306 C Calculate the Cartesian derivatives of the vectors.
7307         do iii=1,2
7308           do kkk=1,5
7309             do lll=1,3
7310               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7311               call matvec2(auxmat(1,1),b1(1,i),
7312      &          AEAb1derx(1,lll,kkk,iii,1,1))
7313               call matvec2(auxmat(1,1),Ub2(1,i),
7314      &          AEAb2derx(1,lll,kkk,iii,1,1))
7315               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7316      &          AEAb1derx(1,lll,kkk,iii,2,1))
7317               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7318      &          AEAb2derx(1,lll,kkk,iii,2,1))
7319               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7320               call matvec2(auxmat(1,1),b1(1,l),
7321      &          AEAb1derx(1,lll,kkk,iii,1,2))
7322               call matvec2(auxmat(1,1),Ub2(1,l),
7323      &          AEAb2derx(1,lll,kkk,iii,1,2))
7324               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7325      &          AEAb1derx(1,lll,kkk,iii,2,2))
7326               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7327      &          AEAb2derx(1,lll,kkk,iii,2,2))
7328             enddo
7329           enddo
7330         enddo
7331         ENDIF
7332 C End vectors
7333       endif
7334       return
7335       end
7336 C---------------------------------------------------------------------------
7337       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7338      &  KK,KKderg,AKA,AKAderg,AKAderx)
7339       implicit none
7340       integer nderg
7341       logical transp
7342       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7343      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7344      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7345       integer iii,kkk,lll
7346       integer jjj,mmm
7347       logical lprn
7348       common /kutas/ lprn
7349       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7350       do iii=1,nderg
7351         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7352      &    AKAderg(1,1,iii))
7353       enddo
7354 cd      if (lprn) write (2,*) 'In kernel'
7355       do kkk=1,5
7356 cd        if (lprn) write (2,*) 'kkk=',kkk
7357         do lll=1,3
7358           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7359      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7360 cd          if (lprn) then
7361 cd            write (2,*) 'lll=',lll
7362 cd            write (2,*) 'iii=1'
7363 cd            do jjj=1,2
7364 cd              write (2,'(3(2f10.5),5x)')
7365 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7366 cd            enddo
7367 cd          endif
7368           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7369      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7370 cd          if (lprn) then
7371 cd            write (2,*) 'lll=',lll
7372 cd            write (2,*) 'iii=2'
7373 cd            do jjj=1,2
7374 cd              write (2,'(3(2f10.5),5x)')
7375 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7376 cd            enddo
7377 cd          endif
7378         enddo
7379       enddo
7380       return
7381       end
7382 C---------------------------------------------------------------------------
7383       double precision function eello4(i,j,k,l,jj,kk)
7384       implicit real*8 (a-h,o-z)
7385       include 'DIMENSIONS'
7386       include 'COMMON.IOUNITS'
7387       include 'COMMON.CHAIN'
7388       include 'COMMON.DERIV'
7389       include 'COMMON.INTERACT'
7390       include 'COMMON.CONTACTS'
7391       include 'COMMON.TORSION'
7392       include 'COMMON.VAR'
7393       include 'COMMON.GEO'
7394       double precision pizda(2,2),ggg1(3),ggg2(3)
7395 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7396 cd        eello4=0.0d0
7397 cd        return
7398 cd      endif
7399 cd      print *,'eello4:',i,j,k,l,jj,kk
7400 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7401 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7402 cold      eij=facont_hb(jj,i)
7403 cold      ekl=facont_hb(kk,k)
7404 cold      ekont=eij*ekl
7405       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7406 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7407       gcorr_loc(k-1)=gcorr_loc(k-1)
7408      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7409       if (l.eq.j+1) then
7410         gcorr_loc(l-1)=gcorr_loc(l-1)
7411      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7412       else
7413         gcorr_loc(j-1)=gcorr_loc(j-1)
7414      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7415       endif
7416       do iii=1,2
7417         do kkk=1,5
7418           do lll=1,3
7419             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7420      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7421 cd            derx(lll,kkk,iii)=0.0d0
7422           enddo
7423         enddo
7424       enddo
7425 cd      gcorr_loc(l-1)=0.0d0
7426 cd      gcorr_loc(j-1)=0.0d0
7427 cd      gcorr_loc(k-1)=0.0d0
7428 cd      eel4=1.0d0
7429 cd      write (iout,*)'Contacts have occurred for peptide groups',
7430 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7431 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7432       if (j.lt.nres-1) then
7433         j1=j+1
7434         j2=j-1
7435       else
7436         j1=j-1
7437         j2=j-2
7438       endif
7439       if (l.lt.nres-1) then
7440         l1=l+1
7441         l2=l-1
7442       else
7443         l1=l-1
7444         l2=l-2
7445       endif
7446       do ll=1,3
7447 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7448 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7449         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7450         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7451 cgrad        ghalf=0.5d0*ggg1(ll)
7452         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7453         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7454         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7455         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7456         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7457         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7458 cgrad        ghalf=0.5d0*ggg2(ll)
7459         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7460         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7461         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7462         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7463         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7464         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7465       enddo
7466 cgrad      do m=i+1,j-1
7467 cgrad        do ll=1,3
7468 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7469 cgrad        enddo
7470 cgrad      enddo
7471 cgrad      do m=k+1,l-1
7472 cgrad        do ll=1,3
7473 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7474 cgrad        enddo
7475 cgrad      enddo
7476 cgrad      do m=i+2,j2
7477 cgrad        do ll=1,3
7478 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7479 cgrad        enddo
7480 cgrad      enddo
7481 cgrad      do m=k+2,l2
7482 cgrad        do ll=1,3
7483 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7484 cgrad        enddo
7485 cgrad      enddo
7486 cd      do iii=1,nres-3
7487 cd        write (2,*) iii,gcorr_loc(iii)
7488 cd      enddo
7489       eello4=ekont*eel4
7490 cd      write (2,*) 'ekont',ekont
7491 cd      write (iout,*) 'eello4',ekont*eel4
7492       return
7493       end
7494 C---------------------------------------------------------------------------
7495       double precision function eello5(i,j,k,l,jj,kk)
7496       implicit real*8 (a-h,o-z)
7497       include 'DIMENSIONS'
7498       include 'COMMON.IOUNITS'
7499       include 'COMMON.CHAIN'
7500       include 'COMMON.DERIV'
7501       include 'COMMON.INTERACT'
7502       include 'COMMON.CONTACTS'
7503       include 'COMMON.TORSION'
7504       include 'COMMON.VAR'
7505       include 'COMMON.GEO'
7506       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7507       double precision ggg1(3),ggg2(3)
7508 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7509 C                                                                              C
7510 C                            Parallel chains                                   C
7511 C                                                                              C
7512 C          o             o                   o             o                   C
7513 C         /l\           / \             \   / \           / \   /              C
7514 C        /   \         /   \             \ /   \         /   \ /               C
7515 C       j| o |l1       | o |              o| o |         | o |o                C
7516 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7517 C      \i/   \         /   \ /             /   \         /   \                 C
7518 C       o    k1             o                                                  C
7519 C         (I)          (II)                (III)          (IV)                 C
7520 C                                                                              C
7521 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7522 C                                                                              C
7523 C                            Antiparallel chains                               C
7524 C                                                                              C
7525 C          o             o                   o             o                   C
7526 C         /j\           / \             \   / \           / \   /              C
7527 C        /   \         /   \             \ /   \         /   \ /               C
7528 C      j1| o |l        | o |              o| o |         | o |o                C
7529 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7530 C      \i/   \         /   \ /             /   \         /   \                 C
7531 C       o     k1            o                                                  C
7532 C         (I)          (II)                (III)          (IV)                 C
7533 C                                                                              C
7534 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7535 C                                                                              C
7536 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7537 C                                                                              C
7538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7539 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7540 cd        eello5=0.0d0
7541 cd        return
7542 cd      endif
7543 cd      write (iout,*)
7544 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7545 cd     &   ' and',k,l
7546       itk=itortyp(itype(k))
7547       itl=itortyp(itype(l))
7548       itj=itortyp(itype(j))
7549       eello5_1=0.0d0
7550       eello5_2=0.0d0
7551       eello5_3=0.0d0
7552       eello5_4=0.0d0
7553 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7554 cd     &   eel5_3_num,eel5_4_num)
7555       do iii=1,2
7556         do kkk=1,5
7557           do lll=1,3
7558             derx(lll,kkk,iii)=0.0d0
7559           enddo
7560         enddo
7561       enddo
7562 cd      eij=facont_hb(jj,i)
7563 cd      ekl=facont_hb(kk,k)
7564 cd      ekont=eij*ekl
7565 cd      write (iout,*)'Contacts have occurred for peptide groups',
7566 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7567 cd      goto 1111
7568 C Contribution from the graph I.
7569 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7570 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7571       call transpose2(EUg(1,1,k),auxmat(1,1))
7572       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7573       vv(1)=pizda(1,1)-pizda(2,2)
7574       vv(2)=pizda(1,2)+pizda(2,1)
7575       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7576      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7577 C Explicit gradient in virtual-dihedral angles.
7578       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7579      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7580      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7581       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7582       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7583       vv(1)=pizda(1,1)-pizda(2,2)
7584       vv(2)=pizda(1,2)+pizda(2,1)
7585       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7586      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7587      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7588       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7589       vv(1)=pizda(1,1)-pizda(2,2)
7590       vv(2)=pizda(1,2)+pizda(2,1)
7591       if (l.eq.j+1) then
7592         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7593      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7595       else
7596         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7597      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7598      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7599       endif
7600 C Cartesian gradient
7601       do iii=1,2
7602         do kkk=1,5
7603           do lll=1,3
7604             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7605      &        pizda(1,1))
7606             vv(1)=pizda(1,1)-pizda(2,2)
7607             vv(2)=pizda(1,2)+pizda(2,1)
7608             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7609      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7610      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7611           enddo
7612         enddo
7613       enddo
7614 c      goto 1112
7615 c1111  continue
7616 C Contribution from graph II
7617       call transpose2(EE(1,1,itk),auxmat(1,1))
7618       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7619       vv(1)=pizda(1,1)+pizda(2,2)
7620       vv(2)=pizda(2,1)-pizda(1,2)
7621       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7622      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7623 C Explicit gradient in virtual-dihedral angles.
7624       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7625      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7626       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7627       vv(1)=pizda(1,1)+pizda(2,2)
7628       vv(2)=pizda(2,1)-pizda(1,2)
7629       if (l.eq.j+1) then
7630         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7631      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7632      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7633       else
7634         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7635      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7636      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7637       endif
7638 C Cartesian gradient
7639       do iii=1,2
7640         do kkk=1,5
7641           do lll=1,3
7642             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7643      &        pizda(1,1))
7644             vv(1)=pizda(1,1)+pizda(2,2)
7645             vv(2)=pizda(2,1)-pizda(1,2)
7646             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7647      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7648      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7649           enddo
7650         enddo
7651       enddo
7652 cd      goto 1112
7653 cd1111  continue
7654       if (l.eq.j+1) then
7655 cd        goto 1110
7656 C Parallel orientation
7657 C Contribution from graph III
7658         call transpose2(EUg(1,1,l),auxmat(1,1))
7659         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7660         vv(1)=pizda(1,1)-pizda(2,2)
7661         vv(2)=pizda(1,2)+pizda(2,1)
7662         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7664 C Explicit gradient in virtual-dihedral angles.
7665         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7666      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7667      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7668         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7669         vv(1)=pizda(1,1)-pizda(2,2)
7670         vv(2)=pizda(1,2)+pizda(2,1)
7671         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7672      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7673      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7674         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7675         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7676         vv(1)=pizda(1,1)-pizda(2,2)
7677         vv(2)=pizda(1,2)+pizda(2,1)
7678         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7679      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7680      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7681 C Cartesian gradient
7682         do iii=1,2
7683           do kkk=1,5
7684             do lll=1,3
7685               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7686      &          pizda(1,1))
7687               vv(1)=pizda(1,1)-pizda(2,2)
7688               vv(2)=pizda(1,2)+pizda(2,1)
7689               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7690      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7691      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7692             enddo
7693           enddo
7694         enddo
7695 cd        goto 1112
7696 C Contribution from graph IV
7697 cd1110    continue
7698         call transpose2(EE(1,1,itl),auxmat(1,1))
7699         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7700         vv(1)=pizda(1,1)+pizda(2,2)
7701         vv(2)=pizda(2,1)-pizda(1,2)
7702         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7703      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7704 C Explicit gradient in virtual-dihedral angles.
7705         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7706      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7707         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7708         vv(1)=pizda(1,1)+pizda(2,2)
7709         vv(2)=pizda(2,1)-pizda(1,2)
7710         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7711      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7712      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7713 C Cartesian gradient
7714         do iii=1,2
7715           do kkk=1,5
7716             do lll=1,3
7717               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7718      &          pizda(1,1))
7719               vv(1)=pizda(1,1)+pizda(2,2)
7720               vv(2)=pizda(2,1)-pizda(1,2)
7721               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7722      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7723      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7724             enddo
7725           enddo
7726         enddo
7727       else
7728 C Antiparallel orientation
7729 C Contribution from graph III
7730 c        goto 1110
7731         call transpose2(EUg(1,1,j),auxmat(1,1))
7732         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7733         vv(1)=pizda(1,1)-pizda(2,2)
7734         vv(2)=pizda(1,2)+pizda(2,1)
7735         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7736      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7737 C Explicit gradient in virtual-dihedral angles.
7738         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7739      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7740      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7741         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7742         vv(1)=pizda(1,1)-pizda(2,2)
7743         vv(2)=pizda(1,2)+pizda(2,1)
7744         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7745      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7746      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7747         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7748         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7749         vv(1)=pizda(1,1)-pizda(2,2)
7750         vv(2)=pizda(1,2)+pizda(2,1)
7751         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7752      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7753      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7754 C Cartesian gradient
7755         do iii=1,2
7756           do kkk=1,5
7757             do lll=1,3
7758               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7759      &          pizda(1,1))
7760               vv(1)=pizda(1,1)-pizda(2,2)
7761               vv(2)=pizda(1,2)+pizda(2,1)
7762               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7763      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7764      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7765             enddo
7766           enddo
7767         enddo
7768 cd        goto 1112
7769 C Contribution from graph IV
7770 1110    continue
7771         call transpose2(EE(1,1,itj),auxmat(1,1))
7772         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7773         vv(1)=pizda(1,1)+pizda(2,2)
7774         vv(2)=pizda(2,1)-pizda(1,2)
7775         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7776      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7777 C Explicit gradient in virtual-dihedral angles.
7778         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7779      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7780         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7781         vv(1)=pizda(1,1)+pizda(2,2)
7782         vv(2)=pizda(2,1)-pizda(1,2)
7783         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7784      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7785      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7786 C Cartesian gradient
7787         do iii=1,2
7788           do kkk=1,5
7789             do lll=1,3
7790               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7791      &          pizda(1,1))
7792               vv(1)=pizda(1,1)+pizda(2,2)
7793               vv(2)=pizda(2,1)-pizda(1,2)
7794               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7795      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7796      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7797             enddo
7798           enddo
7799         enddo
7800       endif
7801 1112  continue
7802       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7803 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7804 cd        write (2,*) 'ijkl',i,j,k,l
7805 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7806 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7807 cd      endif
7808 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7809 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7810 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7811 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7812       if (j.lt.nres-1) then
7813         j1=j+1
7814         j2=j-1
7815       else
7816         j1=j-1
7817         j2=j-2
7818       endif
7819       if (l.lt.nres-1) then
7820         l1=l+1
7821         l2=l-1
7822       else
7823         l1=l-1
7824         l2=l-2
7825       endif
7826 cd      eij=1.0d0
7827 cd      ekl=1.0d0
7828 cd      ekont=1.0d0
7829 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7830 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7831 C        summed up outside the subrouine as for the other subroutines
7832 C        handling long-range interactions. The old code is commented out
7833 C        with "cgrad" to keep track of changes.
7834       do ll=1,3
7835 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7836 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7837         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7838         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7839 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7840 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7841 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7842 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7843 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7844 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7845 c     &   gradcorr5ij,
7846 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7847 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7848 cgrad        ghalf=0.5d0*ggg1(ll)
7849 cd        ghalf=0.0d0
7850         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7851         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7852         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7853         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7854         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7855         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7856 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7857 cgrad        ghalf=0.5d0*ggg2(ll)
7858 cd        ghalf=0.0d0
7859         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7860         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7861         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7862         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7863         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7864         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7865       enddo
7866 cd      goto 1112
7867 cgrad      do m=i+1,j-1
7868 cgrad        do ll=1,3
7869 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7870 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7871 cgrad        enddo
7872 cgrad      enddo
7873 cgrad      do m=k+1,l-1
7874 cgrad        do ll=1,3
7875 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7876 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7877 cgrad        enddo
7878 cgrad      enddo
7879 c1112  continue
7880 cgrad      do m=i+2,j2
7881 cgrad        do ll=1,3
7882 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7883 cgrad        enddo
7884 cgrad      enddo
7885 cgrad      do m=k+2,l2
7886 cgrad        do ll=1,3
7887 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7888 cgrad        enddo
7889 cgrad      enddo
7890 cd      do iii=1,nres-3
7891 cd        write (2,*) iii,g_corr5_loc(iii)
7892 cd      enddo
7893       eello5=ekont*eel5
7894 cd      write (2,*) 'ekont',ekont
7895 cd      write (iout,*) 'eello5',ekont*eel5
7896       return
7897       end
7898 c--------------------------------------------------------------------------
7899       double precision function eello6(i,j,k,l,jj,kk)
7900       implicit real*8 (a-h,o-z)
7901       include 'DIMENSIONS'
7902       include 'COMMON.IOUNITS'
7903       include 'COMMON.CHAIN'
7904       include 'COMMON.DERIV'
7905       include 'COMMON.INTERACT'
7906       include 'COMMON.CONTACTS'
7907       include 'COMMON.TORSION'
7908       include 'COMMON.VAR'
7909       include 'COMMON.GEO'
7910       include 'COMMON.FFIELD'
7911       double precision ggg1(3),ggg2(3)
7912 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7913 cd        eello6=0.0d0
7914 cd        return
7915 cd      endif
7916 cd      write (iout,*)
7917 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7918 cd     &   ' and',k,l
7919       eello6_1=0.0d0
7920       eello6_2=0.0d0
7921       eello6_3=0.0d0
7922       eello6_4=0.0d0
7923       eello6_5=0.0d0
7924       eello6_6=0.0d0
7925 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7926 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7927       do iii=1,2
7928         do kkk=1,5
7929           do lll=1,3
7930             derx(lll,kkk,iii)=0.0d0
7931           enddo
7932         enddo
7933       enddo
7934 cd      eij=facont_hb(jj,i)
7935 cd      ekl=facont_hb(kk,k)
7936 cd      ekont=eij*ekl
7937 cd      eij=1.0d0
7938 cd      ekl=1.0d0
7939 cd      ekont=1.0d0
7940       if (l.eq.j+1) then
7941         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7942         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7943         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7944         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7945         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7946         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7947       else
7948         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7949         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7950         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7951         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7952         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7953           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7954         else
7955           eello6_5=0.0d0
7956         endif
7957         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7958       endif
7959 C If turn contributions are considered, they will be handled separately.
7960       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7961 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7962 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7963 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7964 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7965 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7966 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7967 cd      goto 1112
7968       if (j.lt.nres-1) then
7969         j1=j+1
7970         j2=j-1
7971       else
7972         j1=j-1
7973         j2=j-2
7974       endif
7975       if (l.lt.nres-1) then
7976         l1=l+1
7977         l2=l-1
7978       else
7979         l1=l-1
7980         l2=l-2
7981       endif
7982       do ll=1,3
7983 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7984 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7985 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7986 cgrad        ghalf=0.5d0*ggg1(ll)
7987 cd        ghalf=0.0d0
7988         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7989         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7990         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7991         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7992         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7993         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7994         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7995         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7996 cgrad        ghalf=0.5d0*ggg2(ll)
7997 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7998 cd        ghalf=0.0d0
7999         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8000         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8001         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8002         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8003         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8004         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8005       enddo
8006 cd      goto 1112
8007 cgrad      do m=i+1,j-1
8008 cgrad        do ll=1,3
8009 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8010 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8011 cgrad        enddo
8012 cgrad      enddo
8013 cgrad      do m=k+1,l-1
8014 cgrad        do ll=1,3
8015 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8016 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8017 cgrad        enddo
8018 cgrad      enddo
8019 cgrad1112  continue
8020 cgrad      do m=i+2,j2
8021 cgrad        do ll=1,3
8022 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8023 cgrad        enddo
8024 cgrad      enddo
8025 cgrad      do m=k+2,l2
8026 cgrad        do ll=1,3
8027 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8028 cgrad        enddo
8029 cgrad      enddo
8030 cd      do iii=1,nres-3
8031 cd        write (2,*) iii,g_corr6_loc(iii)
8032 cd      enddo
8033       eello6=ekont*eel6
8034 cd      write (2,*) 'ekont',ekont
8035 cd      write (iout,*) 'eello6',ekont*eel6
8036       return
8037       end
8038 c--------------------------------------------------------------------------
8039       double precision function eello6_graph1(i,j,k,l,imat,swap)
8040       implicit real*8 (a-h,o-z)
8041       include 'DIMENSIONS'
8042       include 'COMMON.IOUNITS'
8043       include 'COMMON.CHAIN'
8044       include 'COMMON.DERIV'
8045       include 'COMMON.INTERACT'
8046       include 'COMMON.CONTACTS'
8047       include 'COMMON.TORSION'
8048       include 'COMMON.VAR'
8049       include 'COMMON.GEO'
8050       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8051       logical swap
8052       logical lprn
8053       common /kutas/ lprn
8054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8055 C                                                                              C
8056 C      Parallel       Antiparallel                                             C
8057 C                                                                              C
8058 C          o             o                                                     C
8059 C         /l\           /j\                                                    C
8060 C        /   \         /   \                                                   C
8061 C       /| o |         | o |\                                                  C
8062 C     \ j|/k\|  /   \  |/k\|l /                                                C
8063 C      \ /   \ /     \ /   \ /                                                 C
8064 C       o     o       o     o                                                  C
8065 C       i             i                                                        C
8066 C                                                                              C
8067 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8068       itk=itortyp(itype(k))
8069       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8070       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8071       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8072       call transpose2(EUgC(1,1,k),auxmat(1,1))
8073       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8074       vv1(1)=pizda1(1,1)-pizda1(2,2)
8075       vv1(2)=pizda1(1,2)+pizda1(2,1)
8076       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8077       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8078       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8079       s5=scalar2(vv(1),Dtobr2(1,i))
8080 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8081       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8082       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8083      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8084      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8085      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8086      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8087      & +scalar2(vv(1),Dtobr2der(1,i)))
8088       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8089       vv1(1)=pizda1(1,1)-pizda1(2,2)
8090       vv1(2)=pizda1(1,2)+pizda1(2,1)
8091       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8092       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8093       if (l.eq.j+1) then
8094         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8095      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8096      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8097      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8098      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8099       else
8100         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8101      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8102      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8103      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8104      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8105       endif
8106       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8107       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8108       vv1(1)=pizda1(1,1)-pizda1(2,2)
8109       vv1(2)=pizda1(1,2)+pizda1(2,1)
8110       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8111      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8112      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8113      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8114       do iii=1,2
8115         if (swap) then
8116           ind=3-iii
8117         else
8118           ind=iii
8119         endif
8120         do kkk=1,5
8121           do lll=1,3
8122             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8123             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8124             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8125             call transpose2(EUgC(1,1,k),auxmat(1,1))
8126             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8127      &        pizda1(1,1))
8128             vv1(1)=pizda1(1,1)-pizda1(2,2)
8129             vv1(2)=pizda1(1,2)+pizda1(2,1)
8130             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8131             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8132      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8133             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8134      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8135             s5=scalar2(vv(1),Dtobr2(1,i))
8136             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8137           enddo
8138         enddo
8139       enddo
8140       return
8141       end
8142 c----------------------------------------------------------------------------
8143       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8144       implicit real*8 (a-h,o-z)
8145       include 'DIMENSIONS'
8146       include 'COMMON.IOUNITS'
8147       include 'COMMON.CHAIN'
8148       include 'COMMON.DERIV'
8149       include 'COMMON.INTERACT'
8150       include 'COMMON.CONTACTS'
8151       include 'COMMON.TORSION'
8152       include 'COMMON.VAR'
8153       include 'COMMON.GEO'
8154       logical swap
8155       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8156      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8157       logical lprn
8158       common /kutas/ lprn
8159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8160 C                                                                              C
8161 C      Parallel       Antiparallel                                             C
8162 C                                                                              C
8163 C          o             o                                                     C
8164 C     \   /l\           /j\   /                                                C
8165 C      \ /   \         /   \ /                                                 C
8166 C       o| o |         | o |o                                                  C
8167 C     \ j|/k\|      \  |/k\|l                                                  C
8168 C      \ /   \       \ /   \                                                   C
8169 C       o             o                                                        C
8170 C       i             i                                                        C
8171 C                                                                              C
8172 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8173 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8174 C AL 7/4/01 s1 would occur in the sixth-order moment,
8175 C           but not in a cluster cumulant
8176 #ifdef MOMENT
8177       s1=dip(1,jj,i)*dip(1,kk,k)
8178 #endif
8179       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8180       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8181       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8182       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8183       call transpose2(EUg(1,1,k),auxmat(1,1))
8184       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8185       vv(1)=pizda(1,1)-pizda(2,2)
8186       vv(2)=pizda(1,2)+pizda(2,1)
8187       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8188 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8189 #ifdef MOMENT
8190       eello6_graph2=-(s1+s2+s3+s4)
8191 #else
8192       eello6_graph2=-(s2+s3+s4)
8193 #endif
8194 c      eello6_graph2=-s3
8195 C Derivatives in gamma(i-1)
8196       if (i.gt.1) then
8197 #ifdef MOMENT
8198         s1=dipderg(1,jj,i)*dip(1,kk,k)
8199 #endif
8200         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8201         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8202         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8203         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8204 #ifdef MOMENT
8205         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8206 #else
8207         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8208 #endif
8209 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8210       endif
8211 C Derivatives in gamma(k-1)
8212 #ifdef MOMENT
8213       s1=dip(1,jj,i)*dipderg(1,kk,k)
8214 #endif
8215       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8216       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8217       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8218       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8219       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8220       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8221       vv(1)=pizda(1,1)-pizda(2,2)
8222       vv(2)=pizda(1,2)+pizda(2,1)
8223       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8224 #ifdef MOMENT
8225       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8226 #else
8227       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8228 #endif
8229 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8230 C Derivatives in gamma(j-1) or gamma(l-1)
8231       if (j.gt.1) then
8232 #ifdef MOMENT
8233         s1=dipderg(3,jj,i)*dip(1,kk,k)
8234 #endif
8235         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8236         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8237         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8238         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8239         vv(1)=pizda(1,1)-pizda(2,2)
8240         vv(2)=pizda(1,2)+pizda(2,1)
8241         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8242 #ifdef MOMENT
8243         if (swap) then
8244           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8245         else
8246           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8247         endif
8248 #endif
8249         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8250 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8251       endif
8252 C Derivatives in gamma(l-1) or gamma(j-1)
8253       if (l.gt.1) then
8254 #ifdef MOMENT
8255         s1=dip(1,jj,i)*dipderg(3,kk,k)
8256 #endif
8257         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8258         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8259         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8260         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8261         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8262         vv(1)=pizda(1,1)-pizda(2,2)
8263         vv(2)=pizda(1,2)+pizda(2,1)
8264         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8265 #ifdef MOMENT
8266         if (swap) then
8267           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8268         else
8269           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8270         endif
8271 #endif
8272         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8273 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8274       endif
8275 C Cartesian derivatives.
8276       if (lprn) then
8277         write (2,*) 'In eello6_graph2'
8278         do iii=1,2
8279           write (2,*) 'iii=',iii
8280           do kkk=1,5
8281             write (2,*) 'kkk=',kkk
8282             do jjj=1,2
8283               write (2,'(3(2f10.5),5x)')
8284      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8285             enddo
8286           enddo
8287         enddo
8288       endif
8289       do iii=1,2
8290         do kkk=1,5
8291           do lll=1,3
8292 #ifdef MOMENT
8293             if (iii.eq.1) then
8294               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8295             else
8296               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8297             endif
8298 #endif
8299             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8300      &        auxvec(1))
8301             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8302             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8303      &        auxvec(1))
8304             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8305             call transpose2(EUg(1,1,k),auxmat(1,1))
8306             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8307      &        pizda(1,1))
8308             vv(1)=pizda(1,1)-pizda(2,2)
8309             vv(2)=pizda(1,2)+pizda(2,1)
8310             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8311 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8312 #ifdef MOMENT
8313             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8314 #else
8315             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8316 #endif
8317             if (swap) then
8318               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8319             else
8320               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8321             endif
8322           enddo
8323         enddo
8324       enddo
8325       return
8326       end
8327 c----------------------------------------------------------------------------
8328       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8329       implicit real*8 (a-h,o-z)
8330       include 'DIMENSIONS'
8331       include 'COMMON.IOUNITS'
8332       include 'COMMON.CHAIN'
8333       include 'COMMON.DERIV'
8334       include 'COMMON.INTERACT'
8335       include 'COMMON.CONTACTS'
8336       include 'COMMON.TORSION'
8337       include 'COMMON.VAR'
8338       include 'COMMON.GEO'
8339       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8340       logical swap
8341 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8342 C                                                                              C
8343 C      Parallel       Antiparallel                                             C
8344 C                                                                              C
8345 C          o             o                                                     C
8346 C         /l\   /   \   /j\                                                    C
8347 C        /   \ /     \ /   \                                                   C
8348 C       /| o |o       o| o |\                                                  C
8349 C       j|/k\|  /      |/k\|l /                                                C
8350 C        /   \ /       /   \ /                                                 C
8351 C       /     o       /     o                                                  C
8352 C       i             i                                                        C
8353 C                                                                              C
8354 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8355 C
8356 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8357 C           energy moment and not to the cluster cumulant.
8358       iti=itortyp(itype(i))
8359       if (j.lt.nres-1) then
8360         itj1=itortyp(itype(j+1))
8361       else
8362         itj1=ntortyp+1
8363       endif
8364       itk=itortyp(itype(k))
8365       itk1=itortyp(itype(k+1))
8366       if (l.lt.nres-1) then
8367         itl1=itortyp(itype(l+1))
8368       else
8369         itl1=ntortyp+1
8370       endif
8371 #ifdef MOMENT
8372       s1=dip(4,jj,i)*dip(4,kk,k)
8373 #endif
8374       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8375       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8376       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8377       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8378       call transpose2(EE(1,1,itk),auxmat(1,1))
8379       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8380       vv(1)=pizda(1,1)+pizda(2,2)
8381       vv(2)=pizda(2,1)-pizda(1,2)
8382       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8383 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8384 cd     & "sum",-(s2+s3+s4)
8385 #ifdef MOMENT
8386       eello6_graph3=-(s1+s2+s3+s4)
8387 #else
8388       eello6_graph3=-(s2+s3+s4)
8389 #endif
8390 c      eello6_graph3=-s4
8391 C Derivatives in gamma(k-1)
8392       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8393       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8394       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8395       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8396 C Derivatives in gamma(l-1)
8397       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8398       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8399       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8400       vv(1)=pizda(1,1)+pizda(2,2)
8401       vv(2)=pizda(2,1)-pizda(1,2)
8402       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8403       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8404 C Cartesian derivatives.
8405       do iii=1,2
8406         do kkk=1,5
8407           do lll=1,3
8408 #ifdef MOMENT
8409             if (iii.eq.1) then
8410               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8411             else
8412               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8413             endif
8414 #endif
8415             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8416      &        auxvec(1))
8417             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8418             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8419      &        auxvec(1))
8420             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8421             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8422      &        pizda(1,1))
8423             vv(1)=pizda(1,1)+pizda(2,2)
8424             vv(2)=pizda(2,1)-pizda(1,2)
8425             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8426 #ifdef MOMENT
8427             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8428 #else
8429             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8430 #endif
8431             if (swap) then
8432               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8433             else
8434               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8435             endif
8436 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8437           enddo
8438         enddo
8439       enddo
8440       return
8441       end
8442 c----------------------------------------------------------------------------
8443       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8444       implicit real*8 (a-h,o-z)
8445       include 'DIMENSIONS'
8446       include 'COMMON.IOUNITS'
8447       include 'COMMON.CHAIN'
8448       include 'COMMON.DERIV'
8449       include 'COMMON.INTERACT'
8450       include 'COMMON.CONTACTS'
8451       include 'COMMON.TORSION'
8452       include 'COMMON.VAR'
8453       include 'COMMON.GEO'
8454       include 'COMMON.FFIELD'
8455       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8456      & auxvec1(2),auxmat1(2,2)
8457       logical swap
8458 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8459 C                                                                              C
8460 C      Parallel       Antiparallel                                             C
8461 C                                                                              C
8462 C          o             o                                                     C
8463 C         /l\   /   \   /j\                                                    C
8464 C        /   \ /     \ /   \                                                   C
8465 C       /| o |o       o| o |\                                                  C
8466 C     \ j|/k\|      \  |/k\|l                                                  C
8467 C      \ /   \       \ /   \                                                   C
8468 C       o     \       o     \                                                  C
8469 C       i             i                                                        C
8470 C                                                                              C
8471 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8472 C
8473 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8474 C           energy moment and not to the cluster cumulant.
8475 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8476       iti=itortyp(itype(i))
8477       itj=itortyp(itype(j))
8478       if (j.lt.nres-1) then
8479         itj1=itortyp(itype(j+1))
8480       else
8481         itj1=ntortyp+1
8482       endif
8483       itk=itortyp(itype(k))
8484       if (k.lt.nres-1) then
8485         itk1=itortyp(itype(k+1))
8486       else
8487         itk1=ntortyp+1
8488       endif
8489       itl=itortyp(itype(l))
8490       if (l.lt.nres-1) then
8491         itl1=itortyp(itype(l+1))
8492       else
8493         itl1=ntortyp+1
8494       endif
8495 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8496 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8497 cd     & ' itl',itl,' itl1',itl1
8498 #ifdef MOMENT
8499       if (imat.eq.1) then
8500         s1=dip(3,jj,i)*dip(3,kk,k)
8501       else
8502         s1=dip(2,jj,j)*dip(2,kk,l)
8503       endif
8504 #endif
8505       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8506       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8507       if (j.eq.l+1) then
8508         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8509         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8510       else
8511         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8512         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8513       endif
8514       call transpose2(EUg(1,1,k),auxmat(1,1))
8515       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8516       vv(1)=pizda(1,1)-pizda(2,2)
8517       vv(2)=pizda(2,1)+pizda(1,2)
8518       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8519 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8520 #ifdef MOMENT
8521       eello6_graph4=-(s1+s2+s3+s4)
8522 #else
8523       eello6_graph4=-(s2+s3+s4)
8524 #endif
8525 C Derivatives in gamma(i-1)
8526       if (i.gt.1) then
8527 #ifdef MOMENT
8528         if (imat.eq.1) then
8529           s1=dipderg(2,jj,i)*dip(3,kk,k)
8530         else
8531           s1=dipderg(4,jj,j)*dip(2,kk,l)
8532         endif
8533 #endif
8534         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8535         if (j.eq.l+1) then
8536           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8537           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8538         else
8539           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8540           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8541         endif
8542         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8543         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8544 cd          write (2,*) 'turn6 derivatives'
8545 #ifdef MOMENT
8546           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8547 #else
8548           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8549 #endif
8550         else
8551 #ifdef MOMENT
8552           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8553 #else
8554           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8555 #endif
8556         endif
8557       endif
8558 C Derivatives in gamma(k-1)
8559 #ifdef MOMENT
8560       if (imat.eq.1) then
8561         s1=dip(3,jj,i)*dipderg(2,kk,k)
8562       else
8563         s1=dip(2,jj,j)*dipderg(4,kk,l)
8564       endif
8565 #endif
8566       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8567       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8568       if (j.eq.l+1) then
8569         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8570         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8571       else
8572         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8573         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8574       endif
8575       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8576       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8577       vv(1)=pizda(1,1)-pizda(2,2)
8578       vv(2)=pizda(2,1)+pizda(1,2)
8579       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8580       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8581 #ifdef MOMENT
8582         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8583 #else
8584         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8585 #endif
8586       else
8587 #ifdef MOMENT
8588         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8589 #else
8590         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8591 #endif
8592       endif
8593 C Derivatives in gamma(j-1) or gamma(l-1)
8594       if (l.eq.j+1 .and. l.gt.1) then
8595         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8596         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8597         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8598         vv(1)=pizda(1,1)-pizda(2,2)
8599         vv(2)=pizda(2,1)+pizda(1,2)
8600         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8601         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8602       else if (j.gt.1) then
8603         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8604         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8605         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8606         vv(1)=pizda(1,1)-pizda(2,2)
8607         vv(2)=pizda(2,1)+pizda(1,2)
8608         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8609         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8610           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8611         else
8612           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8613         endif
8614       endif
8615 C Cartesian derivatives.
8616       do iii=1,2
8617         do kkk=1,5
8618           do lll=1,3
8619 #ifdef MOMENT
8620             if (iii.eq.1) then
8621               if (imat.eq.1) then
8622                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8623               else
8624                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8625               endif
8626             else
8627               if (imat.eq.1) then
8628                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8629               else
8630                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8631               endif
8632             endif
8633 #endif
8634             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8635      &        auxvec(1))
8636             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8637             if (j.eq.l+1) then
8638               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8639      &          b1(1,j+1),auxvec(1))
8640               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8641             else
8642               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8643      &          b1(1,l+1),auxvec(1))
8644               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8645             endif
8646             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8647      &        pizda(1,1))
8648             vv(1)=pizda(1,1)-pizda(2,2)
8649             vv(2)=pizda(2,1)+pizda(1,2)
8650             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8651             if (swap) then
8652               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8653 #ifdef MOMENT
8654                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8655      &             -(s1+s2+s4)
8656 #else
8657                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8658      &             -(s2+s4)
8659 #endif
8660                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8661               else
8662 #ifdef MOMENT
8663                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8664 #else
8665                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8666 #endif
8667                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8668               endif
8669             else
8670 #ifdef MOMENT
8671               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8672 #else
8673               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8674 #endif
8675               if (l.eq.j+1) then
8676                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8677               else
8678                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8679               endif
8680             endif
8681           enddo
8682         enddo
8683       enddo
8684       return
8685       end
8686 c----------------------------------------------------------------------------
8687       double precision function eello_turn6(i,jj,kk)
8688       implicit real*8 (a-h,o-z)
8689       include 'DIMENSIONS'
8690       include 'COMMON.IOUNITS'
8691       include 'COMMON.CHAIN'
8692       include 'COMMON.DERIV'
8693       include 'COMMON.INTERACT'
8694       include 'COMMON.CONTACTS'
8695       include 'COMMON.TORSION'
8696       include 'COMMON.VAR'
8697       include 'COMMON.GEO'
8698       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8699      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8700      &  ggg1(3),ggg2(3)
8701       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8702      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8703 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8704 C           the respective energy moment and not to the cluster cumulant.
8705       s1=0.0d0
8706       s8=0.0d0
8707       s13=0.0d0
8708 c
8709       eello_turn6=0.0d0
8710       j=i+4
8711       k=i+1
8712       l=i+3
8713       iti=itortyp(itype(i))
8714       itk=itortyp(itype(k))
8715       itk1=itortyp(itype(k+1))
8716       itl=itortyp(itype(l))
8717       itj=itortyp(itype(j))
8718 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8719 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8720 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8721 cd        eello6=0.0d0
8722 cd        return
8723 cd      endif
8724 cd      write (iout,*)
8725 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8726 cd     &   ' and',k,l
8727 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8728       do iii=1,2
8729         do kkk=1,5
8730           do lll=1,3
8731             derx_turn(lll,kkk,iii)=0.0d0
8732           enddo
8733         enddo
8734       enddo
8735 cd      eij=1.0d0
8736 cd      ekl=1.0d0
8737 cd      ekont=1.0d0
8738       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8739 cd      eello6_5=0.0d0
8740 cd      write (2,*) 'eello6_5',eello6_5
8741 #ifdef MOMENT
8742       call transpose2(AEA(1,1,1),auxmat(1,1))
8743       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8744       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8745       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8746 #endif
8747       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8748       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8749       s2 = scalar2(b1(1,k),vtemp1(1))
8750 #ifdef MOMENT
8751       call transpose2(AEA(1,1,2),atemp(1,1))
8752       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8753       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8754       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8755 #endif
8756       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8757       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8758       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8759 #ifdef MOMENT
8760       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8761       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8762       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8763       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8764       ss13 = scalar2(b1(1,k),vtemp4(1))
8765       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8766 #endif
8767 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8768 c      s1=0.0d0
8769 c      s2=0.0d0
8770 c      s8=0.0d0
8771 c      s12=0.0d0
8772 c      s13=0.0d0
8773       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8774 C Derivatives in gamma(i+2)
8775       s1d =0.0d0
8776       s8d =0.0d0
8777 #ifdef MOMENT
8778       call transpose2(AEA(1,1,1),auxmatd(1,1))
8779       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8780       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8781       call transpose2(AEAderg(1,1,2),atempd(1,1))
8782       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8783       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8784 #endif
8785       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8786       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8787       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8788 c      s1d=0.0d0
8789 c      s2d=0.0d0
8790 c      s8d=0.0d0
8791 c      s12d=0.0d0
8792 c      s13d=0.0d0
8793       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8794 C Derivatives in gamma(i+3)
8795 #ifdef MOMENT
8796       call transpose2(AEA(1,1,1),auxmatd(1,1))
8797       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8798       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8799       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8800 #endif
8801       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8802       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8803       s2d = scalar2(b1(1,k),vtemp1d(1))
8804 #ifdef MOMENT
8805       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8806       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8807 #endif
8808       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8809 #ifdef MOMENT
8810       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8811       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8812       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8813 #endif
8814 c      s1d=0.0d0
8815 c      s2d=0.0d0
8816 c      s8d=0.0d0
8817 c      s12d=0.0d0
8818 c      s13d=0.0d0
8819 #ifdef MOMENT
8820       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8821      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8822 #else
8823       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8824      &               -0.5d0*ekont*(s2d+s12d)
8825 #endif
8826 C Derivatives in gamma(i+4)
8827       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8828       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8829       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8830 #ifdef MOMENT
8831       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8832       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8833       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8834 #endif
8835 c      s1d=0.0d0
8836 c      s2d=0.0d0
8837 c      s8d=0.0d0
8838 C      s12d=0.0d0
8839 c      s13d=0.0d0
8840 #ifdef MOMENT
8841       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8842 #else
8843       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8844 #endif
8845 C Derivatives in gamma(i+5)
8846 #ifdef MOMENT
8847       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8848       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8849       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8850 #endif
8851       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8852       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8853       s2d = scalar2(b1(1,k),vtemp1d(1))
8854 #ifdef MOMENT
8855       call transpose2(AEA(1,1,2),atempd(1,1))
8856       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8857       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8858 #endif
8859       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8860       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8861 #ifdef MOMENT
8862       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8863       ss13d = scalar2(b1(1,k),vtemp4d(1))
8864       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8865 #endif
8866 c      s1d=0.0d0
8867 c      s2d=0.0d0
8868 c      s8d=0.0d0
8869 c      s12d=0.0d0
8870 c      s13d=0.0d0
8871 #ifdef MOMENT
8872       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8873      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8874 #else
8875       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8876      &               -0.5d0*ekont*(s2d+s12d)
8877 #endif
8878 C Cartesian derivatives
8879       do iii=1,2
8880         do kkk=1,5
8881           do lll=1,3
8882 #ifdef MOMENT
8883             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8884             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8885             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8886 #endif
8887             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8888             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8889      &          vtemp1d(1))
8890             s2d = scalar2(b1(1,k),vtemp1d(1))
8891 #ifdef MOMENT
8892             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8893             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8894             s8d = -(atempd(1,1)+atempd(2,2))*
8895      &           scalar2(cc(1,1,itl),vtemp2(1))
8896 #endif
8897             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8898      &           auxmatd(1,1))
8899             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8900             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8901 c      s1d=0.0d0
8902 c      s2d=0.0d0
8903 c      s8d=0.0d0
8904 c      s12d=0.0d0
8905 c      s13d=0.0d0
8906 #ifdef MOMENT
8907             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8908      &        - 0.5d0*(s1d+s2d)
8909 #else
8910             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8911      &        - 0.5d0*s2d
8912 #endif
8913 #ifdef MOMENT
8914             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8915      &        - 0.5d0*(s8d+s12d)
8916 #else
8917             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8918      &        - 0.5d0*s12d
8919 #endif
8920           enddo
8921         enddo
8922       enddo
8923 #ifdef MOMENT
8924       do kkk=1,5
8925         do lll=1,3
8926           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8927      &      achuj_tempd(1,1))
8928           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8929           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8930           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8931           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8932           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8933      &      vtemp4d(1))
8934           ss13d = scalar2(b1(1,k),vtemp4d(1))
8935           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8936           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8937         enddo
8938       enddo
8939 #endif
8940 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8941 cd     &  16*eel_turn6_num
8942 cd      goto 1112
8943       if (j.lt.nres-1) then
8944         j1=j+1
8945         j2=j-1
8946       else
8947         j1=j-1
8948         j2=j-2
8949       endif
8950       if (l.lt.nres-1) then
8951         l1=l+1
8952         l2=l-1
8953       else
8954         l1=l-1
8955         l2=l-2
8956       endif
8957       do ll=1,3
8958 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8959 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8960 cgrad        ghalf=0.5d0*ggg1(ll)
8961 cd        ghalf=0.0d0
8962         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8963         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8964         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8965      &    +ekont*derx_turn(ll,2,1)
8966         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8967         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8968      &    +ekont*derx_turn(ll,4,1)
8969         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8970         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8971         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8972 cgrad        ghalf=0.5d0*ggg2(ll)
8973 cd        ghalf=0.0d0
8974         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8975      &    +ekont*derx_turn(ll,2,2)
8976         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8977         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8978      &    +ekont*derx_turn(ll,4,2)
8979         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8980         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8981         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8982       enddo
8983 cd      goto 1112
8984 cgrad      do m=i+1,j-1
8985 cgrad        do ll=1,3
8986 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8987 cgrad        enddo
8988 cgrad      enddo
8989 cgrad      do m=k+1,l-1
8990 cgrad        do ll=1,3
8991 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8992 cgrad        enddo
8993 cgrad      enddo
8994 cgrad1112  continue
8995 cgrad      do m=i+2,j2
8996 cgrad        do ll=1,3
8997 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8998 cgrad        enddo
8999 cgrad      enddo
9000 cgrad      do m=k+2,l2
9001 cgrad        do ll=1,3
9002 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9003 cgrad        enddo
9004 cgrad      enddo
9005 cd      do iii=1,nres-3
9006 cd        write (2,*) iii,g_corr6_loc(iii)
9007 cd      enddo
9008       eello_turn6=ekont*eel_turn6
9009 cd      write (2,*) 'ekont',ekont
9010 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9011       return
9012       end
9013
9014 C-----------------------------------------------------------------------------
9015       double precision function scalar(u,v)
9016 !DIR$ INLINEALWAYS scalar
9017 #ifndef OSF
9018 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9019 #endif
9020       implicit none
9021       double precision u(3),v(3)
9022 cd      double precision sc
9023 cd      integer i
9024 cd      sc=0.0d0
9025 cd      do i=1,3
9026 cd        sc=sc+u(i)*v(i)
9027 cd      enddo
9028 cd      scalar=sc
9029
9030       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9031       return
9032       end
9033 crc-------------------------------------------------
9034       SUBROUTINE MATVEC2(A1,V1,V2)
9035 !DIR$ INLINEALWAYS MATVEC2
9036 #ifndef OSF
9037 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9038 #endif
9039       implicit real*8 (a-h,o-z)
9040       include 'DIMENSIONS'
9041       DIMENSION A1(2,2),V1(2),V2(2)
9042 c      DO 1 I=1,2
9043 c        VI=0.0
9044 c        DO 3 K=1,2
9045 c    3     VI=VI+A1(I,K)*V1(K)
9046 c        Vaux(I)=VI
9047 c    1 CONTINUE
9048
9049       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9050       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9051
9052       v2(1)=vaux1
9053       v2(2)=vaux2
9054       END
9055 C---------------------------------------
9056       SUBROUTINE MATMAT2(A1,A2,A3)
9057 #ifndef OSF
9058 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9059 #endif
9060       implicit real*8 (a-h,o-z)
9061       include 'DIMENSIONS'
9062       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9063 c      DIMENSION AI3(2,2)
9064 c        DO  J=1,2
9065 c          A3IJ=0.0
9066 c          DO K=1,2
9067 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9068 c          enddo
9069 c          A3(I,J)=A3IJ
9070 c       enddo
9071 c      enddo
9072
9073       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9074       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9075       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9076       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9077
9078       A3(1,1)=AI3_11
9079       A3(2,1)=AI3_21
9080       A3(1,2)=AI3_12
9081       A3(2,2)=AI3_22
9082       END
9083
9084 c-------------------------------------------------------------------------
9085       double precision function scalar2(u,v)
9086 !DIR$ INLINEALWAYS scalar2
9087       implicit none
9088       double precision u(2),v(2)
9089       double precision sc
9090       integer i
9091       scalar2=u(1)*v(1)+u(2)*v(2)
9092       return
9093       end
9094
9095 C-----------------------------------------------------------------------------
9096
9097       subroutine transpose2(a,at)
9098 !DIR$ INLINEALWAYS transpose2
9099 #ifndef OSF
9100 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9101 #endif
9102       implicit none
9103       double precision a(2,2),at(2,2)
9104       at(1,1)=a(1,1)
9105       at(1,2)=a(2,1)
9106       at(2,1)=a(1,2)
9107       at(2,2)=a(2,2)
9108       return
9109       end
9110 c--------------------------------------------------------------------------
9111       subroutine transpose(n,a,at)
9112       implicit none
9113       integer n,i,j
9114       double precision a(n,n),at(n,n)
9115       do i=1,n
9116         do j=1,n
9117           at(j,i)=a(i,j)
9118         enddo
9119       enddo
9120       return
9121       end
9122 C---------------------------------------------------------------------------
9123       subroutine prodmat3(a1,a2,kk,transp,prod)
9124 !DIR$ INLINEALWAYS prodmat3
9125 #ifndef OSF
9126 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9127 #endif
9128       implicit none
9129       integer i,j
9130       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9131       logical transp
9132 crc      double precision auxmat(2,2),prod_(2,2)
9133
9134       if (transp) then
9135 crc        call transpose2(kk(1,1),auxmat(1,1))
9136 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9137 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9138
9139            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9140      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9141            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9142      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9143            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9144      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9145            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9146      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9147
9148       else
9149 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9150 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9151
9152            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9153      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9154            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9155      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9156            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9157      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9158            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9159      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9160
9161       endif
9162 c      call transpose2(a2(1,1),a2t(1,1))
9163
9164 crc      print *,transp
9165 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9166 crc      print *,((prod(i,j),i=1,2),j=1,2)
9167
9168       return
9169       end
9170