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 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.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 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 c#define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 c#undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 c#define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 c#undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423
1424 c      write(iout,*) "Jestem w egb(evdw)"
1425
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         if (itypi.eq.ntyp1) cycle
1436         itypi1=iabs(itype(i+1))
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1446 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1447 C
1448 C Calculate SC interaction energy.
1449 C
1450         do iint=1,nint_gr(i)
1451           do j=istart(i,iint),iend(i,iint)
1452             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1453
1454 c              write(iout,*) "PRZED ZWYKLE", evdwij
1455               call dyn_ssbond_ene(i,j,evdwij)
1456 c              write(iout,*) "PO ZWYKLE", evdwij
1457
1458               evdw=evdw+evdwij
1459               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1460      &                        'evdw',i,j,evdwij,' ss'
1461 C triple bond artifac removal
1462              do k=j+1,iend(i,iint)
1463 C search over all next residues
1464               if (dyn_ss_mask(k)) then
1465 C check if they are cysteins
1466 C              write(iout,*) 'k=',k
1467
1468 c              write(iout,*) "PRZED TRI", evdwij
1469                evdwij_przed_tri=evdwij
1470               call triple_ssbond_ene(i,j,k,evdwij)
1471 c               if(evdwij_przed_tri.ne.evdwij) then
1472 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1473 c               endif
1474
1475 c              write(iout,*) "PO TRI", evdwij
1476 C call the energy function that removes the artifical triple disulfide
1477 C bond the soubroutine is located in ssMD.F
1478               evdw=evdw+evdwij
1479               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1480      &                        'evdw',i,j,evdwij,'tss'
1481               endif!dyn_ss_mask(k)
1482              enddo! k
1483             ELSE
1484             ind=ind+1
1485             itypj=iabs(itype(j))
1486             if (itypj.eq.ntyp1) cycle
1487 c            dscj_inv=dsc_inv(itypj)
1488             dscj_inv=vbld_inv(j+nres)
1489 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1490 c     &       1.0d0/vbld(j+nres)
1491 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1492             sig0ij=sigma(itypi,itypj)
1493             chi1=chi(itypi,itypj)
1494             chi2=chi(itypj,itypi)
1495             chi12=chi1*chi2
1496             chip1=chip(itypi)
1497             chip2=chip(itypj)
1498             chip12=chip1*chip2
1499             alf1=alp(itypi)
1500             alf2=alp(itypj)
1501             alf12=0.5D0*(alf1+alf2)
1502 C For diagnostics only!!!
1503 c           chi1=0.0D0
1504 c           chi2=0.0D0
1505 c           chi12=0.0D0
1506 c           chip1=0.0D0
1507 c           chip2=0.0D0
1508 c           chip12=0.0D0
1509 c           alf1=0.0D0
1510 c           alf2=0.0D0
1511 c           alf12=0.0D0
1512             xj=c(1,nres+j)-xi
1513             yj=c(2,nres+j)-yi
1514             zj=c(3,nres+j)-zi
1515             dxj=dc_norm(1,nres+j)
1516             dyj=dc_norm(2,nres+j)
1517             dzj=dc_norm(3,nres+j)
1518 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1519 c            write (iout,*) "j",j," dc_norm",
1520 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1521             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1522             rij=dsqrt(rrij)
1523 C Calculate angle-dependent terms of energy and contributions to their
1524 C derivatives.
1525             call sc_angular
1526             sigsq=1.0D0/sigsq
1527             sig=sig0ij*dsqrt(sigsq)
1528             rij_shift=1.0D0/rij-sig+sig0ij
1529 c for diagnostics; uncomment
1530 c            rij_shift=1.2*sig0ij
1531 C I hate to put IF's in the loops, but here don't have another choice!!!!
1532             if (rij_shift.le.0.0D0) then
1533               evdw=1.0D20
1534 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1535 cd     &        restyp(itypi),i,restyp(itypj),j,
1536 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1537               return
1538             endif
1539             sigder=-sig*sigsq
1540 c---------------------------------------------------------------
1541             rij_shift=1.0D0/rij_shift
1542             fac=rij_shift**expon
1543             e1=fac*fac*aa(itypi,itypj)
1544             e2=fac*bb(itypi,itypj)
1545             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1546             eps2der=evdwij*eps3rt
1547             eps3der=evdwij*eps2rt
1548 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1549 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1550             evdwij=evdwij*eps2rt*eps3rt
1551             evdw=evdw+evdwij
1552             if (lprn) then
1553             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1554             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1555             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1556      &        restyp(itypi),i,restyp(itypj),j,
1557      &        epsi,sigm,chi1,chi2,chip1,chip2,
1558      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1559      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1560      &        evdwij
1561             endif
1562
1563             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1564      &                        'evdw',i,j,evdwij
1565
1566 C Calculate gradient components.
1567             e1=e1*eps1*eps2rt**2*eps3rt**2
1568             fac=-expon*(e1+evdwij)*rij_shift
1569             sigder=fac*sigder
1570             fac=rij*fac
1571 c            fac=0.0d0
1572 C Calculate the radial part of the gradient
1573             gg(1)=xj*fac
1574             gg(2)=yj*fac
1575             gg(3)=zj*fac
1576 C Calculate angular part of the gradient.
1577             call sc_grad
1578             ENDIF    ! dyn_ss
1579           enddo      ! j
1580         enddo        ! iint
1581       enddo          ! i
1582 c      write (iout,*) "Number of loop steps in EGB:",ind
1583 cccc      energy_dec=.false.
1584       return
1585       end
1586 C-----------------------------------------------------------------------------
1587       subroutine egbv(evdw)
1588 C
1589 C This subroutine calculates the interaction energy of nonbonded side chains
1590 C assuming the Gay-Berne-Vorobjev potential of interaction.
1591 C
1592       implicit real*8 (a-h,o-z)
1593       include 'DIMENSIONS'
1594       include 'COMMON.GEO'
1595       include 'COMMON.VAR'
1596       include 'COMMON.LOCAL'
1597       include 'COMMON.CHAIN'
1598       include 'COMMON.DERIV'
1599       include 'COMMON.NAMES'
1600       include 'COMMON.INTERACT'
1601       include 'COMMON.IOUNITS'
1602       include 'COMMON.CALC'
1603       common /srutu/ icall
1604       logical lprn
1605       evdw=0.0D0
1606 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1607       evdw=0.0D0
1608       lprn=.false.
1609 c     if (icall.eq.0) lprn=.true.
1610       ind=0
1611       do i=iatsc_s,iatsc_e
1612         itypi=iabs(itype(i))
1613         if (itypi.eq.ntyp1) cycle
1614         itypi1=iabs(itype(i+1))
1615         xi=c(1,nres+i)
1616         yi=c(2,nres+i)
1617         zi=c(3,nres+i)
1618         dxi=dc_norm(1,nres+i)
1619         dyi=dc_norm(2,nres+i)
1620         dzi=dc_norm(3,nres+i)
1621 c        dsci_inv=dsc_inv(itypi)
1622         dsci_inv=vbld_inv(i+nres)
1623 C
1624 C Calculate SC interaction energy.
1625 C
1626         do iint=1,nint_gr(i)
1627           do j=istart(i,iint),iend(i,iint)
1628             ind=ind+1
1629             itypj=iabs(itype(j))
1630             if (itypj.eq.ntyp1) cycle
1631 c            dscj_inv=dsc_inv(itypj)
1632             dscj_inv=vbld_inv(j+nres)
1633             sig0ij=sigma(itypi,itypj)
1634             r0ij=r0(itypi,itypj)
1635             chi1=chi(itypi,itypj)
1636             chi2=chi(itypj,itypi)
1637             chi12=chi1*chi2
1638             chip1=chip(itypi)
1639             chip2=chip(itypj)
1640             chip12=chip1*chip2
1641             alf1=alp(itypi)
1642             alf2=alp(itypj)
1643             alf12=0.5D0*(alf1+alf2)
1644 C For diagnostics only!!!
1645 c           chi1=0.0D0
1646 c           chi2=0.0D0
1647 c           chi12=0.0D0
1648 c           chip1=0.0D0
1649 c           chip2=0.0D0
1650 c           chip12=0.0D0
1651 c           alf1=0.0D0
1652 c           alf2=0.0D0
1653 c           alf12=0.0D0
1654             xj=c(1,nres+j)-xi
1655             yj=c(2,nres+j)-yi
1656             zj=c(3,nres+j)-zi
1657             dxj=dc_norm(1,nres+j)
1658             dyj=dc_norm(2,nres+j)
1659             dzj=dc_norm(3,nres+j)
1660             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1661             rij=dsqrt(rrij)
1662 C Calculate angle-dependent terms of energy and contributions to their
1663 C derivatives.
1664             call sc_angular
1665             sigsq=1.0D0/sigsq
1666             sig=sig0ij*dsqrt(sigsq)
1667             rij_shift=1.0D0/rij-sig+r0ij
1668 C I hate to put IF's in the loops, but here don't have another choice!!!!
1669             if (rij_shift.le.0.0D0) then
1670               evdw=1.0D20
1671               return
1672             endif
1673             sigder=-sig*sigsq
1674 c---------------------------------------------------------------
1675             rij_shift=1.0D0/rij_shift
1676             fac=rij_shift**expon
1677             e1=fac*fac*aa(itypi,itypj)
1678             e2=fac*bb(itypi,itypj)
1679             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1680             eps2der=evdwij*eps3rt
1681             eps3der=evdwij*eps2rt
1682             fac_augm=rrij**expon
1683             e_augm=augm(itypi,itypj)*fac_augm
1684             evdwij=evdwij*eps2rt*eps3rt
1685             evdw=evdw+evdwij+e_augm
1686             if (lprn) then
1687             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690      &        restyp(itypi),i,restyp(itypj),j,
1691      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1692      &        chi1,chi2,chip1,chip2,
1693      &        eps1,eps2rt**2,eps3rt**2,
1694      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1695      &        evdwij+e_augm
1696             endif
1697 C Calculate gradient components.
1698             e1=e1*eps1*eps2rt**2*eps3rt**2
1699             fac=-expon*(e1+evdwij)*rij_shift
1700             sigder=fac*sigder
1701             fac=rij*fac-2*expon*rrij*e_augm
1702 C Calculate the radial part of the gradient
1703             gg(1)=xj*fac
1704             gg(2)=yj*fac
1705             gg(3)=zj*fac
1706 C Calculate angular part of the gradient.
1707             call sc_grad
1708           enddo      ! j
1709         enddo        ! iint
1710       enddo          ! i
1711       end
1712 C-----------------------------------------------------------------------------
1713       subroutine sc_angular
1714 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1715 C om12. Called by ebp, egb, and egbv.
1716       implicit none
1717       include 'COMMON.CALC'
1718       include 'COMMON.IOUNITS'
1719       erij(1)=xj*rij
1720       erij(2)=yj*rij
1721       erij(3)=zj*rij
1722       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1723       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1724       om12=dxi*dxj+dyi*dyj+dzi*dzj
1725       chiom12=chi12*om12
1726 C Calculate eps1(om12) and its derivative in om12
1727       faceps1=1.0D0-om12*chiom12
1728       faceps1_inv=1.0D0/faceps1
1729       eps1=dsqrt(faceps1_inv)
1730 C Following variable is eps1*deps1/dom12
1731       eps1_om12=faceps1_inv*chiom12
1732 c diagnostics only
1733 c      faceps1_inv=om12
1734 c      eps1=om12
1735 c      eps1_om12=1.0d0
1736 c      write (iout,*) "om12",om12," eps1",eps1
1737 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1738 C and om12.
1739       om1om2=om1*om2
1740       chiom1=chi1*om1
1741       chiom2=chi2*om2
1742       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1743       sigsq=1.0D0-facsig*faceps1_inv
1744       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1745       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1746       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1747 c diagnostics only
1748 c      sigsq=1.0d0
1749 c      sigsq_om1=0.0d0
1750 c      sigsq_om2=0.0d0
1751 c      sigsq_om12=0.0d0
1752 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1753 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1754 c     &    " eps1",eps1
1755 C Calculate eps2 and its derivatives in om1, om2, and om12.
1756       chipom1=chip1*om1
1757       chipom2=chip2*om2
1758       chipom12=chip12*om12
1759       facp=1.0D0-om12*chipom12
1760       facp_inv=1.0D0/facp
1761       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1762 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1763 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1764 C Following variable is the square root of eps2
1765       eps2rt=1.0D0-facp1*facp_inv
1766 C Following three variables are the derivatives of the square root of eps
1767 C in om1, om2, and om12.
1768       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1769       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1770       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1771 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1772       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1773 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1774 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1775 c     &  " eps2rt_om12",eps2rt_om12
1776 C Calculate whole angle-dependent part of epsilon and contributions
1777 C to its derivatives
1778       return
1779       end
1780 C----------------------------------------------------------------------------
1781       subroutine sc_grad
1782       implicit real*8 (a-h,o-z)
1783       include 'DIMENSIONS'
1784       include 'COMMON.CHAIN'
1785       include 'COMMON.DERIV'
1786       include 'COMMON.CALC'
1787       include 'COMMON.IOUNITS'
1788       double precision dcosom1(3),dcosom2(3)
1789       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1790       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1791       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1792      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1793 c diagnostics only
1794 c      eom1=0.0d0
1795 c      eom2=0.0d0
1796 c      eom12=evdwij*eps1_om12
1797 c end diagnostics
1798 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1799 c     &  " sigder",sigder
1800 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1801 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1802       do k=1,3
1803         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1804         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1805       enddo
1806       do k=1,3
1807         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1808       enddo
1809 c      write (iout,*) "gg",(gg(k),k=1,3)
1810       do k=1,3
1811         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1812      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1813      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1814         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1815      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1816      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1817 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1818 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1819 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1820 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1821       enddo
1822 C
1823 C Calculate the components of the gradient in DC and X
1824 C
1825 cgrad      do k=i,j-1
1826 cgrad        do l=1,3
1827 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1828 cgrad        enddo
1829 cgrad      enddo
1830       do l=1,3
1831         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1832         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1833       enddo
1834       return
1835       end
1836 C-----------------------------------------------------------------------
1837       subroutine e_softsphere(evdw)
1838 C
1839 C This subroutine calculates the interaction energy of nonbonded side chains
1840 C assuming the LJ potential of interaction.
1841 C
1842       implicit real*8 (a-h,o-z)
1843       include 'DIMENSIONS'
1844       parameter (accur=1.0d-10)
1845       include 'COMMON.GEO'
1846       include 'COMMON.VAR'
1847       include 'COMMON.LOCAL'
1848       include 'COMMON.CHAIN'
1849       include 'COMMON.DERIV'
1850       include 'COMMON.INTERACT'
1851       include 'COMMON.TORSION'
1852       include 'COMMON.SBRIDGE'
1853       include 'COMMON.NAMES'
1854       include 'COMMON.IOUNITS'
1855       include 'COMMON.CONTACTS'
1856       dimension gg(3)
1857 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1858       evdw=0.0D0
1859       do i=iatsc_s,iatsc_e
1860         itypi=iabs(itype(i))
1861         if (itypi.eq.ntyp1) cycle
1862         itypi1=iabs(itype(i+1))
1863         xi=c(1,nres+i)
1864         yi=c(2,nres+i)
1865         zi=c(3,nres+i)
1866 C
1867 C Calculate SC interaction energy.
1868 C
1869         do iint=1,nint_gr(i)
1870 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1871 cd   &                  'iend=',iend(i,iint)
1872           do j=istart(i,iint),iend(i,iint)
1873             itypj=iabs(itype(j))
1874             if (itypj.eq.ntyp1) cycle
1875             xj=c(1,nres+j)-xi
1876             yj=c(2,nres+j)-yi
1877             zj=c(3,nres+j)-zi
1878             rij=xj*xj+yj*yj+zj*zj
1879 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1880             r0ij=r0(itypi,itypj)
1881             r0ijsq=r0ij*r0ij
1882 c            print *,i,j,r0ij,dsqrt(rij)
1883             if (rij.lt.r0ijsq) then
1884               evdwij=0.25d0*(rij-r0ijsq)**2
1885               fac=rij-r0ijsq
1886             else
1887               evdwij=0.0d0
1888               fac=0.0d0
1889             endif
1890             evdw=evdw+evdwij
1891 C
1892 C Calculate the components of the gradient in DC and X
1893 C
1894             gg(1)=xj*fac
1895             gg(2)=yj*fac
1896             gg(3)=zj*fac
1897             do k=1,3
1898               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1899               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1900               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1901               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1902             enddo
1903 cgrad            do k=i,j-1
1904 cgrad              do l=1,3
1905 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad              enddo
1907 cgrad            enddo
1908           enddo ! j
1909         enddo ! iint
1910       enddo ! i
1911       return
1912       end
1913 C--------------------------------------------------------------------------
1914       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1915      &              eello_turn4)
1916 C
1917 C Soft-sphere potential of p-p interaction
1918 C
1919       implicit real*8 (a-h,o-z)
1920       include 'DIMENSIONS'
1921       include 'COMMON.CONTROL'
1922       include 'COMMON.IOUNITS'
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.CONTACTS'
1930       include 'COMMON.TORSION'
1931       include 'COMMON.VECTORS'
1932       include 'COMMON.FFIELD'
1933       dimension ggg(3)
1934 cd      write(iout,*) 'In EELEC_soft_sphere'
1935       ees=0.0D0
1936       evdw1=0.0D0
1937       eel_loc=0.0d0
1938       eello_turn3=0.0d0
1939       eello_turn4=0.0d0
1940       ind=0
1941       do i=iatel_s,iatel_e
1942         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1943         dxi=dc(1,i)
1944         dyi=dc(2,i)
1945         dzi=dc(3,i)
1946         xmedi=c(1,i)+0.5d0*dxi
1947         ymedi=c(2,i)+0.5d0*dyi
1948         zmedi=c(3,i)+0.5d0*dzi
1949         num_conti=0
1950 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1951         do j=ielstart(i),ielend(i)
1952           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1953           ind=ind+1
1954           iteli=itel(i)
1955           itelj=itel(j)
1956           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1957           r0ij=rpp(iteli,itelj)
1958           r0ijsq=r0ij*r0ij
1959           dxj=dc(1,j)
1960           dyj=dc(2,j)
1961           dzj=dc(3,j)
1962           xj=c(1,j)+0.5D0*dxj-xmedi
1963           yj=c(2,j)+0.5D0*dyj-ymedi
1964           zj=c(3,j)+0.5D0*dzj-zmedi
1965           rij=xj*xj+yj*yj+zj*zj
1966           if (rij.lt.r0ijsq) then
1967             evdw1ij=0.25d0*(rij-r0ijsq)**2
1968             fac=rij-r0ijsq
1969           else
1970             evdw1ij=0.0d0
1971             fac=0.0d0
1972           endif
1973           evdw1=evdw1+evdw1ij
1974 C
1975 C Calculate contributions to the Cartesian gradient.
1976 C
1977           ggg(1)=fac*xj
1978           ggg(2)=fac*yj
1979           ggg(3)=fac*zj
1980           do k=1,3
1981             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1982             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1983           enddo
1984 *
1985 * Loop over residues i+1 thru j-1.
1986 *
1987 cgrad          do k=i+1,j-1
1988 cgrad            do l=1,3
1989 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1990 cgrad            enddo
1991 cgrad          enddo
1992         enddo ! j
1993       enddo   ! i
1994 cgrad      do i=nnt,nct-1
1995 cgrad        do k=1,3
1996 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1997 cgrad        enddo
1998 cgrad        do j=i+1,nct-1
1999 cgrad          do k=1,3
2000 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2001 cgrad          enddo
2002 cgrad        enddo
2003 cgrad      enddo
2004       return
2005       end
2006 c------------------------------------------------------------------------------
2007       subroutine vec_and_deriv
2008       implicit real*8 (a-h,o-z)
2009       include 'DIMENSIONS'
2010 #ifdef MPI
2011       include 'mpif.h'
2012 #endif
2013       include 'COMMON.IOUNITS'
2014       include 'COMMON.GEO'
2015       include 'COMMON.VAR'
2016       include 'COMMON.LOCAL'
2017       include 'COMMON.CHAIN'
2018       include 'COMMON.VECTORS'
2019       include 'COMMON.SETUP'
2020       include 'COMMON.TIME1'
2021       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2022 C Compute the local reference systems. For reference system (i), the
2023 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2024 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2025 #ifdef PARVEC
2026       do i=ivec_start,ivec_end
2027 #else
2028       do i=1,nres-1
2029 #endif
2030           if (i.eq.nres-1) then
2031 C Case of the last full residue
2032 C Compute the Z-axis
2033             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2034             costh=dcos(pi-theta(nres))
2035             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2036             do k=1,3
2037               uz(k,i)=fac*uz(k,i)
2038             enddo
2039 C Compute the derivatives of uz
2040             uzder(1,1,1)= 0.0d0
2041             uzder(2,1,1)=-dc_norm(3,i-1)
2042             uzder(3,1,1)= dc_norm(2,i-1)
2043             uzder(1,2,1)= dc_norm(3,i-1)
2044             uzder(2,2,1)= 0.0d0
2045             uzder(3,2,1)=-dc_norm(1,i-1)
2046             uzder(1,3,1)=-dc_norm(2,i-1)
2047             uzder(2,3,1)= dc_norm(1,i-1)
2048             uzder(3,3,1)= 0.0d0
2049             uzder(1,1,2)= 0.0d0
2050             uzder(2,1,2)= dc_norm(3,i)
2051             uzder(3,1,2)=-dc_norm(2,i)
2052             uzder(1,2,2)=-dc_norm(3,i)
2053             uzder(2,2,2)= 0.0d0
2054             uzder(3,2,2)= dc_norm(1,i)
2055             uzder(1,3,2)= dc_norm(2,i)
2056             uzder(2,3,2)=-dc_norm(1,i)
2057             uzder(3,3,2)= 0.0d0
2058 C Compute the Y-axis
2059             facy=fac
2060             do k=1,3
2061               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2062             enddo
2063 C Compute the derivatives of uy
2064             do j=1,3
2065               do k=1,3
2066                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2067      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2068                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2069               enddo
2070               uyder(j,j,1)=uyder(j,j,1)-costh
2071               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2072             enddo
2073             do j=1,2
2074               do k=1,3
2075                 do l=1,3
2076                   uygrad(l,k,j,i)=uyder(l,k,j)
2077                   uzgrad(l,k,j,i)=uzder(l,k,j)
2078                 enddo
2079               enddo
2080             enddo
2081             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2082             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2083             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2084             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2085           else
2086 C Other residues
2087 C Compute the Z-axis
2088             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2089             costh=dcos(pi-theta(i+2))
2090             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2091             do k=1,3
2092               uz(k,i)=fac*uz(k,i)
2093             enddo
2094 C Compute the derivatives of uz
2095             uzder(1,1,1)= 0.0d0
2096             uzder(2,1,1)=-dc_norm(3,i+1)
2097             uzder(3,1,1)= dc_norm(2,i+1)
2098             uzder(1,2,1)= dc_norm(3,i+1)
2099             uzder(2,2,1)= 0.0d0
2100             uzder(3,2,1)=-dc_norm(1,i+1)
2101             uzder(1,3,1)=-dc_norm(2,i+1)
2102             uzder(2,3,1)= dc_norm(1,i+1)
2103             uzder(3,3,1)= 0.0d0
2104             uzder(1,1,2)= 0.0d0
2105             uzder(2,1,2)= dc_norm(3,i)
2106             uzder(3,1,2)=-dc_norm(2,i)
2107             uzder(1,2,2)=-dc_norm(3,i)
2108             uzder(2,2,2)= 0.0d0
2109             uzder(3,2,2)= dc_norm(1,i)
2110             uzder(1,3,2)= dc_norm(2,i)
2111             uzder(2,3,2)=-dc_norm(1,i)
2112             uzder(3,3,2)= 0.0d0
2113 C Compute the Y-axis
2114             facy=fac
2115             do k=1,3
2116               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2117             enddo
2118 C Compute the derivatives of uy
2119             do j=1,3
2120               do k=1,3
2121                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2122      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2123                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2124               enddo
2125               uyder(j,j,1)=uyder(j,j,1)-costh
2126               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2127             enddo
2128             do j=1,2
2129               do k=1,3
2130                 do l=1,3
2131                   uygrad(l,k,j,i)=uyder(l,k,j)
2132                   uzgrad(l,k,j,i)=uzder(l,k,j)
2133                 enddo
2134               enddo
2135             enddo
2136             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2137             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2138             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2139             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2140           endif
2141       enddo
2142       do i=1,nres-1
2143         vbld_inv_temp(1)=vbld_inv(i+1)
2144         if (i.lt.nres-1) then
2145           vbld_inv_temp(2)=vbld_inv(i+2)
2146           else
2147           vbld_inv_temp(2)=vbld_inv(i)
2148           endif
2149         do j=1,2
2150           do k=1,3
2151             do l=1,3
2152               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2153               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2154             enddo
2155           enddo
2156         enddo
2157       enddo
2158 #if defined(PARVEC) && defined(MPI)
2159       if (nfgtasks1.gt.1) then
2160         time00=MPI_Wtime()
2161 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2162 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2163 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2164         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2165      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2166      &   FG_COMM1,IERR)
2167         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2168      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2169      &   FG_COMM1,IERR)
2170         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2171      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2172      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2173         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2174      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2175      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2176         time_gather=time_gather+MPI_Wtime()-time00
2177       endif
2178 c      if (fg_rank.eq.0) then
2179 c        write (iout,*) "Arrays UY and UZ"
2180 c        do i=1,nres-1
2181 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2182 c     &     (uz(k,i),k=1,3)
2183 c        enddo
2184 c      endif
2185 #endif
2186       return
2187       end
2188 C-----------------------------------------------------------------------------
2189       subroutine check_vecgrad
2190       implicit real*8 (a-h,o-z)
2191       include 'DIMENSIONS'
2192       include 'COMMON.IOUNITS'
2193       include 'COMMON.GEO'
2194       include 'COMMON.VAR'
2195       include 'COMMON.LOCAL'
2196       include 'COMMON.CHAIN'
2197       include 'COMMON.VECTORS'
2198       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2199       dimension uyt(3,maxres),uzt(3,maxres)
2200       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2201       double precision delta /1.0d-7/
2202       call vec_and_deriv
2203 cd      do i=1,nres
2204 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2205 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2206 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2207 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2208 cd     &     (dc_norm(if90,i),if90=1,3)
2209 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2210 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2211 cd          write(iout,'(a)')
2212 cd      enddo
2213       do i=1,nres
2214         do j=1,2
2215           do k=1,3
2216             do l=1,3
2217               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2218               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2219             enddo
2220           enddo
2221         enddo
2222       enddo
2223       call vec_and_deriv
2224       do i=1,nres
2225         do j=1,3
2226           uyt(j,i)=uy(j,i)
2227           uzt(j,i)=uz(j,i)
2228         enddo
2229       enddo
2230       do i=1,nres
2231 cd        write (iout,*) 'i=',i
2232         do k=1,3
2233           erij(k)=dc_norm(k,i)
2234         enddo
2235         do j=1,3
2236           do k=1,3
2237             dc_norm(k,i)=erij(k)
2238           enddo
2239           dc_norm(j,i)=dc_norm(j,i)+delta
2240 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2241 c          do k=1,3
2242 c            dc_norm(k,i)=dc_norm(k,i)/fac
2243 c          enddo
2244 c          write (iout,*) (dc_norm(k,i),k=1,3)
2245 c          write (iout,*) (erij(k),k=1,3)
2246           call vec_and_deriv
2247           do k=1,3
2248             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2249             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2250             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2251             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2252           enddo
2253 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2254 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2255 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2256         enddo
2257         do k=1,3
2258           dc_norm(k,i)=erij(k)
2259         enddo
2260 cd        do k=1,3
2261 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2262 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2263 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2264 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2265 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2266 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2267 cd          write (iout,'(a)')
2268 cd        enddo
2269       enddo
2270       return
2271       end
2272 C--------------------------------------------------------------------------
2273       subroutine set_matrices
2274       implicit real*8 (a-h,o-z)
2275       include 'DIMENSIONS'
2276 #ifdef MPI
2277       include "mpif.h"
2278       include "COMMON.SETUP"
2279       integer IERR
2280       integer status(MPI_STATUS_SIZE)
2281 #endif
2282       include 'COMMON.IOUNITS'
2283       include 'COMMON.GEO'
2284       include 'COMMON.VAR'
2285       include 'COMMON.LOCAL'
2286       include 'COMMON.CHAIN'
2287       include 'COMMON.DERIV'
2288       include 'COMMON.INTERACT'
2289       include 'COMMON.CONTACTS'
2290       include 'COMMON.TORSION'
2291       include 'COMMON.VECTORS'
2292       include 'COMMON.FFIELD'
2293       double precision auxvec(2),auxmat(2,2)
2294 C
2295 C Compute the virtual-bond-torsional-angle dependent quantities needed
2296 C to calculate the el-loc multibody terms of various order.
2297 C
2298 #ifdef PARMAT
2299       do i=ivec_start+2,ivec_end+2
2300 #else
2301       do i=3,nres+1
2302 #endif
2303         if (i .lt. nres+1) then
2304           sin1=dsin(phi(i))
2305           cos1=dcos(phi(i))
2306           sintab(i-2)=sin1
2307           costab(i-2)=cos1
2308           obrot(1,i-2)=cos1
2309           obrot(2,i-2)=sin1
2310           sin2=dsin(2*phi(i))
2311           cos2=dcos(2*phi(i))
2312           sintab2(i-2)=sin2
2313           costab2(i-2)=cos2
2314           obrot2(1,i-2)=cos2
2315           obrot2(2,i-2)=sin2
2316           Ug(1,1,i-2)=-cos1
2317           Ug(1,2,i-2)=-sin1
2318           Ug(2,1,i-2)=-sin1
2319           Ug(2,2,i-2)= cos1
2320           Ug2(1,1,i-2)=-cos2
2321           Ug2(1,2,i-2)=-sin2
2322           Ug2(2,1,i-2)=-sin2
2323           Ug2(2,2,i-2)= cos2
2324         else
2325           costab(i-2)=1.0d0
2326           sintab(i-2)=0.0d0
2327           obrot(1,i-2)=1.0d0
2328           obrot(2,i-2)=0.0d0
2329           obrot2(1,i-2)=0.0d0
2330           obrot2(2,i-2)=0.0d0
2331           Ug(1,1,i-2)=1.0d0
2332           Ug(1,2,i-2)=0.0d0
2333           Ug(2,1,i-2)=0.0d0
2334           Ug(2,2,i-2)=1.0d0
2335           Ug2(1,1,i-2)=0.0d0
2336           Ug2(1,2,i-2)=0.0d0
2337           Ug2(2,1,i-2)=0.0d0
2338           Ug2(2,2,i-2)=0.0d0
2339         endif
2340         if (i .gt. 3 .and. i .lt. nres+1) then
2341           obrot_der(1,i-2)=-sin1
2342           obrot_der(2,i-2)= cos1
2343           Ugder(1,1,i-2)= sin1
2344           Ugder(1,2,i-2)=-cos1
2345           Ugder(2,1,i-2)=-cos1
2346           Ugder(2,2,i-2)=-sin1
2347           dwacos2=cos2+cos2
2348           dwasin2=sin2+sin2
2349           obrot2_der(1,i-2)=-dwasin2
2350           obrot2_der(2,i-2)= dwacos2
2351           Ug2der(1,1,i-2)= dwasin2
2352           Ug2der(1,2,i-2)=-dwacos2
2353           Ug2der(2,1,i-2)=-dwacos2
2354           Ug2der(2,2,i-2)=-dwasin2
2355         else
2356           obrot_der(1,i-2)=0.0d0
2357           obrot_der(2,i-2)=0.0d0
2358           Ugder(1,1,i-2)=0.0d0
2359           Ugder(1,2,i-2)=0.0d0
2360           Ugder(2,1,i-2)=0.0d0
2361           Ugder(2,2,i-2)=0.0d0
2362           obrot2_der(1,i-2)=0.0d0
2363           obrot2_der(2,i-2)=0.0d0
2364           Ug2der(1,1,i-2)=0.0d0
2365           Ug2der(1,2,i-2)=0.0d0
2366           Ug2der(2,1,i-2)=0.0d0
2367           Ug2der(2,2,i-2)=0.0d0
2368         endif
2369 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2370         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2371           iti = itortyp(itype(i-2))
2372         else
2373           iti=ntortyp+1
2374         endif
2375 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2376         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2377           iti1 = itortyp(itype(i-1))
2378         else
2379           iti1=ntortyp+1
2380         endif
2381 cd        write (iout,*) '*******i',i,' iti1',iti
2382 cd        write (iout,*) 'b1',b1(:,iti)
2383 cd        write (iout,*) 'b2',b2(:,iti)
2384 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2385 c        if (i .gt. iatel_s+2) then
2386         if (i .gt. nnt+2) then
2387           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2388           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2389           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2390      &    then
2391           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2392           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2393           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2394           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2395           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2396           endif
2397         else
2398           do k=1,2
2399             Ub2(k,i-2)=0.0d0
2400             Ctobr(k,i-2)=0.0d0
2401             Dtobr2(k,i-2)=0.0d0
2402             do l=1,2
2403               EUg(l,k,i-2)=0.0d0
2404               CUg(l,k,i-2)=0.0d0
2405               DUg(l,k,i-2)=0.0d0
2406               DtUg2(l,k,i-2)=0.0d0
2407             enddo
2408           enddo
2409         endif
2410         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2411         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2412         do k=1,2
2413           muder(k,i-2)=Ub2der(k,i-2)
2414         enddo
2415 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2416         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2417           if (itype(i-1).le.ntyp) then
2418             iti1 = itortyp(itype(i-1))
2419           else
2420             iti1=ntortyp+1
2421           endif
2422         else
2423           iti1=ntortyp+1
2424         endif
2425         do k=1,2
2426           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2427         enddo
2428 cd        write (iout,*) 'mu ',mu(:,i-2)
2429 cd        write (iout,*) 'mu1',mu1(:,i-2)
2430 cd        write (iout,*) 'mu2',mu2(:,i-2)
2431         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2432      &  then
2433         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2434         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2435         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2436         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2437         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2438 C Vectors and matrices dependent on a single virtual-bond dihedral.
2439         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2440         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2441         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2442         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2443         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2444         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2445         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2446         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2447         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2448         endif
2449       enddo
2450 C Matrices dependent on two consecutive virtual-bond dihedrals.
2451 C The order of matrices is from left to right.
2452       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2453      &then
2454 c      do i=max0(ivec_start,2),ivec_end
2455       do i=2,nres-1
2456         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2457         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2458         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2459         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2460         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2461         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2462         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2463         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2464       enddo
2465       endif
2466 #if defined(MPI) && defined(PARMAT)
2467 #ifdef DEBUG
2468 c      if (fg_rank.eq.0) then
2469         write (iout,*) "Arrays UG and UGDER before GATHER"
2470         do i=1,nres-1
2471           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2472      &     ((ug(l,k,i),l=1,2),k=1,2),
2473      &     ((ugder(l,k,i),l=1,2),k=1,2)
2474         enddo
2475         write (iout,*) "Arrays UG2 and UG2DER"
2476         do i=1,nres-1
2477           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2478      &     ((ug2(l,k,i),l=1,2),k=1,2),
2479      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2480         enddo
2481         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2482         do i=1,nres-1
2483           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2484      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2485      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2486         enddo
2487         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2488         do i=1,nres-1
2489           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2490      &     costab(i),sintab(i),costab2(i),sintab2(i)
2491         enddo
2492         write (iout,*) "Array MUDER"
2493         do i=1,nres-1
2494           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2495         enddo
2496 c      endif
2497 #endif
2498       if (nfgtasks.gt.1) then
2499         time00=MPI_Wtime()
2500 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2501 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2502 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2503 #ifdef MATGATHER
2504         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2505      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2506      &   FG_COMM1,IERR)
2507         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2523      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2524      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2525         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2526      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2527      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2528         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2529      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2530      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2531         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2532      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2533      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2534         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2535      &  then
2536         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2543      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2544      &   FG_COMM1,IERR)
2545        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2546      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2547      &   FG_COMM1,IERR)
2548         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2549      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2552      &   ivec_count(fg_rank1),
2553      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2574      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2577      &   ivec_count(fg_rank1),
2578      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2582      &   FG_COMM1,IERR)
2583        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2593      &   ivec_count(fg_rank1),
2594      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2597      &   ivec_count(fg_rank1),
2598      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2601      &   ivec_count(fg_rank1),
2602      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2603      &   MPI_MAT2,FG_COMM1,IERR)
2604         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2605      &   ivec_count(fg_rank1),
2606      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2607      &   MPI_MAT2,FG_COMM1,IERR)
2608         endif
2609 #else
2610 c Passes matrix info through the ring
2611       isend=fg_rank1
2612       irecv=fg_rank1-1
2613       if (irecv.lt.0) irecv=nfgtasks1-1
2614       iprev=irecv
2615       inext=fg_rank1+1
2616       if (inext.ge.nfgtasks1) inext=0
2617       do i=1,nfgtasks1-1
2618 c        write (iout,*) "isend",isend," irecv",irecv
2619 c        call flush(iout)
2620         lensend=lentyp(isend)
2621         lenrecv=lentyp(irecv)
2622 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2623 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2624 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2625 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2626 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2627 c        write (iout,*) "Gather ROTAT1"
2628 c        call flush(iout)
2629 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2630 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2631 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2632 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2633 c        write (iout,*) "Gather ROTAT2"
2634 c        call flush(iout)
2635         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2636      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2637      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2638      &   iprev,4400+irecv,FG_COMM,status,IERR)
2639 c        write (iout,*) "Gather ROTAT_OLD"
2640 c        call flush(iout)
2641         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2642      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2643      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2644      &   iprev,5500+irecv,FG_COMM,status,IERR)
2645 c        write (iout,*) "Gather PRECOMP11"
2646 c        call flush(iout)
2647         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2648      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2649      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2650      &   iprev,6600+irecv,FG_COMM,status,IERR)
2651 c        write (iout,*) "Gather PRECOMP12"
2652 c        call flush(iout)
2653         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2654      &  then
2655         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2656      &   MPI_ROTAT2(lensend),inext,7700+isend,
2657      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2658      &   iprev,7700+irecv,FG_COMM,status,IERR)
2659 c        write (iout,*) "Gather PRECOMP21"
2660 c        call flush(iout)
2661         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2662      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2663      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2664      &   iprev,8800+irecv,FG_COMM,status,IERR)
2665 c        write (iout,*) "Gather PRECOMP22"
2666 c        call flush(iout)
2667         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2668      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2669      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2670      &   MPI_PRECOMP23(lenrecv),
2671      &   iprev,9900+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather PRECOMP23"
2673 c        call flush(iout)
2674         endif
2675         isend=irecv
2676         irecv=irecv-1
2677         if (irecv.lt.0) irecv=nfgtasks1-1
2678       enddo
2679 #endif
2680         time_gather=time_gather+MPI_Wtime()-time00
2681       endif
2682 #ifdef DEBUG
2683 c      if (fg_rank.eq.0) then
2684         write (iout,*) "Arrays UG and UGDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2687      &     ((ug(l,k,i),l=1,2),k=1,2),
2688      &     ((ugder(l,k,i),l=1,2),k=1,2)
2689         enddo
2690         write (iout,*) "Arrays UG2 and UG2DER"
2691         do i=1,nres-1
2692           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2693      &     ((ug2(l,k,i),l=1,2),k=1,2),
2694      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2695         enddo
2696         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2697         do i=1,nres-1
2698           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2699      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2700      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2701         enddo
2702         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2703         do i=1,nres-1
2704           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2705      &     costab(i),sintab(i),costab2(i),sintab2(i)
2706         enddo
2707         write (iout,*) "Array MUDER"
2708         do i=1,nres-1
2709           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2710         enddo
2711 c      endif
2712 #endif
2713 #endif
2714 cd      do i=1,nres
2715 cd        iti = itortyp(itype(i))
2716 cd        write (iout,*) i
2717 cd        do j=1,2
2718 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2719 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2720 cd        enddo
2721 cd      enddo
2722       return
2723       end
2724 C--------------------------------------------------------------------------
2725       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2726 C
2727 C This subroutine calculates the average interaction energy and its gradient
2728 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2729 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2730 C The potential depends both on the distance of peptide-group centers and on
2731 C the orientation of the CA-CA virtual bonds.
2732 C
2733       implicit real*8 (a-h,o-z)
2734 #ifdef MPI
2735       include 'mpif.h'
2736 #endif
2737       include 'DIMENSIONS'
2738       include 'COMMON.CONTROL'
2739       include 'COMMON.SETUP'
2740       include 'COMMON.IOUNITS'
2741       include 'COMMON.GEO'
2742       include 'COMMON.VAR'
2743       include 'COMMON.LOCAL'
2744       include 'COMMON.CHAIN'
2745       include 'COMMON.DERIV'
2746       include 'COMMON.INTERACT'
2747       include 'COMMON.CONTACTS'
2748       include 'COMMON.TORSION'
2749       include 'COMMON.VECTORS'
2750       include 'COMMON.FFIELD'
2751       include 'COMMON.TIME1'
2752       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2753      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2754       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2755      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2756       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2757      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2758      &    num_conti,j1,j2
2759 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2760 #ifdef MOMENT
2761       double precision scal_el /1.0d0/
2762 #else
2763       double precision scal_el /0.5d0/
2764 #endif
2765 C 12/13/98
2766 C 13-go grudnia roku pamietnego...
2767       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2768      &                   0.0d0,1.0d0,0.0d0,
2769      &                   0.0d0,0.0d0,1.0d0/
2770 cd      write(iout,*) 'In EELEC'
2771 cd      do i=1,nloctyp
2772 cd        write(iout,*) 'Type',i
2773 cd        write(iout,*) 'B1',B1(:,i)
2774 cd        write(iout,*) 'B2',B2(:,i)
2775 cd        write(iout,*) 'CC',CC(:,:,i)
2776 cd        write(iout,*) 'DD',DD(:,:,i)
2777 cd        write(iout,*) 'EE',EE(:,:,i)
2778 cd      enddo
2779 cd      call check_vecgrad
2780 cd      stop
2781       if (icheckgrad.eq.1) then
2782         do i=1,nres-1
2783           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2784           do k=1,3
2785             dc_norm(k,i)=dc(k,i)*fac
2786           enddo
2787 c          write (iout,*) 'i',i,' fac',fac
2788         enddo
2789       endif
2790       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2791      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2792      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2793 c        call vec_and_deriv
2794 #ifdef TIMING
2795         time01=MPI_Wtime()
2796 #endif
2797         call set_matrices
2798 #ifdef TIMING
2799         time_mat=time_mat+MPI_Wtime()-time01
2800 #endif
2801       endif
2802 cd      do i=1,nres-1
2803 cd        write (iout,*) 'i=',i
2804 cd        do k=1,3
2805 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2806 cd        enddo
2807 cd        do k=1,3
2808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2810 cd        enddo
2811 cd      enddo
2812       t_eelecij=0.0d0
2813       ees=0.0D0
2814       evdw1=0.0D0
2815       eel_loc=0.0d0
2816       eello_turn3=0.0d0
2817       eello_turn4=0.0d0
2818       ind=0
2819       do i=1,nres
2820         num_cont_hb(i)=0
2821       enddo
2822 cd      print '(a)','Enter EELEC'
2823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2824       do i=1,nres
2825         gel_loc_loc(i)=0.0d0
2826         gcorr_loc(i)=0.0d0
2827       enddo
2828 c
2829 c
2830 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2831 C
2832 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2833 C
2834       do i=iturn3_start,iturn3_end
2835         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2836      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2837         dxi=dc(1,i)
2838         dyi=dc(2,i)
2839         dzi=dc(3,i)
2840         dx_normi=dc_norm(1,i)
2841         dy_normi=dc_norm(2,i)
2842         dz_normi=dc_norm(3,i)
2843         xmedi=c(1,i)+0.5d0*dxi
2844         ymedi=c(2,i)+0.5d0*dyi
2845         zmedi=c(3,i)+0.5d0*dzi
2846         num_conti=0
2847         call eelecij(i,i+2,ees,evdw1,eel_loc)
2848         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2849         num_cont_hb(i)=num_conti
2850       enddo
2851       do i=iturn4_start,iturn4_end
2852         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2853      &    .or. itype(i+3).eq.ntyp1
2854      &    .or. itype(i+4).eq.ntyp1) cycle
2855         dxi=dc(1,i)
2856         dyi=dc(2,i)
2857         dzi=dc(3,i)
2858         dx_normi=dc_norm(1,i)
2859         dy_normi=dc_norm(2,i)
2860         dz_normi=dc_norm(3,i)
2861         xmedi=c(1,i)+0.5d0*dxi
2862         ymedi=c(2,i)+0.5d0*dyi
2863         zmedi=c(3,i)+0.5d0*dzi
2864         num_conti=num_cont_hb(i)
2865         call eelecij(i,i+3,ees,evdw1,eel_loc)
2866         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2867      &   call eturn4(i,eello_turn4)
2868         num_cont_hb(i)=num_conti
2869       enddo   ! i
2870 c
2871 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2872 c
2873       do i=iatel_s,iatel_e
2874         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2875         dxi=dc(1,i)
2876         dyi=dc(2,i)
2877         dzi=dc(3,i)
2878         dx_normi=dc_norm(1,i)
2879         dy_normi=dc_norm(2,i)
2880         dz_normi=dc_norm(3,i)
2881         xmedi=c(1,i)+0.5d0*dxi
2882         ymedi=c(2,i)+0.5d0*dyi
2883         zmedi=c(3,i)+0.5d0*dzi
2884 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2885         num_conti=num_cont_hb(i)
2886         do j=ielstart(i),ielend(i)
2887 c          write (iout,*) i,j,itype(i),itype(j)
2888           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2889           call eelecij(i,j,ees,evdw1,eel_loc)
2890         enddo ! j
2891         num_cont_hb(i)=num_conti
2892       enddo   ! i
2893 c      write (iout,*) "Number of loop steps in EELEC:",ind
2894 cd      do i=1,nres
2895 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2896 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2897 cd      enddo
2898 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2899 ccc      eel_loc=eel_loc+eello_turn3
2900 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2901       return
2902       end
2903 C-------------------------------------------------------------------------------
2904       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2905       implicit real*8 (a-h,o-z)
2906       include 'DIMENSIONS'
2907 #ifdef MPI
2908       include "mpif.h"
2909 #endif
2910       include 'COMMON.CONTROL'
2911       include 'COMMON.IOUNITS'
2912       include 'COMMON.GEO'
2913       include 'COMMON.VAR'
2914       include 'COMMON.LOCAL'
2915       include 'COMMON.CHAIN'
2916       include 'COMMON.DERIV'
2917       include 'COMMON.INTERACT'
2918       include 'COMMON.CONTACTS'
2919       include 'COMMON.TORSION'
2920       include 'COMMON.VECTORS'
2921       include 'COMMON.FFIELD'
2922       include 'COMMON.TIME1'
2923       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2924      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2925       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2926      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2927       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2928      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2929      &    num_conti,j1,j2
2930 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2931 #ifdef MOMENT
2932       double precision scal_el /1.0d0/
2933 #else
2934       double precision scal_el /0.5d0/
2935 #endif
2936 C 12/13/98
2937 C 13-go grudnia roku pamietnego...
2938       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2939      &                   0.0d0,1.0d0,0.0d0,
2940      &                   0.0d0,0.0d0,1.0d0/
2941 c          time00=MPI_Wtime()
2942 cd      write (iout,*) "eelecij",i,j
2943 c          ind=ind+1
2944           iteli=itel(i)
2945           itelj=itel(j)
2946           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2947           aaa=app(iteli,itelj)
2948           bbb=bpp(iteli,itelj)
2949           ael6i=ael6(iteli,itelj)
2950           ael3i=ael3(iteli,itelj)
2951           dxj=dc(1,j)
2952           dyj=dc(2,j)
2953           dzj=dc(3,j)
2954           dx_normj=dc_norm(1,j)
2955           dy_normj=dc_norm(2,j)
2956           dz_normj=dc_norm(3,j)
2957           xj=c(1,j)+0.5D0*dxj-xmedi
2958           yj=c(2,j)+0.5D0*dyj-ymedi
2959           zj=c(3,j)+0.5D0*dzj-zmedi
2960           rij=xj*xj+yj*yj+zj*zj
2961           rrmij=1.0D0/rij
2962           rij=dsqrt(rij)
2963           rmij=1.0D0/rij
2964           r3ij=rrmij*rmij
2965           r6ij=r3ij*r3ij
2966           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2967           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2968           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2969           fac=cosa-3.0D0*cosb*cosg
2970           ev1=aaa*r6ij*r6ij
2971 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2972           if (j.eq.i+2) ev1=scal_el*ev1
2973           ev2=bbb*r6ij
2974           fac3=ael6i*r6ij
2975           fac4=ael3i*r3ij
2976           evdwij=ev1+ev2
2977           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2978           el2=fac4*fac
2979           eesij=el1+el2
2980 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2981           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2982           ees=ees+eesij
2983           evdw1=evdw1+evdwij
2984 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2985 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2986 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2987 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2988
2989           if (energy_dec) then
2990               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2991      &'evdw1',i,j,evdwij
2992      &,iteli,itelj,aaa,evdw1
2993               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2994           endif
2995
2996 C
2997 C Calculate contributions to the Cartesian gradient.
2998 C
2999 #ifdef SPLITELE
3000           facvdw=-6*rrmij*(ev1+evdwij)
3001           facel=-3*rrmij*(el1+eesij)
3002           fac1=fac
3003           erij(1)=xj*rmij
3004           erij(2)=yj*rmij
3005           erij(3)=zj*rmij
3006 *
3007 * Radial derivatives. First process both termini of the fragment (i,j)
3008 *
3009           ggg(1)=facel*xj
3010           ggg(2)=facel*yj
3011           ggg(3)=facel*zj
3012 c          do k=1,3
3013 c            ghalf=0.5D0*ggg(k)
3014 c            gelc(k,i)=gelc(k,i)+ghalf
3015 c            gelc(k,j)=gelc(k,j)+ghalf
3016 c          enddo
3017 c 9/28/08 AL Gradient compotents will be summed only at the end
3018           do k=1,3
3019             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3020             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3021           enddo
3022 *
3023 * Loop over residues i+1 thru j-1.
3024 *
3025 cgrad          do k=i+1,j-1
3026 cgrad            do l=1,3
3027 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3028 cgrad            enddo
3029 cgrad          enddo
3030           ggg(1)=facvdw*xj
3031           ggg(2)=facvdw*yj
3032           ggg(3)=facvdw*zj
3033 c          do k=1,3
3034 c            ghalf=0.5D0*ggg(k)
3035 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3036 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3037 c          enddo
3038 c 9/28/08 AL Gradient compotents will be summed only at the end
3039           do k=1,3
3040             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3041             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3042           enddo
3043 *
3044 * Loop over residues i+1 thru j-1.
3045 *
3046 cgrad          do k=i+1,j-1
3047 cgrad            do l=1,3
3048 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3049 cgrad            enddo
3050 cgrad          enddo
3051 #else
3052           facvdw=ev1+evdwij
3053           facel=el1+eesij
3054           fac1=fac
3055           fac=-3*rrmij*(facvdw+facvdw+facel)
3056           erij(1)=xj*rmij
3057           erij(2)=yj*rmij
3058           erij(3)=zj*rmij
3059 *
3060 * Radial derivatives. First process both termini of the fragment (i,j)
3061 *
3062           ggg(1)=fac*xj
3063           ggg(2)=fac*yj
3064           ggg(3)=fac*zj
3065 c          do k=1,3
3066 c            ghalf=0.5D0*ggg(k)
3067 c            gelc(k,i)=gelc(k,i)+ghalf
3068 c            gelc(k,j)=gelc(k,j)+ghalf
3069 c          enddo
3070 c 9/28/08 AL Gradient compotents will be summed only at the end
3071           do k=1,3
3072             gelc_long(k,j)=gelc(k,j)+ggg(k)
3073             gelc_long(k,i)=gelc(k,i)-ggg(k)
3074           enddo
3075 *
3076 * Loop over residues i+1 thru j-1.
3077 *
3078 cgrad          do k=i+1,j-1
3079 cgrad            do l=1,3
3080 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3081 cgrad            enddo
3082 cgrad          enddo
3083 c 9/28/08 AL Gradient compotents will be summed only at the end
3084           ggg(1)=facvdw*xj
3085           ggg(2)=facvdw*yj
3086           ggg(3)=facvdw*zj
3087           do k=1,3
3088             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3089             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3090           enddo
3091 #endif
3092 *
3093 * Angular part
3094 *
3095           ecosa=2.0D0*fac3*fac1+fac4
3096           fac4=-3.0D0*fac4
3097           fac3=-6.0D0*fac3
3098           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3099           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3100           do k=1,3
3101             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3102             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3103           enddo
3104 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3105 cd   &          (dcosg(k),k=1,3)
3106           do k=1,3
3107             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3108           enddo
3109 c          do k=1,3
3110 c            ghalf=0.5D0*ggg(k)
3111 c            gelc(k,i)=gelc(k,i)+ghalf
3112 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3113 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3114 c            gelc(k,j)=gelc(k,j)+ghalf
3115 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3116 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3117 c          enddo
3118 cgrad          do k=i+1,j-1
3119 cgrad            do l=1,3
3120 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3121 cgrad            enddo
3122 cgrad          enddo
3123           do k=1,3
3124             gelc(k,i)=gelc(k,i)
3125      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3126      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3127             gelc(k,j)=gelc(k,j)
3128      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3129      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3130             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3131             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3132           enddo
3133           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3134      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3135      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3136 C
3137 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3138 C   energy of a peptide unit is assumed in the form of a second-order
3139 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3140 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3141 C   are computed for EVERY pair of non-contiguous peptide groups.
3142 C
3143           if (j.lt.nres-1) then
3144             j1=j+1
3145             j2=j-1
3146           else
3147             j1=j-1
3148             j2=j-2
3149           endif
3150           kkk=0
3151           do k=1,2
3152             do l=1,2
3153               kkk=kkk+1
3154               muij(kkk)=mu(k,i)*mu(l,j)
3155             enddo
3156           enddo
3157 cd         write (iout,*) 'EELEC: i',i,' j',j
3158 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3159 cd          write(iout,*) 'muij',muij
3160           ury=scalar(uy(1,i),erij)
3161           urz=scalar(uz(1,i),erij)
3162           vry=scalar(uy(1,j),erij)
3163           vrz=scalar(uz(1,j),erij)
3164           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3165           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3166           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3167           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3168           fac=dsqrt(-ael6i)*r3ij
3169           a22=a22*fac
3170           a23=a23*fac
3171           a32=a32*fac
3172           a33=a33*fac
3173 cd          write (iout,'(4i5,4f10.5)')
3174 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3175 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3176 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3177 cd     &      uy(:,j),uz(:,j)
3178 cd          write (iout,'(4f10.5)')
3179 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3180 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3181 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3182 cd           write (iout,'(9f10.5/)')
3183 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3184 C Derivatives of the elements of A in virtual-bond vectors
3185           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3186           do k=1,3
3187             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3188             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3189             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3190             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3191             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3192             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3193             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3194             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3195             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3196             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3197             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3198             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3199           enddo
3200 C Compute radial contributions to the gradient
3201           facr=-3.0d0*rrmij
3202           a22der=a22*facr
3203           a23der=a23*facr
3204           a32der=a32*facr
3205           a33der=a33*facr
3206           agg(1,1)=a22der*xj
3207           agg(2,1)=a22der*yj
3208           agg(3,1)=a22der*zj
3209           agg(1,2)=a23der*xj
3210           agg(2,2)=a23der*yj
3211           agg(3,2)=a23der*zj
3212           agg(1,3)=a32der*xj
3213           agg(2,3)=a32der*yj
3214           agg(3,3)=a32der*zj
3215           agg(1,4)=a33der*xj
3216           agg(2,4)=a33der*yj
3217           agg(3,4)=a33der*zj
3218 C Add the contributions coming from er
3219           fac3=-3.0d0*fac
3220           do k=1,3
3221             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3222             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3223             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3224             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3225           enddo
3226           do k=1,3
3227 C Derivatives in DC(i)
3228 cgrad            ghalf1=0.5d0*agg(k,1)
3229 cgrad            ghalf2=0.5d0*agg(k,2)
3230 cgrad            ghalf3=0.5d0*agg(k,3)
3231 cgrad            ghalf4=0.5d0*agg(k,4)
3232             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3233      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3234             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3235      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3236             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3237      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3238             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3239      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3240 C Derivatives in DC(i+1)
3241             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3242      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3243             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3244      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3245             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3246      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3247             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3248      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3249 C Derivatives in DC(j)
3250             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3251      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3252             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3253      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3254             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3255      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3256             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3257      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3258 C Derivatives in DC(j+1) or DC(nres-1)
3259             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3260      &      -3.0d0*vryg(k,3)*ury)
3261             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3262      &      -3.0d0*vrzg(k,3)*ury)
3263             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3264      &      -3.0d0*vryg(k,3)*urz)
3265             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3266      &      -3.0d0*vrzg(k,3)*urz)
3267 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3268 cgrad              do l=1,4
3269 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3270 cgrad              enddo
3271 cgrad            endif
3272           enddo
3273           acipa(1,1)=a22
3274           acipa(1,2)=a23
3275           acipa(2,1)=a32
3276           acipa(2,2)=a33
3277           a22=-a22
3278           a23=-a23
3279           do l=1,2
3280             do k=1,3
3281               agg(k,l)=-agg(k,l)
3282               aggi(k,l)=-aggi(k,l)
3283               aggi1(k,l)=-aggi1(k,l)
3284               aggj(k,l)=-aggj(k,l)
3285               aggj1(k,l)=-aggj1(k,l)
3286             enddo
3287           enddo
3288           if (j.lt.nres-1) then
3289             a22=-a22
3290             a32=-a32
3291             do l=1,3,2
3292               do k=1,3
3293                 agg(k,l)=-agg(k,l)
3294                 aggi(k,l)=-aggi(k,l)
3295                 aggi1(k,l)=-aggi1(k,l)
3296                 aggj(k,l)=-aggj(k,l)
3297                 aggj1(k,l)=-aggj1(k,l)
3298               enddo
3299             enddo
3300           else
3301             a22=-a22
3302             a23=-a23
3303             a32=-a32
3304             a33=-a33
3305             do l=1,4
3306               do k=1,3
3307                 agg(k,l)=-agg(k,l)
3308                 aggi(k,l)=-aggi(k,l)
3309                 aggi1(k,l)=-aggi1(k,l)
3310                 aggj(k,l)=-aggj(k,l)
3311                 aggj1(k,l)=-aggj1(k,l)
3312               enddo
3313             enddo
3314           endif
3315           ENDIF ! WCORR
3316           IF (wel_loc.gt.0.0d0) THEN
3317 C Contribution to the local-electrostatic energy coming from the i-j pair
3318           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3319      &     +a33*muij(4)
3320 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3321
3322           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3323      &            'eelloc',i,j,eel_loc_ij
3324 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3325
3326           eel_loc=eel_loc+eel_loc_ij
3327 C Partial derivatives in virtual-bond dihedral angles gamma
3328           if (i.gt.1)
3329      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3330      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3331      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3332           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3333      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3334      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3336           do l=1,3
3337             ggg(l)=agg(l,1)*muij(1)+
3338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3339             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3340             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3341 cgrad            ghalf=0.5d0*ggg(l)
3342 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3343 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3344           enddo
3345 cgrad          do k=i+1,j2
3346 cgrad            do l=1,3
3347 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3348 cgrad            enddo
3349 cgrad          enddo
3350 C Remaining derivatives of eello
3351           do l=1,3
3352             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3353      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3354             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3355      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3356             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3357      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3358             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3359      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3360           enddo
3361           ENDIF
3362 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3363 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3364           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3365      &       .and. num_conti.le.maxconts) then
3366 c            write (iout,*) i,j," entered corr"
3367 C
3368 C Calculate the contact function. The ith column of the array JCONT will
3369 C contain the numbers of atoms that make contacts with the atom I (of numbers
3370 C greater than I). The arrays FACONT and GACONT will contain the values of
3371 C the contact function and its derivative.
3372 c           r0ij=1.02D0*rpp(iteli,itelj)
3373 c           r0ij=1.11D0*rpp(iteli,itelj)
3374             r0ij=2.20D0*rpp(iteli,itelj)
3375 c           r0ij=1.55D0*rpp(iteli,itelj)
3376             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3377             if (fcont.gt.0.0D0) then
3378               num_conti=num_conti+1
3379               if (num_conti.gt.maxconts) then
3380                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3381      &                         ' will skip next contacts for this conf.'
3382               else
3383                 jcont_hb(num_conti,i)=j
3384 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3385 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3386                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3387      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3388 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3389 C  terms.
3390                 d_cont(num_conti,i)=rij
3391 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3392 C     --- Electrostatic-interaction matrix ---
3393                 a_chuj(1,1,num_conti,i)=a22
3394                 a_chuj(1,2,num_conti,i)=a23
3395                 a_chuj(2,1,num_conti,i)=a32
3396                 a_chuj(2,2,num_conti,i)=a33
3397 C     --- Gradient of rij
3398                 do kkk=1,3
3399                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3400                 enddo
3401                 kkll=0
3402                 do k=1,2
3403                   do l=1,2
3404                     kkll=kkll+1
3405                     do m=1,3
3406                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3407                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3408                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3409                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3410                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3411                     enddo
3412                   enddo
3413                 enddo
3414                 ENDIF
3415                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3416 C Calculate contact energies
3417                 cosa4=4.0D0*cosa
3418                 wij=cosa-3.0D0*cosb*cosg
3419                 cosbg1=cosb+cosg
3420                 cosbg2=cosb-cosg
3421 c               fac3=dsqrt(-ael6i)/r0ij**3
3422                 fac3=dsqrt(-ael6i)*r3ij
3423 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3424                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3425                 if (ees0tmp.gt.0) then
3426                   ees0pij=dsqrt(ees0tmp)
3427                 else
3428                   ees0pij=0
3429                 endif
3430 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3431                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3432                 if (ees0tmp.gt.0) then
3433                   ees0mij=dsqrt(ees0tmp)
3434                 else
3435                   ees0mij=0
3436                 endif
3437 c               ees0mij=0.0D0
3438                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3439                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3440 C Diagnostics. Comment out or remove after debugging!
3441 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3442 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3443 c               ees0m(num_conti,i)=0.0D0
3444 C End diagnostics.
3445 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3446 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3447 C Angular derivatives of the contact function
3448                 ees0pij1=fac3/ees0pij
3449                 ees0mij1=fac3/ees0mij
3450                 fac3p=-3.0D0*fac3*rrmij
3451                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3452                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3453 c               ees0mij1=0.0D0
3454                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3455                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3456                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3457                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3458                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3459                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3460                 ecosap=ecosa1+ecosa2
3461                 ecosbp=ecosb1+ecosb2
3462                 ecosgp=ecosg1+ecosg2
3463                 ecosam=ecosa1-ecosa2
3464                 ecosbm=ecosb1-ecosb2
3465                 ecosgm=ecosg1-ecosg2
3466 C Diagnostics
3467 c               ecosap=ecosa1
3468 c               ecosbp=ecosb1
3469 c               ecosgp=ecosg1
3470 c               ecosam=0.0D0
3471 c               ecosbm=0.0D0
3472 c               ecosgm=0.0D0
3473 C End diagnostics
3474                 facont_hb(num_conti,i)=fcont
3475                 fprimcont=fprimcont/rij
3476 cd              facont_hb(num_conti,i)=1.0D0
3477 C Following line is for diagnostics.
3478 cd              fprimcont=0.0D0
3479                 do k=1,3
3480                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3481                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3482                 enddo
3483                 do k=1,3
3484                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3485                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3486                 enddo
3487                 gggp(1)=gggp(1)+ees0pijp*xj
3488                 gggp(2)=gggp(2)+ees0pijp*yj
3489                 gggp(3)=gggp(3)+ees0pijp*zj
3490                 gggm(1)=gggm(1)+ees0mijp*xj
3491                 gggm(2)=gggm(2)+ees0mijp*yj
3492                 gggm(3)=gggm(3)+ees0mijp*zj
3493 C Derivatives due to the contact function
3494                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3495                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3496                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3497                 do k=1,3
3498 c
3499 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3500 c          following the change of gradient-summation algorithm.
3501 c
3502 cgrad                  ghalfp=0.5D0*gggp(k)
3503 cgrad                  ghalfm=0.5D0*gggm(k)
3504                   gacontp_hb1(k,num_conti,i)=!ghalfp
3505      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3506      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3507                   gacontp_hb2(k,num_conti,i)=!ghalfp
3508      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3509      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3510                   gacontp_hb3(k,num_conti,i)=gggp(k)
3511                   gacontm_hb1(k,num_conti,i)=!ghalfm
3512      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3513      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3514                   gacontm_hb2(k,num_conti,i)=!ghalfm
3515      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3516      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3517                   gacontm_hb3(k,num_conti,i)=gggm(k)
3518                 enddo
3519 C Diagnostics. Comment out or remove after debugging!
3520 cdiag           do k=1,3
3521 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3522 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3523 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3524 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3525 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3526 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3527 cdiag           enddo
3528               ENDIF ! wcorr
3529               endif  ! num_conti.le.maxconts
3530             endif  ! fcont.gt.0
3531           endif    ! j.gt.i+1
3532           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3533             do k=1,4
3534               do l=1,3
3535                 ghalf=0.5d0*agg(l,k)
3536                 aggi(l,k)=aggi(l,k)+ghalf
3537                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3538                 aggj(l,k)=aggj(l,k)+ghalf
3539               enddo
3540             enddo
3541             if (j.eq.nres-1 .and. i.lt.j-2) then
3542               do k=1,4
3543                 do l=1,3
3544                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3545                 enddo
3546               enddo
3547             endif
3548           endif
3549 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3550       return
3551       end
3552 C-----------------------------------------------------------------------------
3553       subroutine eturn3(i,eello_turn3)
3554 C Third- and fourth-order contributions from turns
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557       include 'COMMON.IOUNITS'
3558       include 'COMMON.GEO'
3559       include 'COMMON.VAR'
3560       include 'COMMON.LOCAL'
3561       include 'COMMON.CHAIN'
3562       include 'COMMON.DERIV'
3563       include 'COMMON.INTERACT'
3564       include 'COMMON.CONTACTS'
3565       include 'COMMON.TORSION'
3566       include 'COMMON.VECTORS'
3567       include 'COMMON.FFIELD'
3568       include 'COMMON.CONTROL'
3569       dimension ggg(3)
3570       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3571      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3572      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3573       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3574      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3575       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3576      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3577      &    num_conti,j1,j2
3578       j=i+2
3579 c      write (iout,*) "eturn3",i,j,j1,j2
3580       a_temp(1,1)=a22
3581       a_temp(1,2)=a23
3582       a_temp(2,1)=a32
3583       a_temp(2,2)=a33
3584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3585 C
3586 C               Third-order contributions
3587 C
3588 C                 (i+2)o----(i+3)
3589 C                      | |
3590 C                      | |
3591 C                 (i+1)o----i
3592 C
3593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3594 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3595         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3596         call transpose2(auxmat(1,1),auxmat1(1,1))
3597         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3598         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3599         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3600      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3601 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3602 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3603 cd     &    ' eello_turn3_num',4*eello_turn3_num
3604 C Derivatives in gamma(i)
3605         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3606         call transpose2(auxmat2(1,1),auxmat3(1,1))
3607         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3608         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3609 C Derivatives in gamma(i+1)
3610         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3611         call transpose2(auxmat2(1,1),auxmat3(1,1))
3612         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3613         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3614      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3615 C Cartesian derivatives
3616         do l=1,3
3617 c            ghalf1=0.5d0*agg(l,1)
3618 c            ghalf2=0.5d0*agg(l,2)
3619 c            ghalf3=0.5d0*agg(l,3)
3620 c            ghalf4=0.5d0*agg(l,4)
3621           a_temp(1,1)=aggi(l,1)!+ghalf1
3622           a_temp(1,2)=aggi(l,2)!+ghalf2
3623           a_temp(2,1)=aggi(l,3)!+ghalf3
3624           a_temp(2,2)=aggi(l,4)!+ghalf4
3625           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3626           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3627      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3628           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3629           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3630           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3631           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3632           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3633           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3634      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3635           a_temp(1,1)=aggj(l,1)!+ghalf1
3636           a_temp(1,2)=aggj(l,2)!+ghalf2
3637           a_temp(2,1)=aggj(l,3)!+ghalf3
3638           a_temp(2,2)=aggj(l,4)!+ghalf4
3639           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3640           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3641      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3642           a_temp(1,1)=aggj1(l,1)
3643           a_temp(1,2)=aggj1(l,2)
3644           a_temp(2,1)=aggj1(l,3)
3645           a_temp(2,2)=aggj1(l,4)
3646           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3647           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3648      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3649         enddo
3650       return
3651       end
3652 C-------------------------------------------------------------------------------
3653       subroutine eturn4(i,eello_turn4)
3654 C Third- and fourth-order contributions from turns
3655       implicit real*8 (a-h,o-z)
3656       include 'DIMENSIONS'
3657       include 'COMMON.IOUNITS'
3658       include 'COMMON.GEO'
3659       include 'COMMON.VAR'
3660       include 'COMMON.LOCAL'
3661       include 'COMMON.CHAIN'
3662       include 'COMMON.DERIV'
3663       include 'COMMON.INTERACT'
3664       include 'COMMON.CONTACTS'
3665       include 'COMMON.TORSION'
3666       include 'COMMON.VECTORS'
3667       include 'COMMON.FFIELD'
3668       include 'COMMON.CONTROL'
3669       dimension ggg(3)
3670       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3671      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3672      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3673       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3674      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3675       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3676      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3677      &    num_conti,j1,j2
3678       j=i+3
3679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3680 C
3681 C               Fourth-order contributions
3682 C
3683 C                 (i+3)o----(i+4)
3684 C                     /  |
3685 C               (i+2)o   |
3686 C                     \  |
3687 C                 (i+1)o----i
3688 C
3689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3690 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3691 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3692         a_temp(1,1)=a22
3693         a_temp(1,2)=a23
3694         a_temp(2,1)=a32
3695         a_temp(2,2)=a33
3696         iti1=itortyp(itype(i+1))
3697         iti2=itortyp(itype(i+2))
3698         iti3=itortyp(itype(i+3))
3699 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3700         call transpose2(EUg(1,1,i+1),e1t(1,1))
3701         call transpose2(Eug(1,1,i+2),e2t(1,1))
3702         call transpose2(Eug(1,1,i+3),e3t(1,1))
3703         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3704         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3705         s1=scalar2(b1(1,iti2),auxvec(1))
3706         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3707         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3708         s2=scalar2(b1(1,iti1),auxvec(1))
3709         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3710         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3711         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3712         eello_turn4=eello_turn4-(s1+s2+s3)
3713         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3714      &      'eturn4',i,j,-(s1+s2+s3)
3715 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3716 cd     &    ' eello_turn4_num',8*eello_turn4_num
3717 C Derivatives in gamma(i)
3718         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3719         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3720         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3721         s1=scalar2(b1(1,iti2),auxvec(1))
3722         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3723         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3725 C Derivatives in gamma(i+1)
3726         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3727         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3728         s2=scalar2(b1(1,iti1),auxvec(1))
3729         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3730         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3731         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3733 C Derivatives in gamma(i+2)
3734         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3735         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3736         s1=scalar2(b1(1,iti2),auxvec(1))
3737         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3738         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3739         s2=scalar2(b1(1,iti1),auxvec(1))
3740         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3741         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3742         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3744 C Cartesian derivatives
3745 C Derivatives of this turn contributions in DC(i+2)
3746         if (j.lt.nres-1) then
3747           do l=1,3
3748             a_temp(1,1)=agg(l,1)
3749             a_temp(1,2)=agg(l,2)
3750             a_temp(2,1)=agg(l,3)
3751             a_temp(2,2)=agg(l,4)
3752             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3753             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754             s1=scalar2(b1(1,iti2),auxvec(1))
3755             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3756             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3757             s2=scalar2(b1(1,iti1),auxvec(1))
3758             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3759             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3761             ggg(l)=-(s1+s2+s3)
3762             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3763           enddo
3764         endif
3765 C Remaining derivatives of this turn contribution
3766         do l=1,3
3767           a_temp(1,1)=aggi(l,1)
3768           a_temp(1,2)=aggi(l,2)
3769           a_temp(2,1)=aggi(l,3)
3770           a_temp(2,2)=aggi(l,4)
3771           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3772           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3773           s1=scalar2(b1(1,iti2),auxvec(1))
3774           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3775           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3776           s2=scalar2(b1(1,iti1),auxvec(1))
3777           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3778           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3779           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3780           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3781           a_temp(1,1)=aggi1(l,1)
3782           a_temp(1,2)=aggi1(l,2)
3783           a_temp(2,1)=aggi1(l,3)
3784           a_temp(2,2)=aggi1(l,4)
3785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787           s1=scalar2(b1(1,iti2),auxvec(1))
3788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790           s2=scalar2(b1(1,iti1),auxvec(1))
3791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3795           a_temp(1,1)=aggj(l,1)
3796           a_temp(1,2)=aggj(l,2)
3797           a_temp(2,1)=aggj(l,3)
3798           a_temp(2,2)=aggj(l,4)
3799           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3800           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3801           s1=scalar2(b1(1,iti2),auxvec(1))
3802           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3803           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3804           s2=scalar2(b1(1,iti1),auxvec(1))
3805           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3806           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3807           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3808           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3809           a_temp(1,1)=aggj1(l,1)
3810           a_temp(1,2)=aggj1(l,2)
3811           a_temp(2,1)=aggj1(l,3)
3812           a_temp(2,2)=aggj1(l,4)
3813           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3814           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3815           s1=scalar2(b1(1,iti2),auxvec(1))
3816           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3817           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3818           s2=scalar2(b1(1,iti1),auxvec(1))
3819           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3820           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3821           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3822 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3823           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3824         enddo
3825       return
3826       end
3827 C-----------------------------------------------------------------------------
3828       subroutine vecpr(u,v,w)
3829       implicit real*8(a-h,o-z)
3830       dimension u(3),v(3),w(3)
3831       w(1)=u(2)*v(3)-u(3)*v(2)
3832       w(2)=-u(1)*v(3)+u(3)*v(1)
3833       w(3)=u(1)*v(2)-u(2)*v(1)
3834       return
3835       end
3836 C-----------------------------------------------------------------------------
3837       subroutine unormderiv(u,ugrad,unorm,ungrad)
3838 C This subroutine computes the derivatives of a normalized vector u, given
3839 C the derivatives computed without normalization conditions, ugrad. Returns
3840 C ungrad.
3841       implicit none
3842       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3843       double precision vec(3)
3844       double precision scalar
3845       integer i,j
3846 c      write (2,*) 'ugrad',ugrad
3847 c      write (2,*) 'u',u
3848       do i=1,3
3849         vec(i)=scalar(ugrad(1,i),u(1))
3850       enddo
3851 c      write (2,*) 'vec',vec
3852       do i=1,3
3853         do j=1,3
3854           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3855         enddo
3856       enddo
3857 c      write (2,*) 'ungrad',ungrad
3858       return
3859       end
3860 C-----------------------------------------------------------------------------
3861       subroutine escp_soft_sphere(evdw2,evdw2_14)
3862 C
3863 C This subroutine calculates the excluded-volume interaction energy between
3864 C peptide-group centers and side chains and its gradient in virtual-bond and
3865 C side-chain vectors.
3866 C
3867       implicit real*8 (a-h,o-z)
3868       include 'DIMENSIONS'
3869       include 'COMMON.GEO'
3870       include 'COMMON.VAR'
3871       include 'COMMON.LOCAL'
3872       include 'COMMON.CHAIN'
3873       include 'COMMON.DERIV'
3874       include 'COMMON.INTERACT'
3875       include 'COMMON.FFIELD'
3876       include 'COMMON.IOUNITS'
3877       include 'COMMON.CONTROL'
3878       dimension ggg(3)
3879       evdw2=0.0D0
3880       evdw2_14=0.0d0
3881       r0_scp=4.5d0
3882 cd    print '(a)','Enter ESCP'
3883 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3884       do i=iatscp_s,iatscp_e
3885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3886         iteli=itel(i)
3887         xi=0.5D0*(c(1,i)+c(1,i+1))
3888         yi=0.5D0*(c(2,i)+c(2,i+1))
3889         zi=0.5D0*(c(3,i)+c(3,i+1))
3890
3891         do iint=1,nscp_gr(i)
3892
3893         do j=iscpstart(i,iint),iscpend(i,iint)
3894           if (itype(j).eq.ntyp1) cycle
3895           itypj=iabs(itype(j))
3896 C Uncomment following three lines for SC-p interactions
3897 c         xj=c(1,nres+j)-xi
3898 c         yj=c(2,nres+j)-yi
3899 c         zj=c(3,nres+j)-zi
3900 C Uncomment following three lines for Ca-p interactions
3901           xj=c(1,j)-xi
3902           yj=c(2,j)-yi
3903           zj=c(3,j)-zi
3904           rij=xj*xj+yj*yj+zj*zj
3905           r0ij=r0_scp
3906           r0ijsq=r0ij*r0ij
3907           if (rij.lt.r0ijsq) then
3908             evdwij=0.25d0*(rij-r0ijsq)**2
3909             fac=rij-r0ijsq
3910           else
3911             evdwij=0.0d0
3912             fac=0.0d0
3913           endif
3914           evdw2=evdw2+evdwij
3915 C
3916 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3917 C
3918           ggg(1)=xj*fac
3919           ggg(2)=yj*fac
3920           ggg(3)=zj*fac
3921 cgrad          if (j.lt.i) then
3922 cd          write (iout,*) 'j<i'
3923 C Uncomment following three lines for SC-p interactions
3924 c           do k=1,3
3925 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3926 c           enddo
3927 cgrad          else
3928 cd          write (iout,*) 'j>i'
3929 cgrad            do k=1,3
3930 cgrad              ggg(k)=-ggg(k)
3931 C Uncomment following line for SC-p interactions
3932 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3933 cgrad            enddo
3934 cgrad          endif
3935 cgrad          do k=1,3
3936 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3937 cgrad          enddo
3938 cgrad          kstart=min0(i+1,j)
3939 cgrad          kend=max0(i-1,j-1)
3940 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3941 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3942 cgrad          do k=kstart,kend
3943 cgrad            do l=1,3
3944 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3945 cgrad            enddo
3946 cgrad          enddo
3947           do k=1,3
3948             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3949             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3950           enddo
3951         enddo
3952
3953         enddo ! iint
3954       enddo ! i
3955       return
3956       end
3957 C-----------------------------------------------------------------------------
3958       subroutine escp(evdw2,evdw2_14)
3959 C
3960 C This subroutine calculates the excluded-volume interaction energy between
3961 C peptide-group centers and side chains and its gradient in virtual-bond and
3962 C side-chain vectors.
3963 C
3964       implicit real*8 (a-h,o-z)
3965       include 'DIMENSIONS'
3966       include 'COMMON.GEO'
3967       include 'COMMON.VAR'
3968       include 'COMMON.LOCAL'
3969       include 'COMMON.CHAIN'
3970       include 'COMMON.DERIV'
3971       include 'COMMON.INTERACT'
3972       include 'COMMON.FFIELD'
3973       include 'COMMON.IOUNITS'
3974       include 'COMMON.CONTROL'
3975       dimension ggg(3)
3976       evdw2=0.0D0
3977       evdw2_14=0.0d0
3978 cd    print '(a)','Enter ESCP'
3979 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3980       do i=iatscp_s,iatscp_e
3981         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3982         iteli=itel(i)
3983         xi=0.5D0*(c(1,i)+c(1,i+1))
3984         yi=0.5D0*(c(2,i)+c(2,i+1))
3985         zi=0.5D0*(c(3,i)+c(3,i+1))
3986
3987         do iint=1,nscp_gr(i)
3988
3989         do j=iscpstart(i,iint),iscpend(i,iint)
3990           itypj=iabs(itype(j))
3991           if (itypj.eq.ntyp1) cycle
3992 C Uncomment following three lines for SC-p interactions
3993 c         xj=c(1,nres+j)-xi
3994 c         yj=c(2,nres+j)-yi
3995 c         zj=c(3,nres+j)-zi
3996 C Uncomment following three lines for Ca-p interactions
3997           xj=c(1,j)-xi
3998           yj=c(2,j)-yi
3999           zj=c(3,j)-zi
4000           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4001           fac=rrij**expon2
4002           e1=fac*fac*aad(itypj,iteli)
4003           e2=fac*bad(itypj,iteli)
4004           if (iabs(j-i) .le. 2) then
4005             e1=scal14*e1
4006             e2=scal14*e2
4007             evdw2_14=evdw2_14+e1+e2
4008           endif
4009           evdwij=e1+e2
4010           evdw2=evdw2+evdwij
4011           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4012      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4013      &       bad(itypj,iteli)
4014 C
4015 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4016 C
4017           fac=-(evdwij+e1)*rrij
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 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4033 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4034 cgrad            enddo
4035 cgrad          endif
4036 cgrad          do k=1,3
4037 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4038 cgrad          enddo
4039 cgrad          kstart=min0(i+1,j)
4040 cgrad          kend=max0(i-1,j-1)
4041 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4042 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4043 cgrad          do k=kstart,kend
4044 cgrad            do l=1,3
4045 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4046 cgrad            enddo
4047 cgrad          enddo
4048           do k=1,3
4049             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4050             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4051           enddo
4052         enddo
4053
4054         enddo ! iint
4055       enddo ! i
4056       do i=1,nct
4057         do j=1,3
4058           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4059           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4060           gradx_scp(j,i)=expon*gradx_scp(j,i)
4061         enddo
4062       enddo
4063 C******************************************************************************
4064 C
4065 C                              N O T E !!!
4066 C
4067 C To save time the factor EXPON has been extracted from ALL components
4068 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4069 C use!
4070 C
4071 C******************************************************************************
4072       return
4073       end
4074 C--------------------------------------------------------------------------
4075       subroutine edis(ehpb)
4076 C
4077 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4078 C
4079       implicit real*8 (a-h,o-z)
4080       include 'DIMENSIONS'
4081       include 'COMMON.SBRIDGE'
4082       include 'COMMON.CHAIN'
4083       include 'COMMON.DERIV'
4084       include 'COMMON.VAR'
4085       include 'COMMON.INTERACT'
4086       include 'COMMON.IOUNITS'
4087       include 'COMMON.CONTROL'
4088       dimension ggg(3)
4089       ehpb=0.0D0
4090       do i=1,3
4091        ggg(i)=0.0d0
4092       enddo
4093 C      write (iout,*) ,"link_end",link_end,constr_dist
4094 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4095 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4096       if (link_end.eq.0) return
4097       do i=link_start,link_end
4098 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4099 C CA-CA distance used in regularization of structure.
4100         ii=ihpb(i)
4101         jj=jhpb(i)
4102 C iii and jjj point to the residues for which the distance is assigned.
4103         if (ii.gt.nres) then
4104           iii=ii-nres
4105           jjj=jj-nres
4106         else
4107           iii=ii
4108           jjj=jj
4109         endif
4110 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4111 c     &    dhpb(i),dhpb1(i),forcon(i)
4112 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4113 C    distance and angle dependent SS bond potential.
4114 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4115 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4116         if (.not.dyn_ss .and. i.le.nss) then
4117 C 15/02/13 CC dynamic SSbond - additional check
4118          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4119      & iabs(itype(jjj)).eq.1) then
4120           call ssbond_ene(iii,jjj,eij)
4121           ehpb=ehpb+2*eij
4122          endif
4123 cd          write (iout,*) "eij",eij
4124 cd   &   ' waga=',waga,' fac=',fac
4125         else if (ii.gt.nres .and. jj.gt.nres) then
4126 c Restraints from contact prediction
4127           dd=dist(ii,jj)
4128           if (constr_dist.eq.11) then
4129             ehpb=ehpb+fordepth(i)**4.0d0
4130      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4131             fac=fordepth(i)**4.0d0
4132      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4133           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4134      &    ehpb,fordepth(i),dd
4135            else
4136           if (dhpb1(i).gt.0.0d0) then
4137             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4138             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4139 c            write (iout,*) "beta nmr",
4140 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4141           else
4142             dd=dist(ii,jj)
4143             rdis=dd-dhpb(i)
4144 C Get the force constant corresponding to this distance.
4145             waga=forcon(i)
4146 C Calculate the contribution to energy.
4147             ehpb=ehpb+waga*rdis*rdis
4148 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4149 C
4150 C Evaluate gradient.
4151 C
4152             fac=waga*rdis/dd
4153           endif
4154           endif
4155           do j=1,3
4156             ggg(j)=fac*(c(j,jj)-c(j,ii))
4157           enddo
4158           do j=1,3
4159             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4160             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4161           enddo
4162           do k=1,3
4163             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4164             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4165           enddo
4166         else
4167 C Calculate the distance between the two points and its difference from the
4168 C target distance.
4169           dd=dist(ii,jj)
4170           if (constr_dist.eq.11) then
4171             ehpb=ehpb+fordepth(i)**4.0d0
4172      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4173             fac=fordepth(i)**4.0d0
4174      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4175           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4176      &    ehpb,fordepth(i),dd
4177            else
4178           if (dhpb1(i).gt.0.0d0) then
4179             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4180             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4181 c            write (iout,*) "alph nmr",
4182 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4183           else
4184             rdis=dd-dhpb(i)
4185 C Get the force constant corresponding to this distance.
4186             waga=forcon(i)
4187 C Calculate the contribution to energy.
4188             ehpb=ehpb+waga*rdis*rdis
4189 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4190 C
4191 C Evaluate gradient.
4192 C
4193             fac=waga*rdis/dd
4194           endif
4195           endif
4196             do j=1,3
4197               ggg(j)=fac*(c(j,jj)-c(j,ii))
4198             enddo
4199 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4200 C If this is a SC-SC distance, we need to calculate the contributions to the
4201 C Cartesian gradient in the SC vectors (ghpbx).
4202           if (iii.lt.ii) then
4203           do j=1,3
4204             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4205             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4206           enddo
4207           endif
4208 cgrad        do j=iii,jjj-1
4209 cgrad          do k=1,3
4210 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4211 cgrad          enddo
4212 cgrad        enddo
4213           do k=1,3
4214             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4215             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4216           enddo
4217         endif
4218       enddo
4219       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4220       return
4221       end
4222 C--------------------------------------------------------------------------
4223       subroutine ssbond_ene(i,j,eij)
4224 C
4225 C Calculate the distance and angle dependent SS-bond potential energy
4226 C using a free-energy function derived based on RHF/6-31G** ab initio
4227 C calculations of diethyl disulfide.
4228 C
4229 C A. Liwo and U. Kozlowska, 11/24/03
4230 C
4231       implicit real*8 (a-h,o-z)
4232       include 'DIMENSIONS'
4233       include 'COMMON.SBRIDGE'
4234       include 'COMMON.CHAIN'
4235       include 'COMMON.DERIV'
4236       include 'COMMON.LOCAL'
4237       include 'COMMON.INTERACT'
4238       include 'COMMON.VAR'
4239       include 'COMMON.IOUNITS'
4240       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4241       itypi=iabs(itype(i))
4242       xi=c(1,nres+i)
4243       yi=c(2,nres+i)
4244       zi=c(3,nres+i)
4245       dxi=dc_norm(1,nres+i)
4246       dyi=dc_norm(2,nres+i)
4247       dzi=dc_norm(3,nres+i)
4248 c      dsci_inv=dsc_inv(itypi)
4249       dsci_inv=vbld_inv(nres+i)
4250       itypj=iabs(itype(j))
4251 c      dscj_inv=dsc_inv(itypj)
4252       dscj_inv=vbld_inv(nres+j)
4253       xj=c(1,nres+j)-xi
4254       yj=c(2,nres+j)-yi
4255       zj=c(3,nres+j)-zi
4256       dxj=dc_norm(1,nres+j)
4257       dyj=dc_norm(2,nres+j)
4258       dzj=dc_norm(3,nres+j)
4259       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4260       rij=dsqrt(rrij)
4261       erij(1)=xj*rij
4262       erij(2)=yj*rij
4263       erij(3)=zj*rij
4264       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4265       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4266       om12=dxi*dxj+dyi*dyj+dzi*dzj
4267       do k=1,3
4268         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4269         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4270       enddo
4271       rij=1.0d0/rij
4272       deltad=rij-d0cm
4273       deltat1=1.0d0-om1
4274       deltat2=1.0d0+om2
4275       deltat12=om2-om1+2.0d0
4276       cosphi=om12-om1*om2
4277       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4278      &  +akct*deltad*deltat12
4279      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4280 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4281 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4282 c     &  " deltat12",deltat12," eij",eij
4283       ed=2*akcm*deltad+akct*deltat12
4284       pom1=akct*deltad
4285       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4286       eom1=-2*akth*deltat1-pom1-om2*pom2
4287       eom2= 2*akth*deltat2+pom1-om1*pom2
4288       eom12=pom2
4289       do k=1,3
4290         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4291         ghpbx(k,i)=ghpbx(k,i)-ggk
4292      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4293      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4294         ghpbx(k,j)=ghpbx(k,j)+ggk
4295      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4296      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4297         ghpbc(k,i)=ghpbc(k,i)-ggk
4298         ghpbc(k,j)=ghpbc(k,j)+ggk
4299       enddo
4300 C
4301 C Calculate the components of the gradient in DC and X
4302 C
4303 cgrad      do k=i,j-1
4304 cgrad        do l=1,3
4305 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4306 cgrad        enddo
4307 cgrad      enddo
4308       return
4309       end
4310 C--------------------------------------------------------------------------
4311       subroutine ebond(estr)
4312 c
4313 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4314 c
4315       implicit real*8 (a-h,o-z)
4316       include 'DIMENSIONS'
4317       include 'COMMON.LOCAL'
4318       include 'COMMON.GEO'
4319       include 'COMMON.INTERACT'
4320       include 'COMMON.DERIV'
4321       include 'COMMON.VAR'
4322       include 'COMMON.CHAIN'
4323       include 'COMMON.IOUNITS'
4324       include 'COMMON.NAMES'
4325       include 'COMMON.FFIELD'
4326       include 'COMMON.CONTROL'
4327       include 'COMMON.SETUP'
4328       double precision u(3),ud(3)
4329       estr=0.0d0
4330       estr1=0.0d0
4331       do i=ibondp_start,ibondp_end
4332         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4333           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4334           do j=1,3
4335           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4336      &      *dc(j,i-1)/vbld(i)
4337           enddo
4338           if (energy_dec) write(iout,*)
4339      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4340         else
4341         diff = vbld(i)-vbldp0
4342         if (energy_dec) write (iout,*)
4343      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4344         estr=estr+diff*diff
4345         do j=1,3
4346           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4347         enddo
4348 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4349         endif
4350       enddo
4351       estr=0.5d0*AKP*estr+estr1
4352 c
4353 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4354 c
4355       do i=ibond_start,ibond_end
4356         iti=iabs(itype(i))
4357         if (iti.ne.10 .and. iti.ne.ntyp1) then
4358           nbi=nbondterm(iti)
4359           if (nbi.eq.1) then
4360             diff=vbld(i+nres)-vbldsc0(1,iti)
4361             if (energy_dec) write (iout,*)
4362      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4363      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4364             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4365             do j=1,3
4366               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4367             enddo
4368           else
4369             do j=1,nbi
4370               diff=vbld(i+nres)-vbldsc0(j,iti)
4371               ud(j)=aksc(j,iti)*diff
4372               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4373             enddo
4374             uprod=u(1)
4375             do j=2,nbi
4376               uprod=uprod*u(j)
4377             enddo
4378             usum=0.0d0
4379             usumsqder=0.0d0
4380             do j=1,nbi
4381               uprod1=1.0d0
4382               uprod2=1.0d0
4383               do k=1,nbi
4384                 if (k.ne.j) then
4385                   uprod1=uprod1*u(k)
4386                   uprod2=uprod2*u(k)*u(k)
4387                 endif
4388               enddo
4389               usum=usum+uprod1
4390               usumsqder=usumsqder+ud(j)*uprod2
4391             enddo
4392             estr=estr+uprod/usum
4393             do j=1,3
4394              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4395             enddo
4396           endif
4397         endif
4398       enddo
4399       return
4400       end
4401 #ifdef CRYST_THETA
4402 C--------------------------------------------------------------------------
4403       subroutine ebend(etheta)
4404 C
4405 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4406 C angles gamma and its derivatives in consecutive thetas and gammas.
4407 C
4408       implicit real*8 (a-h,o-z)
4409       include 'DIMENSIONS'
4410       include 'COMMON.LOCAL'
4411       include 'COMMON.GEO'
4412       include 'COMMON.INTERACT'
4413       include 'COMMON.DERIV'
4414       include 'COMMON.VAR'
4415       include 'COMMON.CHAIN'
4416       include 'COMMON.IOUNITS'
4417       include 'COMMON.NAMES'
4418       include 'COMMON.FFIELD'
4419       include 'COMMON.CONTROL'
4420       common /calcthet/ term1,term2,termm,diffak,ratak,
4421      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4422      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4423       double precision y(2),z(2)
4424       delta=0.02d0*pi
4425 c      time11=dexp(-2*time)
4426 c      time12=1.0d0
4427       etheta=0.0D0
4428 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4429       do i=ithet_start,ithet_end
4430         if (itype(i-1).eq.ntyp1) cycle
4431 C Zero the energy function and its derivative at 0 or pi.
4432         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4433         it=itype(i-1)
4434         ichir1=isign(1,itype(i-2))
4435         ichir2=isign(1,itype(i))
4436          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4437          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4438          if (itype(i-1).eq.10) then
4439           itype1=isign(10,itype(i-2))
4440           ichir11=isign(1,itype(i-2))
4441           ichir12=isign(1,itype(i-2))
4442           itype2=isign(10,itype(i))
4443           ichir21=isign(1,itype(i))
4444           ichir22=isign(1,itype(i))
4445          endif
4446
4447         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4448 #ifdef OSF
4449           phii=phi(i)
4450           if (phii.ne.phii) phii=150.0
4451 #else
4452           phii=phi(i)
4453 #endif
4454           y(1)=dcos(phii)
4455           y(2)=dsin(phii)
4456         else
4457           y(1)=0.0D0
4458           y(2)=0.0D0
4459         endif
4460         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4461 #ifdef OSF
4462           phii1=phi(i+1)
4463           if (phii1.ne.phii1) phii1=150.0
4464           phii1=pinorm(phii1)
4465           z(1)=cos(phii1)
4466 #else
4467           phii1=phi(i+1)
4468           z(1)=dcos(phii1)
4469 #endif
4470           z(2)=dsin(phii1)
4471         else
4472           z(1)=0.0D0
4473           z(2)=0.0D0
4474         endif
4475 C Calculate the "mean" value of theta from the part of the distribution
4476 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4477 C In following comments this theta will be referred to as t_c.
4478         thet_pred_mean=0.0d0
4479         do k=1,2
4480             athetk=athet(k,it,ichir1,ichir2)
4481             bthetk=bthet(k,it,ichir1,ichir2)
4482           if (it.eq.10) then
4483              athetk=athet(k,itype1,ichir11,ichir12)
4484              bthetk=bthet(k,itype2,ichir21,ichir22)
4485           endif
4486          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4487         enddo
4488         dthett=thet_pred_mean*ssd
4489         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4490 C Derivatives of the "mean" values in gamma1 and gamma2.
4491         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4492      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4493          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4494      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4495          if (it.eq.10) then
4496       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4497      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4498         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4499      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4500          endif
4501         if (theta(i).gt.pi-delta) then
4502           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4503      &         E_tc0)
4504           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4505           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4506           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4507      &        E_theta)
4508           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4509      &        E_tc)
4510         else if (theta(i).lt.delta) then
4511           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4512           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4513           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4514      &        E_theta)
4515           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4516           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4517      &        E_tc)
4518         else
4519           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4520      &        E_theta,E_tc)
4521         endif
4522         etheta=etheta+ethetai
4523         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4524      &      'ebend',i,ethetai
4525         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4526         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4527         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4528       enddo
4529 C Ufff.... We've done all this!!!
4530       return
4531       end
4532 C---------------------------------------------------------------------------
4533       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4534      &     E_tc)
4535       implicit real*8 (a-h,o-z)
4536       include 'DIMENSIONS'
4537       include 'COMMON.LOCAL'
4538       include 'COMMON.IOUNITS'
4539       common /calcthet/ term1,term2,termm,diffak,ratak,
4540      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4541      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4542 C Calculate the contributions to both Gaussian lobes.
4543 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4544 C The "polynomial part" of the "standard deviation" of this part of
4545 C the distribution.
4546         sig=polthet(3,it)
4547         do j=2,0,-1
4548           sig=sig*thet_pred_mean+polthet(j,it)
4549         enddo
4550 C Derivative of the "interior part" of the "standard deviation of the"
4551 C gamma-dependent Gaussian lobe in t_c.
4552         sigtc=3*polthet(3,it)
4553         do j=2,1,-1
4554           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4555         enddo
4556         sigtc=sig*sigtc
4557 C Set the parameters of both Gaussian lobes of the distribution.
4558 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4559         fac=sig*sig+sigc0(it)
4560         sigcsq=fac+fac
4561         sigc=1.0D0/sigcsq
4562 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4563         sigsqtc=-4.0D0*sigcsq*sigtc
4564 c       print *,i,sig,sigtc,sigsqtc
4565 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4566         sigtc=-sigtc/(fac*fac)
4567 C Following variable is sigma(t_c)**(-2)
4568         sigcsq=sigcsq*sigcsq
4569         sig0i=sig0(it)
4570         sig0inv=1.0D0/sig0i**2
4571         delthec=thetai-thet_pred_mean
4572         delthe0=thetai-theta0i
4573         term1=-0.5D0*sigcsq*delthec*delthec
4574         term2=-0.5D0*sig0inv*delthe0*delthe0
4575 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4576 C NaNs in taking the logarithm. We extract the largest exponent which is added
4577 C to the energy (this being the log of the distribution) at the end of energy
4578 C term evaluation for this virtual-bond angle.
4579         if (term1.gt.term2) then
4580           termm=term1
4581           term2=dexp(term2-termm)
4582           term1=1.0d0
4583         else
4584           termm=term2
4585           term1=dexp(term1-termm)
4586           term2=1.0d0
4587         endif
4588 C The ratio between the gamma-independent and gamma-dependent lobes of
4589 C the distribution is a Gaussian function of thet_pred_mean too.
4590         diffak=gthet(2,it)-thet_pred_mean
4591         ratak=diffak/gthet(3,it)**2
4592         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4593 C Let's differentiate it in thet_pred_mean NOW.
4594         aktc=ak*ratak
4595 C Now put together the distribution terms to make complete distribution.
4596         termexp=term1+ak*term2
4597         termpre=sigc+ak*sig0i
4598 C Contribution of the bending energy from this theta is just the -log of
4599 C the sum of the contributions from the two lobes and the pre-exponential
4600 C factor. Simple enough, isn't it?
4601         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4602 C NOW the derivatives!!!
4603 C 6/6/97 Take into account the deformation.
4604         E_theta=(delthec*sigcsq*term1
4605      &       +ak*delthe0*sig0inv*term2)/termexp
4606         E_tc=((sigtc+aktc*sig0i)/termpre
4607      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4608      &       aktc*term2)/termexp)
4609       return
4610       end
4611 c-----------------------------------------------------------------------------
4612       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4613       implicit real*8 (a-h,o-z)
4614       include 'DIMENSIONS'
4615       include 'COMMON.LOCAL'
4616       include 'COMMON.IOUNITS'
4617       common /calcthet/ term1,term2,termm,diffak,ratak,
4618      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4619      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4620       delthec=thetai-thet_pred_mean
4621       delthe0=thetai-theta0i
4622 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4623       t3 = thetai-thet_pred_mean
4624       t6 = t3**2
4625       t9 = term1
4626       t12 = t3*sigcsq
4627       t14 = t12+t6*sigsqtc
4628       t16 = 1.0d0
4629       t21 = thetai-theta0i
4630       t23 = t21**2
4631       t26 = term2
4632       t27 = t21*t26
4633       t32 = termexp
4634       t40 = t32**2
4635       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4636      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4637      & *(-t12*t9-ak*sig0inv*t27)
4638       return
4639       end
4640 #else
4641 C--------------------------------------------------------------------------
4642       subroutine ebend(etheta)
4643 C
4644 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4645 C angles gamma and its derivatives in consecutive thetas and gammas.
4646 C ab initio-derived potentials from
4647 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4648 C
4649       implicit real*8 (a-h,o-z)
4650       include 'DIMENSIONS'
4651       include 'COMMON.LOCAL'
4652       include 'COMMON.GEO'
4653       include 'COMMON.INTERACT'
4654       include 'COMMON.DERIV'
4655       include 'COMMON.VAR'
4656       include 'COMMON.CHAIN'
4657       include 'COMMON.IOUNITS'
4658       include 'COMMON.NAMES'
4659       include 'COMMON.FFIELD'
4660       include 'COMMON.CONTROL'
4661       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4662      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4663      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4664      & sinph1ph2(maxdouble,maxdouble)
4665       logical lprn /.false./, lprn1 /.false./
4666       etheta=0.0D0
4667       do i=ithet_start,ithet_end
4668         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4669      &(itype(i).eq.ntyp1)) cycle
4670 C        print *,i,theta(i)
4671         if (iabs(itype(i+1)).eq.20) iblock=2
4672         if (iabs(itype(i+1)).ne.20) iblock=1
4673         dethetai=0.0d0
4674         dephii=0.0d0
4675         dephii1=0.0d0
4676         theti2=0.5d0*theta(i)
4677         ityp2=ithetyp((itype(i-1)))
4678         do k=1,nntheterm
4679           coskt(k)=dcos(k*theti2)
4680           sinkt(k)=dsin(k*theti2)
4681         enddo
4682 C        print *,ethetai
4683
4684         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4685 #ifdef OSF
4686           phii=phi(i)
4687           if (phii.ne.phii) phii=150.0
4688 #else
4689           phii=phi(i)
4690 #endif
4691           ityp1=ithetyp((itype(i-2)))
4692 C propagation of chirality for glycine type
4693           do k=1,nsingle
4694             cosph1(k)=dcos(k*phii)
4695             sinph1(k)=dsin(k*phii)
4696           enddo
4697         else
4698           phii=0.0d0
4699           do k=1,nsingle
4700           ityp1=ithetyp((itype(i-2)))
4701             cosph1(k)=0.0d0
4702             sinph1(k)=0.0d0
4703           enddo
4704         endif
4705         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4706 #ifdef OSF
4707           phii1=phi(i+1)
4708           if (phii1.ne.phii1) phii1=150.0
4709           phii1=pinorm(phii1)
4710 #else
4711           phii1=phi(i+1)
4712 #endif
4713           ityp3=ithetyp((itype(i)))
4714           do k=1,nsingle
4715             cosph2(k)=dcos(k*phii1)
4716             sinph2(k)=dsin(k*phii1)
4717           enddo
4718         else
4719           phii1=0.0d0
4720           ityp3=ithetyp((itype(i)))
4721           do k=1,nsingle
4722             cosph2(k)=0.0d0
4723             sinph2(k)=0.0d0
4724           enddo
4725         endif
4726         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4727         do k=1,ndouble
4728           do l=1,k-1
4729             ccl=cosph1(l)*cosph2(k-l)
4730             ssl=sinph1(l)*sinph2(k-l)
4731             scl=sinph1(l)*cosph2(k-l)
4732             csl=cosph1(l)*sinph2(k-l)
4733             cosph1ph2(l,k)=ccl-ssl
4734             cosph1ph2(k,l)=ccl+ssl
4735             sinph1ph2(l,k)=scl+csl
4736             sinph1ph2(k,l)=scl-csl
4737           enddo
4738         enddo
4739         if (lprn) then
4740         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4741      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4742         write (iout,*) "coskt and sinkt"
4743         do k=1,nntheterm
4744           write (iout,*) k,coskt(k),sinkt(k)
4745         enddo
4746         endif
4747         do k=1,ntheterm
4748           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4749           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4750      &      *coskt(k)
4751           if (lprn)
4752      &    write (iout,*) "k",k,"
4753      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4754      &     " ethetai",ethetai
4755         enddo
4756         if (lprn) then
4757         write (iout,*) "cosph and sinph"
4758         do k=1,nsingle
4759           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4760         enddo
4761         write (iout,*) "cosph1ph2 and sinph2ph2"
4762         do k=2,ndouble
4763           do l=1,k-1
4764             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4765      &         sinph1ph2(l,k),sinph1ph2(k,l)
4766           enddo
4767         enddo
4768         write(iout,*) "ethetai",ethetai
4769         endif
4770 C       print *,ethetai
4771         do m=1,ntheterm2
4772           do k=1,nsingle
4773             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4774      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4775      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4776      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4777             ethetai=ethetai+sinkt(m)*aux
4778             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4779             dephii=dephii+k*sinkt(m)*(
4780      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4781      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4782             dephii1=dephii1+k*sinkt(m)*(
4783      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4784      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4785             if (lprn)
4786      &      write (iout,*) "m",m," k",k," bbthet",
4787      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4788      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4789      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4790      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4791 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4792           enddo
4793         enddo
4794 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4795 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4796 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4797 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4798         if (lprn)
4799      &  write(iout,*) "ethetai",ethetai
4800 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4801         do m=1,ntheterm3
4802           do k=2,ndouble
4803             do l=1,k-1
4804               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4805      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4806      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4807      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4808               ethetai=ethetai+sinkt(m)*aux
4809               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4810               dephii=dephii+l*sinkt(m)*(
4811      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4812      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4813      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4814      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4815               dephii1=dephii1+(k-l)*sinkt(m)*(
4816      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4817      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4818      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4819      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4820               if (lprn) then
4821               write (iout,*) "m",m," k",k," l",l," ffthet",
4822      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4823      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4824      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4825      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4826      &            " ethetai",ethetai
4827               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4828      &            cosph1ph2(k,l)*sinkt(m),
4829      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4830               endif
4831             enddo
4832           enddo
4833         enddo
4834 10      continue
4835 c        lprn1=.true.
4836 C        print *,ethetai
4837         if (lprn1)
4838      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4839      &   i,theta(i)*rad2deg,phii*rad2deg,
4840      &   phii1*rad2deg,ethetai
4841 c        lprn1=.false.
4842         etheta=etheta+ethetai
4843         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4844         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4845         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4846       enddo
4847       return
4848       end
4849 #endif
4850 #ifdef CRYST_SC
4851 c-----------------------------------------------------------------------------
4852       subroutine esc(escloc)
4853 C Calculate the local energy of a side chain and its derivatives in the
4854 C corresponding virtual-bond valence angles THETA and the spherical angles
4855 C ALPHA and OMEGA.
4856       implicit real*8 (a-h,o-z)
4857       include 'DIMENSIONS'
4858       include 'COMMON.GEO'
4859       include 'COMMON.LOCAL'
4860       include 'COMMON.VAR'
4861       include 'COMMON.INTERACT'
4862       include 'COMMON.DERIV'
4863       include 'COMMON.CHAIN'
4864       include 'COMMON.IOUNITS'
4865       include 'COMMON.NAMES'
4866       include 'COMMON.FFIELD'
4867       include 'COMMON.CONTROL'
4868       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4869      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4870       common /sccalc/ time11,time12,time112,theti,it,nlobit
4871       delta=0.02d0*pi
4872       escloc=0.0D0
4873 c     write (iout,'(a)') 'ESC'
4874       do i=loc_start,loc_end
4875         it=itype(i)
4876         if (it.eq.ntyp1) cycle
4877         if (it.eq.10) goto 1
4878         nlobit=nlob(iabs(it))
4879 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4880 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4881         theti=theta(i+1)-pipol
4882         x(1)=dtan(theti)
4883         x(2)=alph(i)
4884         x(3)=omeg(i)
4885
4886         if (x(2).gt.pi-delta) then
4887           xtemp(1)=x(1)
4888           xtemp(2)=pi-delta
4889           xtemp(3)=x(3)
4890           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4891           xtemp(2)=pi
4892           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4893           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4894      &        escloci,dersc(2))
4895           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4896      &        ddersc0(1),dersc(1))
4897           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4898      &        ddersc0(3),dersc(3))
4899           xtemp(2)=pi-delta
4900           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4901           xtemp(2)=pi
4902           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4903           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4904      &            dersc0(2),esclocbi,dersc02)
4905           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4906      &            dersc12,dersc01)
4907           call splinthet(x(2),0.5d0*delta,ss,ssd)
4908           dersc0(1)=dersc01
4909           dersc0(2)=dersc02
4910           dersc0(3)=0.0d0
4911           do k=1,3
4912             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4913           enddo
4914           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4915 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4916 c    &             esclocbi,ss,ssd
4917           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4918 c         escloci=esclocbi
4919 c         write (iout,*) escloci
4920         else if (x(2).lt.delta) then
4921           xtemp(1)=x(1)
4922           xtemp(2)=delta
4923           xtemp(3)=x(3)
4924           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4925           xtemp(2)=0.0d0
4926           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4927           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4928      &        escloci,dersc(2))
4929           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4930      &        ddersc0(1),dersc(1))
4931           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4932      &        ddersc0(3),dersc(3))
4933           xtemp(2)=delta
4934           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4935           xtemp(2)=0.0d0
4936           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4937           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4938      &            dersc0(2),esclocbi,dersc02)
4939           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4940      &            dersc12,dersc01)
4941           dersc0(1)=dersc01
4942           dersc0(2)=dersc02
4943           dersc0(3)=0.0d0
4944           call splinthet(x(2),0.5d0*delta,ss,ssd)
4945           do k=1,3
4946             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4947           enddo
4948           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4949 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4950 c    &             esclocbi,ss,ssd
4951           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4952 c         write (iout,*) escloci
4953         else
4954           call enesc(x,escloci,dersc,ddummy,.false.)
4955         endif
4956
4957         escloc=escloc+escloci
4958         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4959      &     'escloc',i,escloci
4960 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4961
4962         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4963      &   wscloc*dersc(1)
4964         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4965         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4966     1   continue
4967       enddo
4968       return
4969       end
4970 C---------------------------------------------------------------------------
4971       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4972       implicit real*8 (a-h,o-z)
4973       include 'DIMENSIONS'
4974       include 'COMMON.GEO'
4975       include 'COMMON.LOCAL'
4976       include 'COMMON.IOUNITS'
4977       common /sccalc/ time11,time12,time112,theti,it,nlobit
4978       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4979       double precision contr(maxlob,-1:1)
4980       logical mixed
4981 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4982         escloc_i=0.0D0
4983         do j=1,3
4984           dersc(j)=0.0D0
4985           if (mixed) ddersc(j)=0.0d0
4986         enddo
4987         x3=x(3)
4988
4989 C Because of periodicity of the dependence of the SC energy in omega we have
4990 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4991 C To avoid underflows, first compute & store the exponents.
4992
4993         do iii=-1,1
4994
4995           x(3)=x3+iii*dwapi
4996
4997           do j=1,nlobit
4998             do k=1,3
4999               z(k)=x(k)-censc(k,j,it)
5000             enddo
5001             do k=1,3
5002               Axk=0.0D0
5003               do l=1,3
5004                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5005               enddo
5006               Ax(k,j,iii)=Axk
5007             enddo
5008             expfac=0.0D0
5009             do k=1,3
5010               expfac=expfac+Ax(k,j,iii)*z(k)
5011             enddo
5012             contr(j,iii)=expfac
5013           enddo ! j
5014
5015         enddo ! iii
5016
5017         x(3)=x3
5018 C As in the case of ebend, we want to avoid underflows in exponentiation and
5019 C subsequent NaNs and INFs in energy calculation.
5020 C Find the largest exponent
5021         emin=contr(1,-1)
5022         do iii=-1,1
5023           do j=1,nlobit
5024             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5025           enddo
5026         enddo
5027         emin=0.5D0*emin
5028 cd      print *,'it=',it,' emin=',emin
5029
5030 C Compute the contribution to SC energy and derivatives
5031         do iii=-1,1
5032
5033           do j=1,nlobit
5034 #ifdef OSF
5035             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5036             if(adexp.ne.adexp) adexp=1.0
5037             expfac=dexp(adexp)
5038 #else
5039             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5040 #endif
5041 cd          print *,'j=',j,' expfac=',expfac
5042             escloc_i=escloc_i+expfac
5043             do k=1,3
5044               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5045             enddo
5046             if (mixed) then
5047               do k=1,3,2
5048                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5049      &            +gaussc(k,2,j,it))*expfac
5050               enddo
5051             endif
5052           enddo
5053
5054         enddo ! iii
5055
5056         dersc(1)=dersc(1)/cos(theti)**2
5057         ddersc(1)=ddersc(1)/cos(theti)**2
5058         ddersc(3)=ddersc(3)
5059
5060         escloci=-(dlog(escloc_i)-emin)
5061         do j=1,3
5062           dersc(j)=dersc(j)/escloc_i
5063         enddo
5064         if (mixed) then
5065           do j=1,3,2
5066             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5067           enddo
5068         endif
5069       return
5070       end
5071 C------------------------------------------------------------------------------
5072       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5073       implicit real*8 (a-h,o-z)
5074       include 'DIMENSIONS'
5075       include 'COMMON.GEO'
5076       include 'COMMON.LOCAL'
5077       include 'COMMON.IOUNITS'
5078       common /sccalc/ time11,time12,time112,theti,it,nlobit
5079       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5080       double precision contr(maxlob)
5081       logical mixed
5082
5083       escloc_i=0.0D0
5084
5085       do j=1,3
5086         dersc(j)=0.0D0
5087       enddo
5088
5089       do j=1,nlobit
5090         do k=1,2
5091           z(k)=x(k)-censc(k,j,it)
5092         enddo
5093         z(3)=dwapi
5094         do k=1,3
5095           Axk=0.0D0
5096           do l=1,3
5097             Axk=Axk+gaussc(l,k,j,it)*z(l)
5098           enddo
5099           Ax(k,j)=Axk
5100         enddo
5101         expfac=0.0D0
5102         do k=1,3
5103           expfac=expfac+Ax(k,j)*z(k)
5104         enddo
5105         contr(j)=expfac
5106       enddo ! j
5107
5108 C As in the case of ebend, we want to avoid underflows in exponentiation and
5109 C subsequent NaNs and INFs in energy calculation.
5110 C Find the largest exponent
5111       emin=contr(1)
5112       do j=1,nlobit
5113         if (emin.gt.contr(j)) emin=contr(j)
5114       enddo
5115       emin=0.5D0*emin
5116
5117 C Compute the contribution to SC energy and derivatives
5118
5119       dersc12=0.0d0
5120       do j=1,nlobit
5121         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5122         escloc_i=escloc_i+expfac
5123         do k=1,2
5124           dersc(k)=dersc(k)+Ax(k,j)*expfac
5125         enddo
5126         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5127      &            +gaussc(1,2,j,it))*expfac
5128         dersc(3)=0.0d0
5129       enddo
5130
5131       dersc(1)=dersc(1)/cos(theti)**2
5132       dersc12=dersc12/cos(theti)**2
5133       escloci=-(dlog(escloc_i)-emin)
5134       do j=1,2
5135         dersc(j)=dersc(j)/escloc_i
5136       enddo
5137       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5138       return
5139       end
5140 #else
5141 c----------------------------------------------------------------------------------
5142       subroutine esc(escloc)
5143 C Calculate the local energy of a side chain and its derivatives in the
5144 C corresponding virtual-bond valence angles THETA and the spherical angles
5145 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5146 C added by Urszula Kozlowska. 07/11/2007
5147 C
5148       implicit real*8 (a-h,o-z)
5149       include 'DIMENSIONS'
5150       include 'COMMON.GEO'
5151       include 'COMMON.LOCAL'
5152       include 'COMMON.VAR'
5153       include 'COMMON.SCROT'
5154       include 'COMMON.INTERACT'
5155       include 'COMMON.DERIV'
5156       include 'COMMON.CHAIN'
5157       include 'COMMON.IOUNITS'
5158       include 'COMMON.NAMES'
5159       include 'COMMON.FFIELD'
5160       include 'COMMON.CONTROL'
5161       include 'COMMON.VECTORS'
5162       double precision x_prime(3),y_prime(3),z_prime(3)
5163      &    , sumene,dsc_i,dp2_i,x(65),
5164      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5165      &    de_dxx,de_dyy,de_dzz,de_dt
5166       double precision s1_t,s1_6_t,s2_t,s2_6_t
5167       double precision
5168      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5169      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5170      & dt_dCi(3),dt_dCi1(3)
5171       common /sccalc/ time11,time12,time112,theti,it,nlobit
5172       delta=0.02d0*pi
5173       escloc=0.0D0
5174       do i=loc_start,loc_end
5175         if (itype(i).eq.ntyp1) cycle
5176         costtab(i+1) =dcos(theta(i+1))
5177         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5178         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5179         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5180         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5181         cosfac=dsqrt(cosfac2)
5182         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5183         sinfac=dsqrt(sinfac2)
5184         it=iabs(itype(i))
5185         if (it.eq.10) goto 1
5186 c
5187 C  Compute the axes of tghe local cartesian coordinates system; store in
5188 c   x_prime, y_prime and z_prime
5189 c
5190         do j=1,3
5191           x_prime(j) = 0.00
5192           y_prime(j) = 0.00
5193           z_prime(j) = 0.00
5194         enddo
5195 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5196 C     &   dc_norm(3,i+nres)
5197         do j = 1,3
5198           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5199           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5200         enddo
5201         do j = 1,3
5202           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5203         enddo
5204 c       write (2,*) "i",i
5205 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5206 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5207 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5208 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5209 c      & " xy",scalar(x_prime(1),y_prime(1)),
5210 c      & " xz",scalar(x_prime(1),z_prime(1)),
5211 c      & " yy",scalar(y_prime(1),y_prime(1)),
5212 c      & " yz",scalar(y_prime(1),z_prime(1)),
5213 c      & " zz",scalar(z_prime(1),z_prime(1))
5214 c
5215 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5216 C to local coordinate system. Store in xx, yy, zz.
5217 c
5218         xx=0.0d0
5219         yy=0.0d0
5220         zz=0.0d0
5221         do j = 1,3
5222           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5223           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5224           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5225         enddo
5226
5227         xxtab(i)=xx
5228         yytab(i)=yy
5229         zztab(i)=zz
5230 C
5231 C Compute the energy of the ith side cbain
5232 C
5233 c        write (2,*) "xx",xx," yy",yy," zz",zz
5234         it=iabs(itype(i))
5235         do j = 1,65
5236           x(j) = sc_parmin(j,it)
5237         enddo
5238 #ifdef CHECK_COORD
5239 Cc diagnostics - remove later
5240         xx1 = dcos(alph(2))
5241         yy1 = dsin(alph(2))*dcos(omeg(2))
5242         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5243         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5244      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5245      &    xx1,yy1,zz1
5246 C,"  --- ", xx_w,yy_w,zz_w
5247 c end diagnostics
5248 #endif
5249         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5250      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5251      &   + x(10)*yy*zz
5252         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5253      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5254      & + x(20)*yy*zz
5255         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5256      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5257      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5258      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5259      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5260      &  +x(40)*xx*yy*zz
5261         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5262      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5263      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5264      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5265      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5266      &  +x(60)*xx*yy*zz
5267         dsc_i   = 0.743d0+x(61)
5268         dp2_i   = 1.9d0+x(62)
5269         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5270      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5271         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5272      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5273         s1=(1+x(63))/(0.1d0 + dscp1)
5274         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5275         s2=(1+x(65))/(0.1d0 + dscp2)
5276         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5277         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5278      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5279 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5280 c     &   sumene4,
5281 c     &   dscp1,dscp2,sumene
5282 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5283         escloc = escloc + sumene
5284 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5285 c     & ,zz,xx,yy
5286 c#define DEBUG
5287 #ifdef DEBUG
5288 C
5289 C This section to check the numerical derivatives of the energy of ith side
5290 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5291 C #define DEBUG in the code to turn it on.
5292 C
5293         write (2,*) "sumene               =",sumene
5294         aincr=1.0d-7
5295         xxsave=xx
5296         xx=xx+aincr
5297         write (2,*) xx,yy,zz
5298         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5299         de_dxx_num=(sumenep-sumene)/aincr
5300         xx=xxsave
5301         write (2,*) "xx+ sumene from enesc=",sumenep
5302         yysave=yy
5303         yy=yy+aincr
5304         write (2,*) xx,yy,zz
5305         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5306         de_dyy_num=(sumenep-sumene)/aincr
5307         yy=yysave
5308         write (2,*) "yy+ sumene from enesc=",sumenep
5309         zzsave=zz
5310         zz=zz+aincr
5311         write (2,*) xx,yy,zz
5312         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5313         de_dzz_num=(sumenep-sumene)/aincr
5314         zz=zzsave
5315         write (2,*) "zz+ sumene from enesc=",sumenep
5316         costsave=cost2tab(i+1)
5317         sintsave=sint2tab(i+1)
5318         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5319         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5320         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5321         de_dt_num=(sumenep-sumene)/aincr
5322         write (2,*) " t+ sumene from enesc=",sumenep
5323         cost2tab(i+1)=costsave
5324         sint2tab(i+1)=sintsave
5325 C End of diagnostics section.
5326 #endif
5327 C
5328 C Compute the gradient of esc
5329 C
5330 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5331         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5332         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5333         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5334         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5335         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5336         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5337         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5338         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5339         pom1=(sumene3*sint2tab(i+1)+sumene1)
5340      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5341         pom2=(sumene4*cost2tab(i+1)+sumene2)
5342      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5343         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5344         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5345      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5346      &  +x(40)*yy*zz
5347         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5348         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5349      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5350      &  +x(60)*yy*zz
5351         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5352      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5353      &        +(pom1+pom2)*pom_dx
5354 #ifdef DEBUG
5355         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5356 #endif
5357 C
5358         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5359         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5360      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5361      &  +x(40)*xx*zz
5362         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5363         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5364      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5365      &  +x(59)*zz**2 +x(60)*xx*zz
5366         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5367      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5368      &        +(pom1-pom2)*pom_dy
5369 #ifdef DEBUG
5370         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5371 #endif
5372 C
5373         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5374      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5375      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5376      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5377      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5378      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5379      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5380      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5381 #ifdef DEBUG
5382         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5383 #endif
5384 C
5385         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5386      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5387      &  +pom1*pom_dt1+pom2*pom_dt2
5388 #ifdef DEBUG
5389         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5390 #endif
5391 c#undef DEBUG
5392 c
5393 C
5394        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5395        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5396        cosfac2xx=cosfac2*xx
5397        sinfac2yy=sinfac2*yy
5398        do k = 1,3
5399          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5400      &      vbld_inv(i+1)
5401          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5402      &      vbld_inv(i)
5403          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5404          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5405 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5406 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5407 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5408 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5409          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5410          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5411          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5412          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5413          dZZ_Ci1(k)=0.0d0
5414          dZZ_Ci(k)=0.0d0
5415          do j=1,3
5416            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5417      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5418            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5419      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5420          enddo
5421
5422          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5423          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5424          dZZ_XYZ(k)=vbld_inv(i+nres)*
5425      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5426 c
5427          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5428          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5429        enddo
5430
5431        do k=1,3
5432          dXX_Ctab(k,i)=dXX_Ci(k)
5433          dXX_C1tab(k,i)=dXX_Ci1(k)
5434          dYY_Ctab(k,i)=dYY_Ci(k)
5435          dYY_C1tab(k,i)=dYY_Ci1(k)
5436          dZZ_Ctab(k,i)=dZZ_Ci(k)
5437          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5438          dXX_XYZtab(k,i)=dXX_XYZ(k)
5439          dYY_XYZtab(k,i)=dYY_XYZ(k)
5440          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5441        enddo
5442
5443        do k = 1,3
5444 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5445 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5446 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5447 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5448 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5449 c     &    dt_dci(k)
5450 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5451 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5452          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5453      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5454          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5455      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5456          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5457      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5458        enddo
5459 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5460 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5461
5462 C to check gradient call subroutine check_grad
5463
5464     1 continue
5465       enddo
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5470       implicit none
5471       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5472      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5473       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5474      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5475      &   + x(10)*yy*zz
5476       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5477      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5478      & + x(20)*yy*zz
5479       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5480      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5481      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5482      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5483      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5484      &  +x(40)*xx*yy*zz
5485       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5486      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5487      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5488      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5489      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5490      &  +x(60)*xx*yy*zz
5491       dsc_i   = 0.743d0+x(61)
5492       dp2_i   = 1.9d0+x(62)
5493       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5494      &          *(xx*cost2+yy*sint2))
5495       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5496      &          *(xx*cost2-yy*sint2))
5497       s1=(1+x(63))/(0.1d0 + dscp1)
5498       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5499       s2=(1+x(65))/(0.1d0 + dscp2)
5500       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5501       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5502      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5503       enesc=sumene
5504       return
5505       end
5506 #endif
5507 c------------------------------------------------------------------------------
5508       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5509 C
5510 C This procedure calculates two-body contact function g(rij) and its derivative:
5511 C
5512 C           eps0ij                                     !       x < -1
5513 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5514 C            0                                         !       x > 1
5515 C
5516 C where x=(rij-r0ij)/delta
5517 C
5518 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5519 C
5520       implicit none
5521       double precision rij,r0ij,eps0ij,fcont,fprimcont
5522       double precision x,x2,x4,delta
5523 c     delta=0.02D0*r0ij
5524 c      delta=0.2D0*r0ij
5525       x=(rij-r0ij)/delta
5526       if (x.lt.-1.0D0) then
5527         fcont=eps0ij
5528         fprimcont=0.0D0
5529       else if (x.le.1.0D0) then
5530         x2=x*x
5531         x4=x2*x2
5532         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5533         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5534       else
5535         fcont=0.0D0
5536         fprimcont=0.0D0
5537       endif
5538       return
5539       end
5540 c------------------------------------------------------------------------------
5541       subroutine splinthet(theti,delta,ss,ssder)
5542       implicit real*8 (a-h,o-z)
5543       include 'DIMENSIONS'
5544       include 'COMMON.VAR'
5545       include 'COMMON.GEO'
5546       thetup=pi-delta
5547       thetlow=delta
5548       if (theti.gt.pipol) then
5549         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5550       else
5551         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5552         ssder=-ssder
5553       endif
5554       return
5555       end
5556 c------------------------------------------------------------------------------
5557       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5558       implicit none
5559       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5560       double precision ksi,ksi2,ksi3,a1,a2,a3
5561       a1=fprim0*delta/(f1-f0)
5562       a2=3.0d0-2.0d0*a1
5563       a3=a1-2.0d0
5564       ksi=(x-x0)/delta
5565       ksi2=ksi*ksi
5566       ksi3=ksi2*ksi
5567       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5568       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5569       return
5570       end
5571 c------------------------------------------------------------------------------
5572       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5573       implicit none
5574       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5575       double precision ksi,ksi2,ksi3,a1,a2,a3
5576       ksi=(x-x0)/delta
5577       ksi2=ksi*ksi
5578       ksi3=ksi2*ksi
5579       a1=fprim0x*delta
5580       a2=3*(f1x-f0x)-2*fprim0x*delta
5581       a3=fprim0x*delta-2*(f1x-f0x)
5582       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5583       return
5584       end
5585 C-----------------------------------------------------------------------------
5586 #ifdef CRYST_TOR
5587 C-----------------------------------------------------------------------------
5588       subroutine etor(etors,edihcnstr)
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       include 'COMMON.VAR'
5592       include 'COMMON.GEO'
5593       include 'COMMON.LOCAL'
5594       include 'COMMON.TORSION'
5595       include 'COMMON.INTERACT'
5596       include 'COMMON.DERIV'
5597       include 'COMMON.CHAIN'
5598       include 'COMMON.NAMES'
5599       include 'COMMON.IOUNITS'
5600       include 'COMMON.FFIELD'
5601       include 'COMMON.TORCNSTR'
5602       include 'COMMON.CONTROL'
5603       logical lprn
5604 C Set lprn=.true. for debugging
5605       lprn=.false.
5606 c      lprn=.true.
5607       etors=0.0D0
5608       do i=iphi_start,iphi_end
5609       etors_ii=0.0D0
5610         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5611      &      .or. itype(i).eq.ntyp1) cycle
5612         itori=itortyp(itype(i-2))
5613         itori1=itortyp(itype(i-1))
5614         phii=phi(i)
5615         gloci=0.0D0
5616 C Proline-Proline pair is a special case...
5617         if (itori.eq.3 .and. itori1.eq.3) then
5618           if (phii.gt.-dwapi3) then
5619             cosphi=dcos(3*phii)
5620             fac=1.0D0/(1.0D0-cosphi)
5621             etorsi=v1(1,3,3)*fac
5622             etorsi=etorsi+etorsi
5623             etors=etors+etorsi-v1(1,3,3)
5624             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5625             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5626           endif
5627           do j=1,3
5628             v1ij=v1(j+1,itori,itori1)
5629             v2ij=v2(j+1,itori,itori1)
5630             cosphi=dcos(j*phii)
5631             sinphi=dsin(j*phii)
5632             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5633             if (energy_dec) etors_ii=etors_ii+
5634      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5635             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5636           enddo
5637         else
5638           do j=1,nterm_old
5639             v1ij=v1(j,itori,itori1)
5640             v2ij=v2(j,itori,itori1)
5641             cosphi=dcos(j*phii)
5642             sinphi=dsin(j*phii)
5643             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5644             if (energy_dec) etors_ii=etors_ii+
5645      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5646             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5647           enddo
5648         endif
5649         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5650              'etor',i,etors_ii
5651         if (lprn)
5652      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5653      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5654      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5655         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5656 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5657       enddo
5658 ! 6/20/98 - dihedral angle constraints
5659       edihcnstr=0.0d0
5660       do i=1,ndih_constr
5661         itori=idih_constr(i)
5662         phii=phi(itori)
5663         difi=phii-phi0(i)
5664         if (difi.gt.drange(i)) then
5665           difi=difi-drange(i)
5666           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5667           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5668         else if (difi.lt.-drange(i)) then
5669           difi=difi+drange(i)
5670           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5671           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5672         endif
5673 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5674 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5675       enddo
5676 !      write (iout,*) 'edihcnstr',edihcnstr
5677       return
5678       end
5679 c------------------------------------------------------------------------------
5680       subroutine etor_d(etors_d)
5681       etors_d=0.0d0
5682       return
5683       end
5684 c----------------------------------------------------------------------------
5685 #else
5686       subroutine etor(etors,edihcnstr)
5687       implicit real*8 (a-h,o-z)
5688       include 'DIMENSIONS'
5689       include 'COMMON.VAR'
5690       include 'COMMON.GEO'
5691       include 'COMMON.LOCAL'
5692       include 'COMMON.TORSION'
5693       include 'COMMON.INTERACT'
5694       include 'COMMON.DERIV'
5695       include 'COMMON.CHAIN'
5696       include 'COMMON.NAMES'
5697       include 'COMMON.IOUNITS'
5698       include 'COMMON.FFIELD'
5699       include 'COMMON.TORCNSTR'
5700       include 'COMMON.CONTROL'
5701       logical lprn
5702 C Set lprn=.true. for debugging
5703       lprn=.false.
5704 c     lprn=.true.
5705       etors=0.0D0
5706       do i=iphi_start,iphi_end
5707         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5708      &       .or. itype(i).eq.ntyp1) cycle
5709         etors_ii=0.0D0
5710          if (iabs(itype(i)).eq.20) then
5711          iblock=2
5712          else
5713          iblock=1
5714          endif
5715         itori=itortyp(itype(i-2))
5716         itori1=itortyp(itype(i-1))
5717         phii=phi(i)
5718         gloci=0.0D0
5719 C Regular cosine and sine terms
5720         do j=1,nterm(itori,itori1,iblock)
5721           v1ij=v1(j,itori,itori1,iblock)
5722           v2ij=v2(j,itori,itori1,iblock)
5723           cosphi=dcos(j*phii)
5724           sinphi=dsin(j*phii)
5725           etors=etors+v1ij*cosphi+v2ij*sinphi
5726           if (energy_dec) etors_ii=etors_ii+
5727      &                v1ij*cosphi+v2ij*sinphi
5728           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5729         enddo
5730 C Lorentz terms
5731 C                         v1
5732 C  E = SUM ----------------------------------- - v1
5733 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5734 C
5735         cosphi=dcos(0.5d0*phii)
5736         sinphi=dsin(0.5d0*phii)
5737         do j=1,nlor(itori,itori1,iblock)
5738           vl1ij=vlor1(j,itori,itori1)
5739           vl2ij=vlor2(j,itori,itori1)
5740           vl3ij=vlor3(j,itori,itori1)
5741           pom=vl2ij*cosphi+vl3ij*sinphi
5742           pom1=1.0d0/(pom*pom+1.0d0)
5743           etors=etors+vl1ij*pom1
5744           if (energy_dec) etors_ii=etors_ii+
5745      &                vl1ij*pom1
5746           pom=-pom*pom1*pom1
5747           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5748         enddo
5749 C Subtract the constant term
5750         etors=etors-v0(itori,itori1,iblock)
5751           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5752      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5753         if (lprn)
5754      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5755      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5756      &  (v1(j,itori,itori1,iblock),j=1,6),
5757      &  (v2(j,itori,itori1,iblock),j=1,6)
5758         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5759 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5760       enddo
5761 ! 6/20/98 - dihedral angle constraints
5762       edihcnstr=0.0d0
5763 c      do i=1,ndih_constr
5764       do i=idihconstr_start,idihconstr_end
5765         itori=idih_constr(i)
5766         phii=phi(itori)
5767         difi=pinorm(phii-phi0(i))
5768         if (difi.gt.drange(i)) then
5769           difi=difi-drange(i)
5770           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5771           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5772         else if (difi.lt.-drange(i)) then
5773           difi=difi+drange(i)
5774           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5775           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5776         else
5777           difi=0.0
5778         endif
5779 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5780 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5781 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5782       enddo
5783 cd       write (iout,*) 'edihcnstr',edihcnstr
5784       return
5785       end
5786 c----------------------------------------------------------------------------
5787       subroutine etor_d(etors_d)
5788 C 6/23/01 Compute double torsional energy
5789       implicit real*8 (a-h,o-z)
5790       include 'DIMENSIONS'
5791       include 'COMMON.VAR'
5792       include 'COMMON.GEO'
5793       include 'COMMON.LOCAL'
5794       include 'COMMON.TORSION'
5795       include 'COMMON.INTERACT'
5796       include 'COMMON.DERIV'
5797       include 'COMMON.CHAIN'
5798       include 'COMMON.NAMES'
5799       include 'COMMON.IOUNITS'
5800       include 'COMMON.FFIELD'
5801       include 'COMMON.TORCNSTR'
5802       logical lprn
5803 C Set lprn=.true. for debugging
5804       lprn=.false.
5805 c     lprn=.true.
5806       etors_d=0.0D0
5807 c      write(iout,*) "a tu??"
5808       do i=iphid_start,iphid_end
5809         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5810      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5811         itori=itortyp(itype(i-2))
5812         itori1=itortyp(itype(i-1))
5813         itori2=itortyp(itype(i))
5814         phii=phi(i)
5815         phii1=phi(i+1)
5816         gloci1=0.0D0
5817         gloci2=0.0D0
5818         iblock=1
5819         if (iabs(itype(i+1)).eq.20) iblock=2
5820
5821 C Regular cosine and sine terms
5822         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5823           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5824           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5825           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5826           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5827           cosphi1=dcos(j*phii)
5828           sinphi1=dsin(j*phii)
5829           cosphi2=dcos(j*phii1)
5830           sinphi2=dsin(j*phii1)
5831           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5832      &     v2cij*cosphi2+v2sij*sinphi2
5833           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5834           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5835         enddo
5836         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5837           do l=1,k-1
5838             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5839             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5840             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5841             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5842             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5843             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5844             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5845             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5846             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5847      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5848             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5849      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5850             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5851      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5852           enddo
5853         enddo
5854         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5855         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5856       enddo
5857       return
5858       end
5859 #endif
5860 c------------------------------------------------------------------------------
5861       subroutine eback_sc_corr(esccor)
5862 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5863 c        conformational states; temporarily implemented as differences
5864 c        between UNRES torsional potentials (dependent on three types of
5865 c        residues) and the torsional potentials dependent on all 20 types
5866 c        of residues computed from AM1  energy surfaces of terminally-blocked
5867 c        amino-acid residues.
5868       implicit real*8 (a-h,o-z)
5869       include 'DIMENSIONS'
5870       include 'COMMON.VAR'
5871       include 'COMMON.GEO'
5872       include 'COMMON.LOCAL'
5873       include 'COMMON.TORSION'
5874       include 'COMMON.SCCOR'
5875       include 'COMMON.INTERACT'
5876       include 'COMMON.DERIV'
5877       include 'COMMON.CHAIN'
5878       include 'COMMON.NAMES'
5879       include 'COMMON.IOUNITS'
5880       include 'COMMON.FFIELD'
5881       include 'COMMON.CONTROL'
5882       logical lprn
5883 C Set lprn=.true. for debugging
5884       lprn=.false.
5885 c      lprn=.true.
5886 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5887       esccor=0.0D0
5888       do i=itau_start,itau_end
5889         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5890         esccor_ii=0.0D0
5891         isccori=isccortyp(itype(i-2))
5892         isccori1=isccortyp(itype(i-1))
5893 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5894         phii=phi(i)
5895         do intertyp=1,3 !intertyp
5896 cc Added 09 May 2012 (Adasko)
5897 cc  Intertyp means interaction type of backbone mainchain correlation:
5898 c   1 = SC...Ca...Ca...Ca
5899 c   2 = Ca...Ca...Ca...SC
5900 c   3 = SC...Ca...Ca...SCi
5901         gloci=0.0D0
5902         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5903      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5904      &      (itype(i-1).eq.ntyp1)))
5905      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5906      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5907      &     .or.(itype(i).eq.ntyp1)))
5908      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5909      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5910      &      (itype(i-3).eq.ntyp1)))) cycle
5911         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5912         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5913      & cycle
5914        do j=1,nterm_sccor(isccori,isccori1)
5915           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5916           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5917           cosphi=dcos(j*tauangle(intertyp,i))
5918           sinphi=dsin(j*tauangle(intertyp,i))
5919           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5920           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5921         enddo
5922 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5923         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5924         if (lprn)
5925      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5926      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5927      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5928      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5929         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5930        enddo !intertyp
5931       enddo
5932
5933       return
5934       end
5935 c----------------------------------------------------------------------------
5936       subroutine multibody(ecorr)
5937 C This subroutine calculates multi-body contributions to energy following
5938 C the idea of Skolnick et al. If side chains I and J make a contact and
5939 C at the same time side chains I+1 and J+1 make a contact, an extra
5940 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5941       implicit real*8 (a-h,o-z)
5942       include 'DIMENSIONS'
5943       include 'COMMON.IOUNITS'
5944       include 'COMMON.DERIV'
5945       include 'COMMON.INTERACT'
5946       include 'COMMON.CONTACTS'
5947       double precision gx(3),gx1(3)
5948       logical lprn
5949
5950 C Set lprn=.true. for debugging
5951       lprn=.false.
5952
5953       if (lprn) then
5954         write (iout,'(a)') 'Contact function values:'
5955         do i=nnt,nct-2
5956           write (iout,'(i2,20(1x,i2,f10.5))')
5957      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5958         enddo
5959       endif
5960       ecorr=0.0D0
5961       do i=nnt,nct
5962         do j=1,3
5963           gradcorr(j,i)=0.0D0
5964           gradxorr(j,i)=0.0D0
5965         enddo
5966       enddo
5967       do i=nnt,nct-2
5968
5969         DO ISHIFT = 3,4
5970
5971         i1=i+ishift
5972         num_conti=num_cont(i)
5973         num_conti1=num_cont(i1)
5974         do jj=1,num_conti
5975           j=jcont(jj,i)
5976           do kk=1,num_conti1
5977             j1=jcont(kk,i1)
5978             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5979 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5980 cd   &                   ' ishift=',ishift
5981 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5982 C The system gains extra energy.
5983               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5984             endif   ! j1==j+-ishift
5985           enddo     ! kk
5986         enddo       ! jj
5987
5988         ENDDO ! ISHIFT
5989
5990       enddo         ! i
5991       return
5992       end
5993 c------------------------------------------------------------------------------
5994       double precision function esccorr(i,j,k,l,jj,kk)
5995       implicit real*8 (a-h,o-z)
5996       include 'DIMENSIONS'
5997       include 'COMMON.IOUNITS'
5998       include 'COMMON.DERIV'
5999       include 'COMMON.INTERACT'
6000       include 'COMMON.CONTACTS'
6001       double precision gx(3),gx1(3)
6002       logical lprn
6003       lprn=.false.
6004       eij=facont(jj,i)
6005       ekl=facont(kk,k)
6006 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6007 C Calculate the multi-body contribution to energy.
6008 C Calculate multi-body contributions to the gradient.
6009 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6010 cd   & k,l,(gacont(m,kk,k),m=1,3)
6011       do m=1,3
6012         gx(m) =ekl*gacont(m,jj,i)
6013         gx1(m)=eij*gacont(m,kk,k)
6014         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6015         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6016         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6017         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6018       enddo
6019       do m=i,j-1
6020         do ll=1,3
6021           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6022         enddo
6023       enddo
6024       do m=k,l-1
6025         do ll=1,3
6026           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6027         enddo
6028       enddo
6029       esccorr=-eij*ekl
6030       return
6031       end
6032 c------------------------------------------------------------------------------
6033       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6034 C This subroutine calculates multi-body contributions to hydrogen-bonding
6035       implicit real*8 (a-h,o-z)
6036       include 'DIMENSIONS'
6037       include 'COMMON.IOUNITS'
6038 #ifdef MPI
6039       include "mpif.h"
6040       parameter (max_cont=maxconts)
6041       parameter (max_dim=26)
6042       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6043       double precision zapas(max_dim,maxconts,max_fg_procs),
6044      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6045       common /przechowalnia/ zapas
6046       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6047      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6048 #endif
6049       include 'COMMON.SETUP'
6050       include 'COMMON.FFIELD'
6051       include 'COMMON.DERIV'
6052       include 'COMMON.INTERACT'
6053       include 'COMMON.CONTACTS'
6054       include 'COMMON.CONTROL'
6055       include 'COMMON.LOCAL'
6056       double precision gx(3),gx1(3),time00
6057       logical lprn,ldone
6058
6059 C Set lprn=.true. for debugging
6060       lprn=.false.
6061 #ifdef MPI
6062       n_corr=0
6063       n_corr1=0
6064       if (nfgtasks.le.1) goto 30
6065       if (lprn) then
6066         write (iout,'(a)') 'Contact function values before RECEIVE:'
6067         do i=nnt,nct-2
6068           write (iout,'(2i3,50(1x,i2,f5.2))')
6069      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6070      &    j=1,num_cont_hb(i))
6071         enddo
6072       endif
6073       call flush(iout)
6074       do i=1,ntask_cont_from
6075         ncont_recv(i)=0
6076       enddo
6077       do i=1,ntask_cont_to
6078         ncont_sent(i)=0
6079       enddo
6080 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6081 c     & ntask_cont_to
6082 C Make the list of contacts to send to send to other procesors
6083 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6084 c      call flush(iout)
6085       do i=iturn3_start,iturn3_end
6086 c        write (iout,*) "make contact list turn3",i," num_cont",
6087 c     &    num_cont_hb(i)
6088         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6089       enddo
6090       do i=iturn4_start,iturn4_end
6091 c        write (iout,*) "make contact list turn4",i," num_cont",
6092 c     &   num_cont_hb(i)
6093         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6094       enddo
6095       do ii=1,nat_sent
6096         i=iat_sent(ii)
6097 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6098 c     &    num_cont_hb(i)
6099         do j=1,num_cont_hb(i)
6100         do k=1,4
6101           jjc=jcont_hb(j,i)
6102           iproc=iint_sent_local(k,jjc,ii)
6103 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6104           if (iproc.gt.0) then
6105             ncont_sent(iproc)=ncont_sent(iproc)+1
6106             nn=ncont_sent(iproc)
6107             zapas(1,nn,iproc)=i
6108             zapas(2,nn,iproc)=jjc
6109             zapas(3,nn,iproc)=facont_hb(j,i)
6110             zapas(4,nn,iproc)=ees0p(j,i)
6111             zapas(5,nn,iproc)=ees0m(j,i)
6112             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6113             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6114             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6115             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6116             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6117             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6118             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6119             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6120             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6121             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6122             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6123             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6124             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6125             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6126             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6127             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6128             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6129             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6130             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6131             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6132             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6133           endif
6134         enddo
6135         enddo
6136       enddo
6137       if (lprn) then
6138       write (iout,*)
6139      &  "Numbers of contacts to be sent to other processors",
6140      &  (ncont_sent(i),i=1,ntask_cont_to)
6141       write (iout,*) "Contacts sent"
6142       do ii=1,ntask_cont_to
6143         nn=ncont_sent(ii)
6144         iproc=itask_cont_to(ii)
6145         write (iout,*) nn," contacts to processor",iproc,
6146      &   " of CONT_TO_COMM group"
6147         do i=1,nn
6148           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6149         enddo
6150       enddo
6151       call flush(iout)
6152       endif
6153       CorrelType=477
6154       CorrelID=fg_rank+1
6155       CorrelType1=478
6156       CorrelID1=nfgtasks+fg_rank+1
6157       ireq=0
6158 C Receive the numbers of needed contacts from other processors
6159       do ii=1,ntask_cont_from
6160         iproc=itask_cont_from(ii)
6161         ireq=ireq+1
6162         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6163      &    FG_COMM,req(ireq),IERR)
6164       enddo
6165 c      write (iout,*) "IRECV ended"
6166 c      call flush(iout)
6167 C Send the number of contacts needed by other processors
6168       do ii=1,ntask_cont_to
6169         iproc=itask_cont_to(ii)
6170         ireq=ireq+1
6171         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6172      &    FG_COMM,req(ireq),IERR)
6173       enddo
6174 c      write (iout,*) "ISEND ended"
6175 c      write (iout,*) "number of requests (nn)",ireq
6176       call flush(iout)
6177       if (ireq.gt.0)
6178      &  call MPI_Waitall(ireq,req,status_array,ierr)
6179 c      write (iout,*)
6180 c     &  "Numbers of contacts to be received from other processors",
6181 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6182 c      call flush(iout)
6183 C Receive contacts
6184       ireq=0
6185       do ii=1,ntask_cont_from
6186         iproc=itask_cont_from(ii)
6187         nn=ncont_recv(ii)
6188 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6189 c     &   " of CONT_TO_COMM group"
6190         call flush(iout)
6191         if (nn.gt.0) then
6192           ireq=ireq+1
6193           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6194      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6195 c          write (iout,*) "ireq,req",ireq,req(ireq)
6196         endif
6197       enddo
6198 C Send the contacts to processors that need them
6199       do ii=1,ntask_cont_to
6200         iproc=itask_cont_to(ii)
6201         nn=ncont_sent(ii)
6202 c        write (iout,*) nn," contacts to processor",iproc,
6203 c     &   " of CONT_TO_COMM group"
6204         if (nn.gt.0) then
6205           ireq=ireq+1
6206           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6207      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6208 c          write (iout,*) "ireq,req",ireq,req(ireq)
6209 c          do i=1,nn
6210 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6211 c          enddo
6212         endif
6213       enddo
6214 c      write (iout,*) "number of requests (contacts)",ireq
6215 c      write (iout,*) "req",(req(i),i=1,4)
6216 c      call flush(iout)
6217       if (ireq.gt.0)
6218      & call MPI_Waitall(ireq,req,status_array,ierr)
6219       do iii=1,ntask_cont_from
6220         iproc=itask_cont_from(iii)
6221         nn=ncont_recv(iii)
6222         if (lprn) then
6223         write (iout,*) "Received",nn," contacts from processor",iproc,
6224      &   " of CONT_FROM_COMM group"
6225         call flush(iout)
6226         do i=1,nn
6227           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6228         enddo
6229         call flush(iout)
6230         endif
6231         do i=1,nn
6232           ii=zapas_recv(1,i,iii)
6233 c Flag the received contacts to prevent double-counting
6234           jj=-zapas_recv(2,i,iii)
6235 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6236 c          call flush(iout)
6237           nnn=num_cont_hb(ii)+1
6238           num_cont_hb(ii)=nnn
6239           jcont_hb(nnn,ii)=jj
6240           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6241           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6242           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6243           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6244           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6245           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6246           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6247           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6248           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6249           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6250           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6251           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6252           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6253           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6254           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6255           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6256           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6257           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6258           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6259           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6260           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6261           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6262           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6263           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6264         enddo
6265       enddo
6266       call flush(iout)
6267       if (lprn) then
6268         write (iout,'(a)') 'Contact function values after receive:'
6269         do i=nnt,nct-2
6270           write (iout,'(2i3,50(1x,i3,f5.2))')
6271      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6272      &    j=1,num_cont_hb(i))
6273         enddo
6274         call flush(iout)
6275       endif
6276    30 continue
6277 #endif
6278       if (lprn) then
6279         write (iout,'(a)') 'Contact function values:'
6280         do i=nnt,nct-2
6281           write (iout,'(2i3,50(1x,i3,f5.2))')
6282      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6283      &    j=1,num_cont_hb(i))
6284         enddo
6285       endif
6286       ecorr=0.0D0
6287 C Remove the loop below after debugging !!!
6288       do i=nnt,nct
6289         do j=1,3
6290           gradcorr(j,i)=0.0D0
6291           gradxorr(j,i)=0.0D0
6292         enddo
6293       enddo
6294 C Calculate the local-electrostatic correlation terms
6295       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6296         i1=i+1
6297         num_conti=num_cont_hb(i)
6298         num_conti1=num_cont_hb(i+1)
6299         do jj=1,num_conti
6300           j=jcont_hb(jj,i)
6301           jp=iabs(j)
6302           do kk=1,num_conti1
6303             j1=jcont_hb(kk,i1)
6304             jp1=iabs(j1)
6305 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6306 c     &         ' jj=',jj,' kk=',kk
6307             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6308      &          .or. j.lt.0 .and. j1.gt.0) .and.
6309      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6310 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6311 C The system gains extra energy.
6312               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6313               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6314      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6315               n_corr=n_corr+1
6316             else if (j1.eq.j) then
6317 C Contacts I-J and I-(J+1) occur simultaneously.
6318 C The system loses extra energy.
6319 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6320             endif
6321           enddo ! kk
6322           do kk=1,num_conti
6323             j1=jcont_hb(kk,i)
6324 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6325 c    &         ' jj=',jj,' kk=',kk
6326             if (j1.eq.j+1) then
6327 C Contacts I-J and (I+1)-J occur simultaneously.
6328 C The system loses extra energy.
6329 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6330             endif ! j1==j+1
6331           enddo ! kk
6332         enddo ! jj
6333       enddo ! i
6334       return
6335       end
6336 c------------------------------------------------------------------------------
6337       subroutine add_hb_contact(ii,jj,itask)
6338       implicit real*8 (a-h,o-z)
6339       include "DIMENSIONS"
6340       include "COMMON.IOUNITS"
6341       integer max_cont
6342       integer max_dim
6343       parameter (max_cont=maxconts)
6344       parameter (max_dim=26)
6345       include "COMMON.CONTACTS"
6346       double precision zapas(max_dim,maxconts,max_fg_procs),
6347      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6348       common /przechowalnia/ zapas
6349       integer i,j,ii,jj,iproc,itask(4),nn
6350 c      write (iout,*) "itask",itask
6351       do i=1,2
6352         iproc=itask(i)
6353         if (iproc.gt.0) then
6354           do j=1,num_cont_hb(ii)
6355             jjc=jcont_hb(j,ii)
6356 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6357             if (jjc.eq.jj) then
6358               ncont_sent(iproc)=ncont_sent(iproc)+1
6359               nn=ncont_sent(iproc)
6360               zapas(1,nn,iproc)=ii
6361               zapas(2,nn,iproc)=jjc
6362               zapas(3,nn,iproc)=facont_hb(j,ii)
6363               zapas(4,nn,iproc)=ees0p(j,ii)
6364               zapas(5,nn,iproc)=ees0m(j,ii)
6365               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6366               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6367               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6368               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6369               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6370               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6371               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6372               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6373               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6374               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6375               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6376               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6377               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6378               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6379               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6380               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6381               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6382               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6383               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6384               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6385               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6386               exit
6387             endif
6388           enddo
6389         endif
6390       enddo
6391       return
6392       end
6393 c------------------------------------------------------------------------------
6394       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6395      &  n_corr1)
6396 C This subroutine calculates multi-body contributions to hydrogen-bonding
6397       implicit real*8 (a-h,o-z)
6398       include 'DIMENSIONS'
6399       include 'COMMON.IOUNITS'
6400 #ifdef MPI
6401       include "mpif.h"
6402       parameter (max_cont=maxconts)
6403       parameter (max_dim=70)
6404       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6405       double precision zapas(max_dim,maxconts,max_fg_procs),
6406      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6407       common /przechowalnia/ zapas
6408       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6409      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6410 #endif
6411       include 'COMMON.SETUP'
6412       include 'COMMON.FFIELD'
6413       include 'COMMON.DERIV'
6414       include 'COMMON.LOCAL'
6415       include 'COMMON.INTERACT'
6416       include 'COMMON.CONTACTS'
6417       include 'COMMON.CHAIN'
6418       include 'COMMON.CONTROL'
6419       double precision gx(3),gx1(3)
6420       integer num_cont_hb_old(maxres)
6421       logical lprn,ldone
6422       double precision eello4,eello5,eelo6,eello_turn6
6423       external eello4,eello5,eello6,eello_turn6
6424 C Set lprn=.true. for debugging
6425       lprn=.false.
6426       eturn6=0.0d0
6427 #ifdef MPI
6428       do i=1,nres
6429         num_cont_hb_old(i)=num_cont_hb(i)
6430       enddo
6431       n_corr=0
6432       n_corr1=0
6433       if (nfgtasks.le.1) goto 30
6434       if (lprn) then
6435         write (iout,'(a)') 'Contact function values before RECEIVE:'
6436         do i=nnt,nct-2
6437           write (iout,'(2i3,50(1x,i2,f5.2))')
6438      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6439      &    j=1,num_cont_hb(i))
6440         enddo
6441       endif
6442       call flush(iout)
6443       do i=1,ntask_cont_from
6444         ncont_recv(i)=0
6445       enddo
6446       do i=1,ntask_cont_to
6447         ncont_sent(i)=0
6448       enddo
6449 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6450 c     & ntask_cont_to
6451 C Make the list of contacts to send to send to other procesors
6452       do i=iturn3_start,iturn3_end
6453 c        write (iout,*) "make contact list turn3",i," num_cont",
6454 c     &    num_cont_hb(i)
6455         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6456       enddo
6457       do i=iturn4_start,iturn4_end
6458 c        write (iout,*) "make contact list turn4",i," num_cont",
6459 c     &   num_cont_hb(i)
6460         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6461       enddo
6462       do ii=1,nat_sent
6463         i=iat_sent(ii)
6464 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6465 c     &    num_cont_hb(i)
6466         do j=1,num_cont_hb(i)
6467         do k=1,4
6468           jjc=jcont_hb(j,i)
6469           iproc=iint_sent_local(k,jjc,ii)
6470 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6471           if (iproc.ne.0) then
6472             ncont_sent(iproc)=ncont_sent(iproc)+1
6473             nn=ncont_sent(iproc)
6474             zapas(1,nn,iproc)=i
6475             zapas(2,nn,iproc)=jjc
6476             zapas(3,nn,iproc)=d_cont(j,i)
6477             ind=3
6478             do kk=1,3
6479               ind=ind+1
6480               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6481             enddo
6482             do kk=1,2
6483               do ll=1,2
6484                 ind=ind+1
6485                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6486               enddo
6487             enddo
6488             do jj=1,5
6489               do kk=1,3
6490                 do ll=1,2
6491                   do mm=1,2
6492                     ind=ind+1
6493                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6494                   enddo
6495                 enddo
6496               enddo
6497             enddo
6498           endif
6499         enddo
6500         enddo
6501       enddo
6502       if (lprn) then
6503       write (iout,*)
6504      &  "Numbers of contacts to be sent to other processors",
6505      &  (ncont_sent(i),i=1,ntask_cont_to)
6506       write (iout,*) "Contacts sent"
6507       do ii=1,ntask_cont_to
6508         nn=ncont_sent(ii)
6509         iproc=itask_cont_to(ii)
6510         write (iout,*) nn," contacts to processor",iproc,
6511      &   " of CONT_TO_COMM group"
6512         do i=1,nn
6513           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6514         enddo
6515       enddo
6516       call flush(iout)
6517       endif
6518       CorrelType=477
6519       CorrelID=fg_rank+1
6520       CorrelType1=478
6521       CorrelID1=nfgtasks+fg_rank+1
6522       ireq=0
6523 C Receive the numbers of needed contacts from other processors
6524       do ii=1,ntask_cont_from
6525         iproc=itask_cont_from(ii)
6526         ireq=ireq+1
6527         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6528      &    FG_COMM,req(ireq),IERR)
6529       enddo
6530 c      write (iout,*) "IRECV ended"
6531 c      call flush(iout)
6532 C Send the number of contacts needed by other processors
6533       do ii=1,ntask_cont_to
6534         iproc=itask_cont_to(ii)
6535         ireq=ireq+1
6536         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6537      &    FG_COMM,req(ireq),IERR)
6538       enddo
6539 c      write (iout,*) "ISEND ended"
6540 c      write (iout,*) "number of requests (nn)",ireq
6541       call flush(iout)
6542       if (ireq.gt.0)
6543      &  call MPI_Waitall(ireq,req,status_array,ierr)
6544 c      write (iout,*)
6545 c     &  "Numbers of contacts to be received from other processors",
6546 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6547 c      call flush(iout)
6548 C Receive contacts
6549       ireq=0
6550       do ii=1,ntask_cont_from
6551         iproc=itask_cont_from(ii)
6552         nn=ncont_recv(ii)
6553 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6554 c     &   " of CONT_TO_COMM group"
6555         call flush(iout)
6556         if (nn.gt.0) then
6557           ireq=ireq+1
6558           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6559      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6560 c          write (iout,*) "ireq,req",ireq,req(ireq)
6561         endif
6562       enddo
6563 C Send the contacts to processors that need them
6564       do ii=1,ntask_cont_to
6565         iproc=itask_cont_to(ii)
6566         nn=ncont_sent(ii)
6567 c        write (iout,*) nn," contacts to processor",iproc,
6568 c     &   " of CONT_TO_COMM group"
6569         if (nn.gt.0) then
6570           ireq=ireq+1
6571           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6572      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6573 c          write (iout,*) "ireq,req",ireq,req(ireq)
6574 c          do i=1,nn
6575 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6576 c          enddo
6577         endif
6578       enddo
6579 c      write (iout,*) "number of requests (contacts)",ireq
6580 c      write (iout,*) "req",(req(i),i=1,4)
6581 c      call flush(iout)
6582       if (ireq.gt.0)
6583      & call MPI_Waitall(ireq,req,status_array,ierr)
6584       do iii=1,ntask_cont_from
6585         iproc=itask_cont_from(iii)
6586         nn=ncont_recv(iii)
6587         if (lprn) then
6588         write (iout,*) "Received",nn," contacts from processor",iproc,
6589      &   " of CONT_FROM_COMM group"
6590         call flush(iout)
6591         do i=1,nn
6592           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6593         enddo
6594         call flush(iout)
6595         endif
6596         do i=1,nn
6597           ii=zapas_recv(1,i,iii)
6598 c Flag the received contacts to prevent double-counting
6599           jj=-zapas_recv(2,i,iii)
6600 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6601 c          call flush(iout)
6602           nnn=num_cont_hb(ii)+1
6603           num_cont_hb(ii)=nnn
6604           jcont_hb(nnn,ii)=jj
6605           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6606           ind=3
6607           do kk=1,3
6608             ind=ind+1
6609             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6610           enddo
6611           do kk=1,2
6612             do ll=1,2
6613               ind=ind+1
6614               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6615             enddo
6616           enddo
6617           do jj=1,5
6618             do kk=1,3
6619               do ll=1,2
6620                 do mm=1,2
6621                   ind=ind+1
6622                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6623                 enddo
6624               enddo
6625             enddo
6626           enddo
6627         enddo
6628       enddo
6629       call flush(iout)
6630       if (lprn) then
6631         write (iout,'(a)') 'Contact function values after receive:'
6632         do i=nnt,nct-2
6633           write (iout,'(2i3,50(1x,i3,5f6.3))')
6634      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6635      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6636         enddo
6637         call flush(iout)
6638       endif
6639    30 continue
6640 #endif
6641       if (lprn) then
6642         write (iout,'(a)') 'Contact function values:'
6643         do i=nnt,nct-2
6644           write (iout,'(2i3,50(1x,i2,5f6.3))')
6645      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6646      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6647         enddo
6648       endif
6649       ecorr=0.0D0
6650       ecorr5=0.0d0
6651       ecorr6=0.0d0
6652 C Remove the loop below after debugging !!!
6653       do i=nnt,nct
6654         do j=1,3
6655           gradcorr(j,i)=0.0D0
6656           gradxorr(j,i)=0.0D0
6657         enddo
6658       enddo
6659 C Calculate the dipole-dipole interaction energies
6660       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6661       do i=iatel_s,iatel_e+1
6662         num_conti=num_cont_hb(i)
6663         do jj=1,num_conti
6664           j=jcont_hb(jj,i)
6665 #ifdef MOMENT
6666           call dipole(i,j,jj)
6667 #endif
6668         enddo
6669       enddo
6670       endif
6671 C Calculate the local-electrostatic correlation terms
6672 c                write (iout,*) "gradcorr5 in eello5 before loop"
6673 c                do iii=1,nres
6674 c                  write (iout,'(i5,3f10.5)')
6675 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6676 c                enddo
6677       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6678 c        write (iout,*) "corr loop i",i
6679         i1=i+1
6680         num_conti=num_cont_hb(i)
6681         num_conti1=num_cont_hb(i+1)
6682         do jj=1,num_conti
6683           j=jcont_hb(jj,i)
6684           jp=iabs(j)
6685           do kk=1,num_conti1
6686             j1=jcont_hb(kk,i1)
6687             jp1=iabs(j1)
6688 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6689 c     &         ' jj=',jj,' kk=',kk
6690 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6691             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6692      &          .or. j.lt.0 .and. j1.gt.0) .and.
6693      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6694 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6695 C The system gains extra energy.
6696               n_corr=n_corr+1
6697               sqd1=dsqrt(d_cont(jj,i))
6698               sqd2=dsqrt(d_cont(kk,i1))
6699               sred_geom = sqd1*sqd2
6700               IF (sred_geom.lt.cutoff_corr) THEN
6701                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6702      &            ekont,fprimcont)
6703 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6704 cd     &         ' jj=',jj,' kk=',kk
6705                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6706                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6707                 do l=1,3
6708                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6709                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6710                 enddo
6711                 n_corr1=n_corr1+1
6712 cd               write (iout,*) 'sred_geom=',sred_geom,
6713 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6714 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6715 cd               write (iout,*) "g_contij",g_contij
6716 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6717 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6718                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6719                 if (wcorr4.gt.0.0d0)
6720      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6721                   if (energy_dec.and.wcorr4.gt.0.0d0)
6722      1                 write (iout,'(a6,4i5,0pf7.3)')
6723      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6724 c                write (iout,*) "gradcorr5 before eello5"
6725 c                do iii=1,nres
6726 c                  write (iout,'(i5,3f10.5)')
6727 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6728 c                enddo
6729                 if (wcorr5.gt.0.0d0)
6730      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6731 c                write (iout,*) "gradcorr5 after eello5"
6732 c                do iii=1,nres
6733 c                  write (iout,'(i5,3f10.5)')
6734 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6735 c                enddo
6736                   if (energy_dec.and.wcorr5.gt.0.0d0)
6737      1                 write (iout,'(a6,4i5,0pf7.3)')
6738      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6739 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6740 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6741                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6742      &               .or. wturn6.eq.0.0d0))then
6743 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6744                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6745                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6746      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6747 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6748 cd     &            'ecorr6=',ecorr6
6749 cd                write (iout,'(4e15.5)') sred_geom,
6750 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6751 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6752 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6753                 else if (wturn6.gt.0.0d0
6754      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6755 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6756                   eturn6=eturn6+eello_turn6(i,jj,kk)
6757                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6758      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6759 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6760                 endif
6761               ENDIF
6762 1111          continue
6763             endif
6764           enddo ! kk
6765         enddo ! jj
6766       enddo ! i
6767       do i=1,nres
6768         num_cont_hb(i)=num_cont_hb_old(i)
6769       enddo
6770 c                write (iout,*) "gradcorr5 in eello5"
6771 c                do iii=1,nres
6772 c                  write (iout,'(i5,3f10.5)')
6773 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6774 c                enddo
6775       return
6776       end
6777 c------------------------------------------------------------------------------
6778       subroutine add_hb_contact_eello(ii,jj,itask)
6779       implicit real*8 (a-h,o-z)
6780       include "DIMENSIONS"
6781       include "COMMON.IOUNITS"
6782       integer max_cont
6783       integer max_dim
6784       parameter (max_cont=maxconts)
6785       parameter (max_dim=70)
6786       include "COMMON.CONTACTS"
6787       double precision zapas(max_dim,maxconts,max_fg_procs),
6788      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6789       common /przechowalnia/ zapas
6790       integer i,j,ii,jj,iproc,itask(4),nn
6791 c      write (iout,*) "itask",itask
6792       do i=1,2
6793         iproc=itask(i)
6794         if (iproc.gt.0) then
6795           do j=1,num_cont_hb(ii)
6796             jjc=jcont_hb(j,ii)
6797 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6798             if (jjc.eq.jj) then
6799               ncont_sent(iproc)=ncont_sent(iproc)+1
6800               nn=ncont_sent(iproc)
6801               zapas(1,nn,iproc)=ii
6802               zapas(2,nn,iproc)=jjc
6803               zapas(3,nn,iproc)=d_cont(j,ii)
6804               ind=3
6805               do kk=1,3
6806                 ind=ind+1
6807                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6808               enddo
6809               do kk=1,2
6810                 do ll=1,2
6811                   ind=ind+1
6812                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6813                 enddo
6814               enddo
6815               do jj=1,5
6816                 do kk=1,3
6817                   do ll=1,2
6818                     do mm=1,2
6819                       ind=ind+1
6820                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6821                     enddo
6822                   enddo
6823                 enddo
6824               enddo
6825               exit
6826             endif
6827           enddo
6828         endif
6829       enddo
6830       return
6831       end
6832 c------------------------------------------------------------------------------
6833       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6834       implicit real*8 (a-h,o-z)
6835       include 'DIMENSIONS'
6836       include 'COMMON.IOUNITS'
6837       include 'COMMON.DERIV'
6838       include 'COMMON.INTERACT'
6839       include 'COMMON.CONTACTS'
6840       double precision gx(3),gx1(3)
6841       logical lprn
6842       lprn=.false.
6843       eij=facont_hb(jj,i)
6844       ekl=facont_hb(kk,k)
6845       ees0pij=ees0p(jj,i)
6846       ees0pkl=ees0p(kk,k)
6847       ees0mij=ees0m(jj,i)
6848       ees0mkl=ees0m(kk,k)
6849       ekont=eij*ekl
6850       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6851 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6852 C Following 4 lines for diagnostics.
6853 cd    ees0pkl=0.0D0
6854 cd    ees0pij=1.0D0
6855 cd    ees0mkl=0.0D0
6856 cd    ees0mij=1.0D0
6857 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6858 c     & 'Contacts ',i,j,
6859 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6860 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6861 c     & 'gradcorr_long'
6862 C Calculate the multi-body contribution to energy.
6863 c      ecorr=ecorr+ekont*ees
6864 C Calculate multi-body contributions to the gradient.
6865       coeffpees0pij=coeffp*ees0pij
6866       coeffmees0mij=coeffm*ees0mij
6867       coeffpees0pkl=coeffp*ees0pkl
6868       coeffmees0mkl=coeffm*ees0mkl
6869       do ll=1,3
6870 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6871         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6872      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6873      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6874         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6875      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6876      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6877 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6878         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6879      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6880      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6881         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6882      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6883      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6884         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6885      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6886      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6887         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6888         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6889         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6890      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6891      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6892         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6893         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6894 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6895       enddo
6896 c      write (iout,*)
6897 cgrad      do m=i+1,j-1
6898 cgrad        do ll=1,3
6899 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6900 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6901 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6902 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6903 cgrad        enddo
6904 cgrad      enddo
6905 cgrad      do m=k+1,l-1
6906 cgrad        do ll=1,3
6907 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6908 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6909 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6910 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6911 cgrad        enddo
6912 cgrad      enddo
6913 c      write (iout,*) "ehbcorr",ekont*ees
6914       ehbcorr=ekont*ees
6915       return
6916       end
6917 #ifdef MOMENT
6918 C---------------------------------------------------------------------------
6919       subroutine dipole(i,j,jj)
6920       implicit real*8 (a-h,o-z)
6921       include 'DIMENSIONS'
6922       include 'COMMON.IOUNITS'
6923       include 'COMMON.CHAIN'
6924       include 'COMMON.FFIELD'
6925       include 'COMMON.DERIV'
6926       include 'COMMON.INTERACT'
6927       include 'COMMON.CONTACTS'
6928       include 'COMMON.TORSION'
6929       include 'COMMON.VAR'
6930       include 'COMMON.GEO'
6931       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6932      &  auxmat(2,2)
6933       iti1 = itortyp(itype(i+1))
6934       if (j.lt.nres-1) then
6935         itj1 = itortyp(itype(j+1))
6936       else
6937         itj1=ntortyp+1
6938       endif
6939       do iii=1,2
6940         dipi(iii,1)=Ub2(iii,i)
6941         dipderi(iii)=Ub2der(iii,i)
6942         dipi(iii,2)=b1(iii,iti1)
6943         dipj(iii,1)=Ub2(iii,j)
6944         dipderj(iii)=Ub2der(iii,j)
6945         dipj(iii,2)=b1(iii,itj1)
6946       enddo
6947       kkk=0
6948       do iii=1,2
6949         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6950         do jjj=1,2
6951           kkk=kkk+1
6952           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6953         enddo
6954       enddo
6955       do kkk=1,5
6956         do lll=1,3
6957           mmm=0
6958           do iii=1,2
6959             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6960      &        auxvec(1))
6961             do jjj=1,2
6962               mmm=mmm+1
6963               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6964             enddo
6965           enddo
6966         enddo
6967       enddo
6968       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6969       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6970       do iii=1,2
6971         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6972       enddo
6973       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6974       do iii=1,2
6975         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6976       enddo
6977       return
6978       end
6979 #endif
6980 C---------------------------------------------------------------------------
6981       subroutine calc_eello(i,j,k,l,jj,kk)
6982 C
6983 C This subroutine computes matrices and vectors needed to calculate
6984 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6985 C
6986       implicit real*8 (a-h,o-z)
6987       include 'DIMENSIONS'
6988       include 'COMMON.IOUNITS'
6989       include 'COMMON.CHAIN'
6990       include 'COMMON.DERIV'
6991       include 'COMMON.INTERACT'
6992       include 'COMMON.CONTACTS'
6993       include 'COMMON.TORSION'
6994       include 'COMMON.VAR'
6995       include 'COMMON.GEO'
6996       include 'COMMON.FFIELD'
6997       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6998      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6999       logical lprn
7000       common /kutas/ lprn
7001 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7002 cd     & ' jj=',jj,' kk=',kk
7003 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7004 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7005 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7006       do iii=1,2
7007         do jjj=1,2
7008           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7009           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7010         enddo
7011       enddo
7012       call transpose2(aa1(1,1),aa1t(1,1))
7013       call transpose2(aa2(1,1),aa2t(1,1))
7014       do kkk=1,5
7015         do lll=1,3
7016           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7017      &      aa1tder(1,1,lll,kkk))
7018           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7019      &      aa2tder(1,1,lll,kkk))
7020         enddo
7021       enddo
7022       if (l.eq.j+1) then
7023 C parallel orientation of the two CA-CA-CA frames.
7024         if (i.gt.1) then
7025           iti=itortyp(itype(i))
7026         else
7027           iti=ntortyp+1
7028         endif
7029         itk1=itortyp(itype(k+1))
7030         itj=itortyp(itype(j))
7031         if (l.lt.nres-1) then
7032           itl1=itortyp(itype(l+1))
7033         else
7034           itl1=ntortyp+1
7035         endif
7036 C A1 kernel(j+1) A2T
7037 cd        do iii=1,2
7038 cd          write (iout,'(3f10.5,5x,3f10.5)')
7039 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7040 cd        enddo
7041         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7042      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7043      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7044 C Following matrices are needed only for 6-th order cumulants
7045         IF (wcorr6.gt.0.0d0) THEN
7046         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7047      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7048      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7050      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7051      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7052      &   ADtEAderx(1,1,1,1,1,1))
7053         lprn=.false.
7054         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7055      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7056      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7057      &   ADtEA1derx(1,1,1,1,1,1))
7058         ENDIF
7059 C End 6-th order cumulants
7060 cd        lprn=.false.
7061 cd        if (lprn) then
7062 cd        write (2,*) 'In calc_eello6'
7063 cd        do iii=1,2
7064 cd          write (2,*) 'iii=',iii
7065 cd          do kkk=1,5
7066 cd            write (2,*) 'kkk=',kkk
7067 cd            do jjj=1,2
7068 cd              write (2,'(3(2f10.5),5x)')
7069 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7070 cd            enddo
7071 cd          enddo
7072 cd        enddo
7073 cd        endif
7074         call transpose2(EUgder(1,1,k),auxmat(1,1))
7075         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7076         call transpose2(EUg(1,1,k),auxmat(1,1))
7077         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7078         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7079         do iii=1,2
7080           do kkk=1,5
7081             do lll=1,3
7082               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7083      &          EAEAderx(1,1,lll,kkk,iii,1))
7084             enddo
7085           enddo
7086         enddo
7087 C A1T kernel(i+1) A2
7088         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7089      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7090      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7091 C Following matrices are needed only for 6-th order cumulants
7092         IF (wcorr6.gt.0.0d0) THEN
7093         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7094      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7095      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7096         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7097      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7098      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7099      &   ADtEAderx(1,1,1,1,1,2))
7100         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7101      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7102      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7103      &   ADtEA1derx(1,1,1,1,1,2))
7104         ENDIF
7105 C End 6-th order cumulants
7106         call transpose2(EUgder(1,1,l),auxmat(1,1))
7107         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7108         call transpose2(EUg(1,1,l),auxmat(1,1))
7109         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7110         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7111         do iii=1,2
7112           do kkk=1,5
7113             do lll=1,3
7114               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7115      &          EAEAderx(1,1,lll,kkk,iii,2))
7116             enddo
7117           enddo
7118         enddo
7119 C AEAb1 and AEAb2
7120 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7121 C They are needed only when the fifth- or the sixth-order cumulants are
7122 C indluded.
7123         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7124         call transpose2(AEA(1,1,1),auxmat(1,1))
7125         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7126         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7127         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7128         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7129         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7130         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7131         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7132         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7133         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7134         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7135         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7136         call transpose2(AEA(1,1,2),auxmat(1,1))
7137         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7138         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7139         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7140         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7141         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7142         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7143         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7144         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7145         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7146         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7147         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7148 C Calculate the Cartesian derivatives of the vectors.
7149         do iii=1,2
7150           do kkk=1,5
7151             do lll=1,3
7152               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7153               call matvec2(auxmat(1,1),b1(1,iti),
7154      &          AEAb1derx(1,lll,kkk,iii,1,1))
7155               call matvec2(auxmat(1,1),Ub2(1,i),
7156      &          AEAb2derx(1,lll,kkk,iii,1,1))
7157               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7158      &          AEAb1derx(1,lll,kkk,iii,2,1))
7159               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7160      &          AEAb2derx(1,lll,kkk,iii,2,1))
7161               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7162               call matvec2(auxmat(1,1),b1(1,itj),
7163      &          AEAb1derx(1,lll,kkk,iii,1,2))
7164               call matvec2(auxmat(1,1),Ub2(1,j),
7165      &          AEAb2derx(1,lll,kkk,iii,1,2))
7166               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7167      &          AEAb1derx(1,lll,kkk,iii,2,2))
7168               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7169      &          AEAb2derx(1,lll,kkk,iii,2,2))
7170             enddo
7171           enddo
7172         enddo
7173         ENDIF
7174 C End vectors
7175       else
7176 C Antiparallel orientation of the two CA-CA-CA frames.
7177         if (i.gt.1) then
7178           iti=itortyp(itype(i))
7179         else
7180           iti=ntortyp+1
7181         endif
7182         itk1=itortyp(itype(k+1))
7183         itl=itortyp(itype(l))
7184         itj=itortyp(itype(j))
7185         if (j.lt.nres-1) then
7186           itj1=itortyp(itype(j+1))
7187         else
7188           itj1=ntortyp+1
7189         endif
7190 C A2 kernel(j-1)T A1T
7191         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7192      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7193      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7194 C Following matrices are needed only for 6-th order cumulants
7195         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7196      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7197         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7198      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7199      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7200         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7201      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7202      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7203      &   ADtEAderx(1,1,1,1,1,1))
7204         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7205      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7206      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7207      &   ADtEA1derx(1,1,1,1,1,1))
7208         ENDIF
7209 C End 6-th order cumulants
7210         call transpose2(EUgder(1,1,k),auxmat(1,1))
7211         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7212         call transpose2(EUg(1,1,k),auxmat(1,1))
7213         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7214         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7215         do iii=1,2
7216           do kkk=1,5
7217             do lll=1,3
7218               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7219      &          EAEAderx(1,1,lll,kkk,iii,1))
7220             enddo
7221           enddo
7222         enddo
7223 C A2T kernel(i+1)T A1
7224         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7225      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7226      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7227 C Following matrices are needed only for 6-th order cumulants
7228         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7229      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7230         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7231      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7232      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7233         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7234      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7235      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7236      &   ADtEAderx(1,1,1,1,1,2))
7237         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7238      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7239      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7240      &   ADtEA1derx(1,1,1,1,1,2))
7241         ENDIF
7242 C End 6-th order cumulants
7243         call transpose2(EUgder(1,1,j),auxmat(1,1))
7244         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7245         call transpose2(EUg(1,1,j),auxmat(1,1))
7246         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7247         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7248         do iii=1,2
7249           do kkk=1,5
7250             do lll=1,3
7251               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7252      &          EAEAderx(1,1,lll,kkk,iii,2))
7253             enddo
7254           enddo
7255         enddo
7256 C AEAb1 and AEAb2
7257 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7258 C They are needed only when the fifth- or the sixth-order cumulants are
7259 C indluded.
7260         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7261      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7262         call transpose2(AEA(1,1,1),auxmat(1,1))
7263         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7264         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7265         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7266         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7267         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7268         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7269         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7270         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7271         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7272         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7273         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7274         call transpose2(AEA(1,1,2),auxmat(1,1))
7275         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7276         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7277         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7278         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7279         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7280         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7281         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7282         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7283         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7284         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7285         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7286 C Calculate the Cartesian derivatives of the vectors.
7287         do iii=1,2
7288           do kkk=1,5
7289             do lll=1,3
7290               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7291               call matvec2(auxmat(1,1),b1(1,iti),
7292      &          AEAb1derx(1,lll,kkk,iii,1,1))
7293               call matvec2(auxmat(1,1),Ub2(1,i),
7294      &          AEAb2derx(1,lll,kkk,iii,1,1))
7295               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7296      &          AEAb1derx(1,lll,kkk,iii,2,1))
7297               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7298      &          AEAb2derx(1,lll,kkk,iii,2,1))
7299               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7300               call matvec2(auxmat(1,1),b1(1,itl),
7301      &          AEAb1derx(1,lll,kkk,iii,1,2))
7302               call matvec2(auxmat(1,1),Ub2(1,l),
7303      &          AEAb2derx(1,lll,kkk,iii,1,2))
7304               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7305      &          AEAb1derx(1,lll,kkk,iii,2,2))
7306               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7307      &          AEAb2derx(1,lll,kkk,iii,2,2))
7308             enddo
7309           enddo
7310         enddo
7311         ENDIF
7312 C End vectors
7313       endif
7314       return
7315       end
7316 C---------------------------------------------------------------------------
7317       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7318      &  KK,KKderg,AKA,AKAderg,AKAderx)
7319       implicit none
7320       integer nderg
7321       logical transp
7322       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7323      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7324      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7325       integer iii,kkk,lll
7326       integer jjj,mmm
7327       logical lprn
7328       common /kutas/ lprn
7329       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7330       do iii=1,nderg
7331         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7332      &    AKAderg(1,1,iii))
7333       enddo
7334 cd      if (lprn) write (2,*) 'In kernel'
7335       do kkk=1,5
7336 cd        if (lprn) write (2,*) 'kkk=',kkk
7337         do lll=1,3
7338           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7339      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7340 cd          if (lprn) then
7341 cd            write (2,*) 'lll=',lll
7342 cd            write (2,*) 'iii=1'
7343 cd            do jjj=1,2
7344 cd              write (2,'(3(2f10.5),5x)')
7345 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7346 cd            enddo
7347 cd          endif
7348           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7349      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7350 cd          if (lprn) then
7351 cd            write (2,*) 'lll=',lll
7352 cd            write (2,*) 'iii=2'
7353 cd            do jjj=1,2
7354 cd              write (2,'(3(2f10.5),5x)')
7355 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7356 cd            enddo
7357 cd          endif
7358         enddo
7359       enddo
7360       return
7361       end
7362 C---------------------------------------------------------------------------
7363       double precision function eello4(i,j,k,l,jj,kk)
7364       implicit real*8 (a-h,o-z)
7365       include 'DIMENSIONS'
7366       include 'COMMON.IOUNITS'
7367       include 'COMMON.CHAIN'
7368       include 'COMMON.DERIV'
7369       include 'COMMON.INTERACT'
7370       include 'COMMON.CONTACTS'
7371       include 'COMMON.TORSION'
7372       include 'COMMON.VAR'
7373       include 'COMMON.GEO'
7374       double precision pizda(2,2),ggg1(3),ggg2(3)
7375 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7376 cd        eello4=0.0d0
7377 cd        return
7378 cd      endif
7379 cd      print *,'eello4:',i,j,k,l,jj,kk
7380 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7381 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7382 cold      eij=facont_hb(jj,i)
7383 cold      ekl=facont_hb(kk,k)
7384 cold      ekont=eij*ekl
7385       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7386 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7387       gcorr_loc(k-1)=gcorr_loc(k-1)
7388      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7389       if (l.eq.j+1) then
7390         gcorr_loc(l-1)=gcorr_loc(l-1)
7391      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7392       else
7393         gcorr_loc(j-1)=gcorr_loc(j-1)
7394      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7395       endif
7396       do iii=1,2
7397         do kkk=1,5
7398           do lll=1,3
7399             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7400      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7401 cd            derx(lll,kkk,iii)=0.0d0
7402           enddo
7403         enddo
7404       enddo
7405 cd      gcorr_loc(l-1)=0.0d0
7406 cd      gcorr_loc(j-1)=0.0d0
7407 cd      gcorr_loc(k-1)=0.0d0
7408 cd      eel4=1.0d0
7409 cd      write (iout,*)'Contacts have occurred for peptide groups',
7410 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7411 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7412       if (j.lt.nres-1) then
7413         j1=j+1
7414         j2=j-1
7415       else
7416         j1=j-1
7417         j2=j-2
7418       endif
7419       if (l.lt.nres-1) then
7420         l1=l+1
7421         l2=l-1
7422       else
7423         l1=l-1
7424         l2=l-2
7425       endif
7426       do ll=1,3
7427 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7428 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7429         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7430         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7431 cgrad        ghalf=0.5d0*ggg1(ll)
7432         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7433         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7434         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7435         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7436         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7437         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7438 cgrad        ghalf=0.5d0*ggg2(ll)
7439         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7440         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7441         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7442         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7443         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7444         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7445       enddo
7446 cgrad      do m=i+1,j-1
7447 cgrad        do ll=1,3
7448 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7449 cgrad        enddo
7450 cgrad      enddo
7451 cgrad      do m=k+1,l-1
7452 cgrad        do ll=1,3
7453 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7454 cgrad        enddo
7455 cgrad      enddo
7456 cgrad      do m=i+2,j2
7457 cgrad        do ll=1,3
7458 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7459 cgrad        enddo
7460 cgrad      enddo
7461 cgrad      do m=k+2,l2
7462 cgrad        do ll=1,3
7463 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7464 cgrad        enddo
7465 cgrad      enddo
7466 cd      do iii=1,nres-3
7467 cd        write (2,*) iii,gcorr_loc(iii)
7468 cd      enddo
7469       eello4=ekont*eel4
7470 cd      write (2,*) 'ekont',ekont
7471 cd      write (iout,*) 'eello4',ekont*eel4
7472       return
7473       end
7474 C---------------------------------------------------------------------------
7475       double precision function eello5(i,j,k,l,jj,kk)
7476       implicit real*8 (a-h,o-z)
7477       include 'DIMENSIONS'
7478       include 'COMMON.IOUNITS'
7479       include 'COMMON.CHAIN'
7480       include 'COMMON.DERIV'
7481       include 'COMMON.INTERACT'
7482       include 'COMMON.CONTACTS'
7483       include 'COMMON.TORSION'
7484       include 'COMMON.VAR'
7485       include 'COMMON.GEO'
7486       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7487       double precision ggg1(3),ggg2(3)
7488 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7489 C                                                                              C
7490 C                            Parallel chains                                   C
7491 C                                                                              C
7492 C          o             o                   o             o                   C
7493 C         /l\           / \             \   / \           / \   /              C
7494 C        /   \         /   \             \ /   \         /   \ /               C
7495 C       j| o |l1       | o |              o| o |         | o |o                C
7496 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7497 C      \i/   \         /   \ /             /   \         /   \                 C
7498 C       o    k1             o                                                  C
7499 C         (I)          (II)                (III)          (IV)                 C
7500 C                                                                              C
7501 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7502 C                                                                              C
7503 C                            Antiparallel chains                               C
7504 C                                                                              C
7505 C          o             o                   o             o                   C
7506 C         /j\           / \             \   / \           / \   /              C
7507 C        /   \         /   \             \ /   \         /   \ /               C
7508 C      j1| o |l        | o |              o| o |         | o |o                C
7509 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7510 C      \i/   \         /   \ /             /   \         /   \                 C
7511 C       o     k1            o                                                  C
7512 C         (I)          (II)                (III)          (IV)                 C
7513 C                                                                              C
7514 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7515 C                                                                              C
7516 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7517 C                                                                              C
7518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7519 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7520 cd        eello5=0.0d0
7521 cd        return
7522 cd      endif
7523 cd      write (iout,*)
7524 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7525 cd     &   ' and',k,l
7526       itk=itortyp(itype(k))
7527       itl=itortyp(itype(l))
7528       itj=itortyp(itype(j))
7529       eello5_1=0.0d0
7530       eello5_2=0.0d0
7531       eello5_3=0.0d0
7532       eello5_4=0.0d0
7533 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7534 cd     &   eel5_3_num,eel5_4_num)
7535       do iii=1,2
7536         do kkk=1,5
7537           do lll=1,3
7538             derx(lll,kkk,iii)=0.0d0
7539           enddo
7540         enddo
7541       enddo
7542 cd      eij=facont_hb(jj,i)
7543 cd      ekl=facont_hb(kk,k)
7544 cd      ekont=eij*ekl
7545 cd      write (iout,*)'Contacts have occurred for peptide groups',
7546 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7547 cd      goto 1111
7548 C Contribution from the graph I.
7549 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7550 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7551       call transpose2(EUg(1,1,k),auxmat(1,1))
7552       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7553       vv(1)=pizda(1,1)-pizda(2,2)
7554       vv(2)=pizda(1,2)+pizda(2,1)
7555       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7556      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7557 C Explicit gradient in virtual-dihedral angles.
7558       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7559      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7560      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7561       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7562       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7563       vv(1)=pizda(1,1)-pizda(2,2)
7564       vv(2)=pizda(1,2)+pizda(2,1)
7565       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7566      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7567      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7568       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7569       vv(1)=pizda(1,1)-pizda(2,2)
7570       vv(2)=pizda(1,2)+pizda(2,1)
7571       if (l.eq.j+1) then
7572         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7573      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7574      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7575       else
7576         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7577      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7578      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7579       endif
7580 C Cartesian gradient
7581       do iii=1,2
7582         do kkk=1,5
7583           do lll=1,3
7584             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7585      &        pizda(1,1))
7586             vv(1)=pizda(1,1)-pizda(2,2)
7587             vv(2)=pizda(1,2)+pizda(2,1)
7588             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7589      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7590      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7591           enddo
7592         enddo
7593       enddo
7594 c      goto 1112
7595 c1111  continue
7596 C Contribution from graph II
7597       call transpose2(EE(1,1,itk),auxmat(1,1))
7598       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7599       vv(1)=pizda(1,1)+pizda(2,2)
7600       vv(2)=pizda(2,1)-pizda(1,2)
7601       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7602      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7603 C Explicit gradient in virtual-dihedral angles.
7604       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7605      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7606       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7607       vv(1)=pizda(1,1)+pizda(2,2)
7608       vv(2)=pizda(2,1)-pizda(1,2)
7609       if (l.eq.j+1) then
7610         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7611      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7612      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7613       else
7614         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7615      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7616      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7617       endif
7618 C Cartesian gradient
7619       do iii=1,2
7620         do kkk=1,5
7621           do lll=1,3
7622             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7623      &        pizda(1,1))
7624             vv(1)=pizda(1,1)+pizda(2,2)
7625             vv(2)=pizda(2,1)-pizda(1,2)
7626             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7627      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7628      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7629           enddo
7630         enddo
7631       enddo
7632 cd      goto 1112
7633 cd1111  continue
7634       if (l.eq.j+1) then
7635 cd        goto 1110
7636 C Parallel orientation
7637 C Contribution from graph III
7638         call transpose2(EUg(1,1,l),auxmat(1,1))
7639         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7640         vv(1)=pizda(1,1)-pizda(2,2)
7641         vv(2)=pizda(1,2)+pizda(2,1)
7642         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7644 C Explicit gradient in virtual-dihedral angles.
7645         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7646      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7647      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7648         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7649         vv(1)=pizda(1,1)-pizda(2,2)
7650         vv(2)=pizda(1,2)+pizda(2,1)
7651         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7652      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7653      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7654         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7655         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7656         vv(1)=pizda(1,1)-pizda(2,2)
7657         vv(2)=pizda(1,2)+pizda(2,1)
7658         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7659      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7661 C Cartesian gradient
7662         do iii=1,2
7663           do kkk=1,5
7664             do lll=1,3
7665               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7666      &          pizda(1,1))
7667               vv(1)=pizda(1,1)-pizda(2,2)
7668               vv(2)=pizda(1,2)+pizda(2,1)
7669               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7670      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7671      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7672             enddo
7673           enddo
7674         enddo
7675 cd        goto 1112
7676 C Contribution from graph IV
7677 cd1110    continue
7678         call transpose2(EE(1,1,itl),auxmat(1,1))
7679         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7680         vv(1)=pizda(1,1)+pizda(2,2)
7681         vv(2)=pizda(2,1)-pizda(1,2)
7682         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7683      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7684 C Explicit gradient in virtual-dihedral angles.
7685         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7686      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7687         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7688         vv(1)=pizda(1,1)+pizda(2,2)
7689         vv(2)=pizda(2,1)-pizda(1,2)
7690         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7691      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7692      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7693 C Cartesian gradient
7694         do iii=1,2
7695           do kkk=1,5
7696             do lll=1,3
7697               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7698      &          pizda(1,1))
7699               vv(1)=pizda(1,1)+pizda(2,2)
7700               vv(2)=pizda(2,1)-pizda(1,2)
7701               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7702      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7703      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7704             enddo
7705           enddo
7706         enddo
7707       else
7708 C Antiparallel orientation
7709 C Contribution from graph III
7710 c        goto 1110
7711         call transpose2(EUg(1,1,j),auxmat(1,1))
7712         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7713         vv(1)=pizda(1,1)-pizda(2,2)
7714         vv(2)=pizda(1,2)+pizda(2,1)
7715         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7717 C Explicit gradient in virtual-dihedral angles.
7718         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7719      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7721         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7722         vv(1)=pizda(1,1)-pizda(2,2)
7723         vv(2)=pizda(1,2)+pizda(2,1)
7724         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7725      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7727         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7728         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7729         vv(1)=pizda(1,1)-pizda(2,2)
7730         vv(2)=pizda(1,2)+pizda(2,1)
7731         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7732      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7734 C Cartesian gradient
7735         do iii=1,2
7736           do kkk=1,5
7737             do lll=1,3
7738               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7739      &          pizda(1,1))
7740               vv(1)=pizda(1,1)-pizda(2,2)
7741               vv(2)=pizda(1,2)+pizda(2,1)
7742               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7743      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7744      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7745             enddo
7746           enddo
7747         enddo
7748 cd        goto 1112
7749 C Contribution from graph IV
7750 1110    continue
7751         call transpose2(EE(1,1,itj),auxmat(1,1))
7752         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7756      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7757 C Explicit gradient in virtual-dihedral angles.
7758         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7759      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7760         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7761         vv(1)=pizda(1,1)+pizda(2,2)
7762         vv(2)=pizda(2,1)-pizda(1,2)
7763         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7764      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7765      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7766 C Cartesian gradient
7767         do iii=1,2
7768           do kkk=1,5
7769             do lll=1,3
7770               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7771      &          pizda(1,1))
7772               vv(1)=pizda(1,1)+pizda(2,2)
7773               vv(2)=pizda(2,1)-pizda(1,2)
7774               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7775      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7776      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7777             enddo
7778           enddo
7779         enddo
7780       endif
7781 1112  continue
7782       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7783 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7784 cd        write (2,*) 'ijkl',i,j,k,l
7785 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7786 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7787 cd      endif
7788 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7789 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7790 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7791 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7792       if (j.lt.nres-1) then
7793         j1=j+1
7794         j2=j-1
7795       else
7796         j1=j-1
7797         j2=j-2
7798       endif
7799       if (l.lt.nres-1) then
7800         l1=l+1
7801         l2=l-1
7802       else
7803         l1=l-1
7804         l2=l-2
7805       endif
7806 cd      eij=1.0d0
7807 cd      ekl=1.0d0
7808 cd      ekont=1.0d0
7809 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7810 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7811 C        summed up outside the subrouine as for the other subroutines
7812 C        handling long-range interactions. The old code is commented out
7813 C        with "cgrad" to keep track of changes.
7814       do ll=1,3
7815 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7816 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7817         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7818         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7819 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7820 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7821 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7822 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7823 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7824 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7825 c     &   gradcorr5ij,
7826 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7827 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7828 cgrad        ghalf=0.5d0*ggg1(ll)
7829 cd        ghalf=0.0d0
7830         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7831         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7832         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7833         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7834         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7835         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7836 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7837 cgrad        ghalf=0.5d0*ggg2(ll)
7838 cd        ghalf=0.0d0
7839         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7840         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7841         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7842         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7843         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7844         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7845       enddo
7846 cd      goto 1112
7847 cgrad      do m=i+1,j-1
7848 cgrad        do ll=1,3
7849 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7850 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7851 cgrad        enddo
7852 cgrad      enddo
7853 cgrad      do m=k+1,l-1
7854 cgrad        do ll=1,3
7855 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7856 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7857 cgrad        enddo
7858 cgrad      enddo
7859 c1112  continue
7860 cgrad      do m=i+2,j2
7861 cgrad        do ll=1,3
7862 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7863 cgrad        enddo
7864 cgrad      enddo
7865 cgrad      do m=k+2,l2
7866 cgrad        do ll=1,3
7867 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cd      do iii=1,nres-3
7871 cd        write (2,*) iii,g_corr5_loc(iii)
7872 cd      enddo
7873       eello5=ekont*eel5
7874 cd      write (2,*) 'ekont',ekont
7875 cd      write (iout,*) 'eello5',ekont*eel5
7876       return
7877       end
7878 c--------------------------------------------------------------------------
7879       double precision function eello6(i,j,k,l,jj,kk)
7880       implicit real*8 (a-h,o-z)
7881       include 'DIMENSIONS'
7882       include 'COMMON.IOUNITS'
7883       include 'COMMON.CHAIN'
7884       include 'COMMON.DERIV'
7885       include 'COMMON.INTERACT'
7886       include 'COMMON.CONTACTS'
7887       include 'COMMON.TORSION'
7888       include 'COMMON.VAR'
7889       include 'COMMON.GEO'
7890       include 'COMMON.FFIELD'
7891       double precision ggg1(3),ggg2(3)
7892 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7893 cd        eello6=0.0d0
7894 cd        return
7895 cd      endif
7896 cd      write (iout,*)
7897 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7898 cd     &   ' and',k,l
7899       eello6_1=0.0d0
7900       eello6_2=0.0d0
7901       eello6_3=0.0d0
7902       eello6_4=0.0d0
7903       eello6_5=0.0d0
7904       eello6_6=0.0d0
7905 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7906 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7907       do iii=1,2
7908         do kkk=1,5
7909           do lll=1,3
7910             derx(lll,kkk,iii)=0.0d0
7911           enddo
7912         enddo
7913       enddo
7914 cd      eij=facont_hb(jj,i)
7915 cd      ekl=facont_hb(kk,k)
7916 cd      ekont=eij*ekl
7917 cd      eij=1.0d0
7918 cd      ekl=1.0d0
7919 cd      ekont=1.0d0
7920       if (l.eq.j+1) then
7921         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7922         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7923         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7924         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7925         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7926         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7927       else
7928         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7929         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7930         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7931         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7932         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7933           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7934         else
7935           eello6_5=0.0d0
7936         endif
7937         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7938       endif
7939 C If turn contributions are considered, they will be handled separately.
7940       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7941 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7942 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7943 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7944 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7945 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7946 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7947 cd      goto 1112
7948       if (j.lt.nres-1) then
7949         j1=j+1
7950         j2=j-1
7951       else
7952         j1=j-1
7953         j2=j-2
7954       endif
7955       if (l.lt.nres-1) then
7956         l1=l+1
7957         l2=l-1
7958       else
7959         l1=l-1
7960         l2=l-2
7961       endif
7962       do ll=1,3
7963 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7964 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7965 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7966 cgrad        ghalf=0.5d0*ggg1(ll)
7967 cd        ghalf=0.0d0
7968         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7969         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7970         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7971         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7972         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7973         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7974         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7975         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7976 cgrad        ghalf=0.5d0*ggg2(ll)
7977 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7978 cd        ghalf=0.0d0
7979         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7980         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7981         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7982         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7983         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7984         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7985       enddo
7986 cd      goto 1112
7987 cgrad      do m=i+1,j-1
7988 cgrad        do ll=1,3
7989 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7990 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7991 cgrad        enddo
7992 cgrad      enddo
7993 cgrad      do m=k+1,l-1
7994 cgrad        do ll=1,3
7995 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7996 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7997 cgrad        enddo
7998 cgrad      enddo
7999 cgrad1112  continue
8000 cgrad      do m=i+2,j2
8001 cgrad        do ll=1,3
8002 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8003 cgrad        enddo
8004 cgrad      enddo
8005 cgrad      do m=k+2,l2
8006 cgrad        do ll=1,3
8007 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8008 cgrad        enddo
8009 cgrad      enddo
8010 cd      do iii=1,nres-3
8011 cd        write (2,*) iii,g_corr6_loc(iii)
8012 cd      enddo
8013       eello6=ekont*eel6
8014 cd      write (2,*) 'ekont',ekont
8015 cd      write (iout,*) 'eello6',ekont*eel6
8016       return
8017       end
8018 c--------------------------------------------------------------------------
8019       double precision function eello6_graph1(i,j,k,l,imat,swap)
8020       implicit real*8 (a-h,o-z)
8021       include 'DIMENSIONS'
8022       include 'COMMON.IOUNITS'
8023       include 'COMMON.CHAIN'
8024       include 'COMMON.DERIV'
8025       include 'COMMON.INTERACT'
8026       include 'COMMON.CONTACTS'
8027       include 'COMMON.TORSION'
8028       include 'COMMON.VAR'
8029       include 'COMMON.GEO'
8030       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8031       logical swap
8032       logical lprn
8033       common /kutas/ lprn
8034 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8035 C                                                                              C
8036 C      Parallel       Antiparallel                                             C
8037 C                                                                              C
8038 C          o             o                                                     C
8039 C         /l\           /j\                                                    C
8040 C        /   \         /   \                                                   C
8041 C       /| o |         | o |\                                                  C
8042 C     \ j|/k\|  /   \  |/k\|l /                                                C
8043 C      \ /   \ /     \ /   \ /                                                 C
8044 C       o     o       o     o                                                  C
8045 C       i             i                                                        C
8046 C                                                                              C
8047 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8048       itk=itortyp(itype(k))
8049       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8050       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8051       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8052       call transpose2(EUgC(1,1,k),auxmat(1,1))
8053       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8054       vv1(1)=pizda1(1,1)-pizda1(2,2)
8055       vv1(2)=pizda1(1,2)+pizda1(2,1)
8056       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8057       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8058       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8059       s5=scalar2(vv(1),Dtobr2(1,i))
8060 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8061       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8062       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8063      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8064      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8065      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8066      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8067      & +scalar2(vv(1),Dtobr2der(1,i)))
8068       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8069       vv1(1)=pizda1(1,1)-pizda1(2,2)
8070       vv1(2)=pizda1(1,2)+pizda1(2,1)
8071       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8072       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8073       if (l.eq.j+1) then
8074         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8075      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8076      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8077      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8078      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8079       else
8080         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8081      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8082      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8083      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8084      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8085       endif
8086       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8087       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8088       vv1(1)=pizda1(1,1)-pizda1(2,2)
8089       vv1(2)=pizda1(1,2)+pizda1(2,1)
8090       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8091      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8092      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8093      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8094       do iii=1,2
8095         if (swap) then
8096           ind=3-iii
8097         else
8098           ind=iii
8099         endif
8100         do kkk=1,5
8101           do lll=1,3
8102             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8103             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8104             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8105             call transpose2(EUgC(1,1,k),auxmat(1,1))
8106             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8107      &        pizda1(1,1))
8108             vv1(1)=pizda1(1,1)-pizda1(2,2)
8109             vv1(2)=pizda1(1,2)+pizda1(2,1)
8110             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8111             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8112      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8113             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8114      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8115             s5=scalar2(vv(1),Dtobr2(1,i))
8116             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8117           enddo
8118         enddo
8119       enddo
8120       return
8121       end
8122 c----------------------------------------------------------------------------
8123       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8124       implicit real*8 (a-h,o-z)
8125       include 'DIMENSIONS'
8126       include 'COMMON.IOUNITS'
8127       include 'COMMON.CHAIN'
8128       include 'COMMON.DERIV'
8129       include 'COMMON.INTERACT'
8130       include 'COMMON.CONTACTS'
8131       include 'COMMON.TORSION'
8132       include 'COMMON.VAR'
8133       include 'COMMON.GEO'
8134       logical swap
8135       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8136      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8137       logical lprn
8138       common /kutas/ lprn
8139 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8140 C                                                                              C
8141 C      Parallel       Antiparallel                                             C
8142 C                                                                              C
8143 C          o             o                                                     C
8144 C     \   /l\           /j\   /                                                C
8145 C      \ /   \         /   \ /                                                 C
8146 C       o| o |         | o |o                                                  C
8147 C     \ j|/k\|      \  |/k\|l                                                  C
8148 C      \ /   \       \ /   \                                                   C
8149 C       o             o                                                        C
8150 C       i             i                                                        C
8151 C                                                                              C
8152 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8153 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8154 C AL 7/4/01 s1 would occur in the sixth-order moment,
8155 C           but not in a cluster cumulant
8156 #ifdef MOMENT
8157       s1=dip(1,jj,i)*dip(1,kk,k)
8158 #endif
8159       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8160       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8161       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8162       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8163       call transpose2(EUg(1,1,k),auxmat(1,1))
8164       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8165       vv(1)=pizda(1,1)-pizda(2,2)
8166       vv(2)=pizda(1,2)+pizda(2,1)
8167       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8168 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8169 #ifdef MOMENT
8170       eello6_graph2=-(s1+s2+s3+s4)
8171 #else
8172       eello6_graph2=-(s2+s3+s4)
8173 #endif
8174 c      eello6_graph2=-s3
8175 C Derivatives in gamma(i-1)
8176       if (i.gt.1) then
8177 #ifdef MOMENT
8178         s1=dipderg(1,jj,i)*dip(1,kk,k)
8179 #endif
8180         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8181         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8182         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8183         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8184 #ifdef MOMENT
8185         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8186 #else
8187         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8188 #endif
8189 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8190       endif
8191 C Derivatives in gamma(k-1)
8192 #ifdef MOMENT
8193       s1=dip(1,jj,i)*dipderg(1,kk,k)
8194 #endif
8195       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8196       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8197       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8198       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8199       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8200       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8201       vv(1)=pizda(1,1)-pizda(2,2)
8202       vv(2)=pizda(1,2)+pizda(2,1)
8203       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8204 #ifdef MOMENT
8205       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8206 #else
8207       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8208 #endif
8209 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8210 C Derivatives in gamma(j-1) or gamma(l-1)
8211       if (j.gt.1) then
8212 #ifdef MOMENT
8213         s1=dipderg(3,jj,i)*dip(1,kk,k)
8214 #endif
8215         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8216         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8217         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8218         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8219         vv(1)=pizda(1,1)-pizda(2,2)
8220         vv(2)=pizda(1,2)+pizda(2,1)
8221         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8222 #ifdef MOMENT
8223         if (swap) then
8224           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8225         else
8226           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8227         endif
8228 #endif
8229         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8230 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8231       endif
8232 C Derivatives in gamma(l-1) or gamma(j-1)
8233       if (l.gt.1) then
8234 #ifdef MOMENT
8235         s1=dip(1,jj,i)*dipderg(3,kk,k)
8236 #endif
8237         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8238         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8239         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8240         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8241         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8242         vv(1)=pizda(1,1)-pizda(2,2)
8243         vv(2)=pizda(1,2)+pizda(2,1)
8244         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8245 #ifdef MOMENT
8246         if (swap) then
8247           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8248         else
8249           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8250         endif
8251 #endif
8252         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8253 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8254       endif
8255 C Cartesian derivatives.
8256       if (lprn) then
8257         write (2,*) 'In eello6_graph2'
8258         do iii=1,2
8259           write (2,*) 'iii=',iii
8260           do kkk=1,5
8261             write (2,*) 'kkk=',kkk
8262             do jjj=1,2
8263               write (2,'(3(2f10.5),5x)')
8264      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8265             enddo
8266           enddo
8267         enddo
8268       endif
8269       do iii=1,2
8270         do kkk=1,5
8271           do lll=1,3
8272 #ifdef MOMENT
8273             if (iii.eq.1) then
8274               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8275             else
8276               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8277             endif
8278 #endif
8279             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8280      &        auxvec(1))
8281             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8282             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8283      &        auxvec(1))
8284             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8285             call transpose2(EUg(1,1,k),auxmat(1,1))
8286             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8287      &        pizda(1,1))
8288             vv(1)=pizda(1,1)-pizda(2,2)
8289             vv(2)=pizda(1,2)+pizda(2,1)
8290             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8291 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8292 #ifdef MOMENT
8293             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8294 #else
8295             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8296 #endif
8297             if (swap) then
8298               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8299             else
8300               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8301             endif
8302           enddo
8303         enddo
8304       enddo
8305       return
8306       end
8307 c----------------------------------------------------------------------------
8308       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8309       implicit real*8 (a-h,o-z)
8310       include 'DIMENSIONS'
8311       include 'COMMON.IOUNITS'
8312       include 'COMMON.CHAIN'
8313       include 'COMMON.DERIV'
8314       include 'COMMON.INTERACT'
8315       include 'COMMON.CONTACTS'
8316       include 'COMMON.TORSION'
8317       include 'COMMON.VAR'
8318       include 'COMMON.GEO'
8319       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8320       logical swap
8321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8322 C                                                                              C
8323 C      Parallel       Antiparallel                                             C
8324 C                                                                              C
8325 C          o             o                                                     C
8326 C         /l\   /   \   /j\                                                    C
8327 C        /   \ /     \ /   \                                                   C
8328 C       /| o |o       o| o |\                                                  C
8329 C       j|/k\|  /      |/k\|l /                                                C
8330 C        /   \ /       /   \ /                                                 C
8331 C       /     o       /     o                                                  C
8332 C       i             i                                                        C
8333 C                                                                              C
8334 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8335 C
8336 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8337 C           energy moment and not to the cluster cumulant.
8338       iti=itortyp(itype(i))
8339       if (j.lt.nres-1) then
8340         itj1=itortyp(itype(j+1))
8341       else
8342         itj1=ntortyp+1
8343       endif
8344       itk=itortyp(itype(k))
8345       itk1=itortyp(itype(k+1))
8346       if (l.lt.nres-1) then
8347         itl1=itortyp(itype(l+1))
8348       else
8349         itl1=ntortyp+1
8350       endif
8351 #ifdef MOMENT
8352       s1=dip(4,jj,i)*dip(4,kk,k)
8353 #endif
8354       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8355       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8356       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8357       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8358       call transpose2(EE(1,1,itk),auxmat(1,1))
8359       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8360       vv(1)=pizda(1,1)+pizda(2,2)
8361       vv(2)=pizda(2,1)-pizda(1,2)
8362       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8363 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8364 cd     & "sum",-(s2+s3+s4)
8365 #ifdef MOMENT
8366       eello6_graph3=-(s1+s2+s3+s4)
8367 #else
8368       eello6_graph3=-(s2+s3+s4)
8369 #endif
8370 c      eello6_graph3=-s4
8371 C Derivatives in gamma(k-1)
8372       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8373       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8374       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8375       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8376 C Derivatives in gamma(l-1)
8377       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8378       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8379       call matmat2(auxmat(1,1),AECAderg(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       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8384 C Cartesian derivatives.
8385       do iii=1,2
8386         do kkk=1,5
8387           do lll=1,3
8388 #ifdef MOMENT
8389             if (iii.eq.1) then
8390               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8391             else
8392               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8393             endif
8394 #endif
8395             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8396      &        auxvec(1))
8397             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8398             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8399      &        auxvec(1))
8400             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8401             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8402      &        pizda(1,1))
8403             vv(1)=pizda(1,1)+pizda(2,2)
8404             vv(2)=pizda(2,1)-pizda(1,2)
8405             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8406 #ifdef MOMENT
8407             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8408 #else
8409             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8410 #endif
8411             if (swap) then
8412               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8413             else
8414               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8415             endif
8416 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8417           enddo
8418         enddo
8419       enddo
8420       return
8421       end
8422 c----------------------------------------------------------------------------
8423       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8424       implicit real*8 (a-h,o-z)
8425       include 'DIMENSIONS'
8426       include 'COMMON.IOUNITS'
8427       include 'COMMON.CHAIN'
8428       include 'COMMON.DERIV'
8429       include 'COMMON.INTERACT'
8430       include 'COMMON.CONTACTS'
8431       include 'COMMON.TORSION'
8432       include 'COMMON.VAR'
8433       include 'COMMON.GEO'
8434       include 'COMMON.FFIELD'
8435       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8436      & auxvec1(2),auxmat1(2,2)
8437       logical swap
8438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8439 C                                                                              C
8440 C      Parallel       Antiparallel                                             C
8441 C                                                                              C
8442 C          o             o                                                     C
8443 C         /l\   /   \   /j\                                                    C
8444 C        /   \ /     \ /   \                                                   C
8445 C       /| o |o       o| o |\                                                  C
8446 C     \ j|/k\|      \  |/k\|l                                                  C
8447 C      \ /   \       \ /   \                                                   C
8448 C       o     \       o     \                                                  C
8449 C       i             i                                                        C
8450 C                                                                              C
8451 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8452 C
8453 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8454 C           energy moment and not to the cluster cumulant.
8455 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8456       iti=itortyp(itype(i))
8457       itj=itortyp(itype(j))
8458       if (j.lt.nres-1) then
8459         itj1=itortyp(itype(j+1))
8460       else
8461         itj1=ntortyp+1
8462       endif
8463       itk=itortyp(itype(k))
8464       if (k.lt.nres-1) then
8465         itk1=itortyp(itype(k+1))
8466       else
8467         itk1=ntortyp+1
8468       endif
8469       itl=itortyp(itype(l))
8470       if (l.lt.nres-1) then
8471         itl1=itortyp(itype(l+1))
8472       else
8473         itl1=ntortyp+1
8474       endif
8475 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8476 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8477 cd     & ' itl',itl,' itl1',itl1
8478 #ifdef MOMENT
8479       if (imat.eq.1) then
8480         s1=dip(3,jj,i)*dip(3,kk,k)
8481       else
8482         s1=dip(2,jj,j)*dip(2,kk,l)
8483       endif
8484 #endif
8485       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8486       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8487       if (j.eq.l+1) then
8488         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8489         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8490       else
8491         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8492         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8493       endif
8494       call transpose2(EUg(1,1,k),auxmat(1,1))
8495       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8496       vv(1)=pizda(1,1)-pizda(2,2)
8497       vv(2)=pizda(2,1)+pizda(1,2)
8498       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8499 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8500 #ifdef MOMENT
8501       eello6_graph4=-(s1+s2+s3+s4)
8502 #else
8503       eello6_graph4=-(s2+s3+s4)
8504 #endif
8505 C Derivatives in gamma(i-1)
8506       if (i.gt.1) then
8507 #ifdef MOMENT
8508         if (imat.eq.1) then
8509           s1=dipderg(2,jj,i)*dip(3,kk,k)
8510         else
8511           s1=dipderg(4,jj,j)*dip(2,kk,l)
8512         endif
8513 #endif
8514         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8515         if (j.eq.l+1) then
8516           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8517           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8518         else
8519           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8520           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8521         endif
8522         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8523         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8524 cd          write (2,*) 'turn6 derivatives'
8525 #ifdef MOMENT
8526           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8527 #else
8528           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8529 #endif
8530         else
8531 #ifdef MOMENT
8532           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8533 #else
8534           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8535 #endif
8536         endif
8537       endif
8538 C Derivatives in gamma(k-1)
8539 #ifdef MOMENT
8540       if (imat.eq.1) then
8541         s1=dip(3,jj,i)*dipderg(2,kk,k)
8542       else
8543         s1=dip(2,jj,j)*dipderg(4,kk,l)
8544       endif
8545 #endif
8546       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8547       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8548       if (j.eq.l+1) then
8549         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8550         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8551       else
8552         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8553         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8554       endif
8555       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8556       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8557       vv(1)=pizda(1,1)-pizda(2,2)
8558       vv(2)=pizda(2,1)+pizda(1,2)
8559       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8560       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8561 #ifdef MOMENT
8562         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8563 #else
8564         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8565 #endif
8566       else
8567 #ifdef MOMENT
8568         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8569 #else
8570         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8571 #endif
8572       endif
8573 C Derivatives in gamma(j-1) or gamma(l-1)
8574       if (l.eq.j+1 .and. l.gt.1) then
8575         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8576         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8577         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8578         vv(1)=pizda(1,1)-pizda(2,2)
8579         vv(2)=pizda(2,1)+pizda(1,2)
8580         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8581         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8582       else if (j.gt.1) then
8583         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8584         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8585         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8586         vv(1)=pizda(1,1)-pizda(2,2)
8587         vv(2)=pizda(2,1)+pizda(1,2)
8588         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8589         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8590           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8591         else
8592           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8593         endif
8594       endif
8595 C Cartesian derivatives.
8596       do iii=1,2
8597         do kkk=1,5
8598           do lll=1,3
8599 #ifdef MOMENT
8600             if (iii.eq.1) then
8601               if (imat.eq.1) then
8602                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8603               else
8604                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8605               endif
8606             else
8607               if (imat.eq.1) then
8608                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8609               else
8610                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8611               endif
8612             endif
8613 #endif
8614             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8615      &        auxvec(1))
8616             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8617             if (j.eq.l+1) then
8618               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8619      &          b1(1,itj1),auxvec(1))
8620               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8621             else
8622               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8623      &          b1(1,itl1),auxvec(1))
8624               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8625             endif
8626             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8627      &        pizda(1,1))
8628             vv(1)=pizda(1,1)-pizda(2,2)
8629             vv(2)=pizda(2,1)+pizda(1,2)
8630             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8631             if (swap) then
8632               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8633 #ifdef MOMENT
8634                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8635      &             -(s1+s2+s4)
8636 #else
8637                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8638      &             -(s2+s4)
8639 #endif
8640                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8641               else
8642 #ifdef MOMENT
8643                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8644 #else
8645                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8646 #endif
8647                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8648               endif
8649             else
8650 #ifdef MOMENT
8651               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8652 #else
8653               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8654 #endif
8655               if (l.eq.j+1) then
8656                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8657               else
8658                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8659               endif
8660             endif
8661           enddo
8662         enddo
8663       enddo
8664       return
8665       end
8666 c----------------------------------------------------------------------------
8667       double precision function eello_turn6(i,jj,kk)
8668       implicit real*8 (a-h,o-z)
8669       include 'DIMENSIONS'
8670       include 'COMMON.IOUNITS'
8671       include 'COMMON.CHAIN'
8672       include 'COMMON.DERIV'
8673       include 'COMMON.INTERACT'
8674       include 'COMMON.CONTACTS'
8675       include 'COMMON.TORSION'
8676       include 'COMMON.VAR'
8677       include 'COMMON.GEO'
8678       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8679      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8680      &  ggg1(3),ggg2(3)
8681       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8682      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8683 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8684 C           the respective energy moment and not to the cluster cumulant.
8685       s1=0.0d0
8686       s8=0.0d0
8687       s13=0.0d0
8688 c
8689       eello_turn6=0.0d0
8690       j=i+4
8691       k=i+1
8692       l=i+3
8693       iti=itortyp(itype(i))
8694       itk=itortyp(itype(k))
8695       itk1=itortyp(itype(k+1))
8696       itl=itortyp(itype(l))
8697       itj=itortyp(itype(j))
8698 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8699 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8700 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8701 cd        eello6=0.0d0
8702 cd        return
8703 cd      endif
8704 cd      write (iout,*)
8705 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8706 cd     &   ' and',k,l
8707 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8708       do iii=1,2
8709         do kkk=1,5
8710           do lll=1,3
8711             derx_turn(lll,kkk,iii)=0.0d0
8712           enddo
8713         enddo
8714       enddo
8715 cd      eij=1.0d0
8716 cd      ekl=1.0d0
8717 cd      ekont=1.0d0
8718       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8719 cd      eello6_5=0.0d0
8720 cd      write (2,*) 'eello6_5',eello6_5
8721 #ifdef MOMENT
8722       call transpose2(AEA(1,1,1),auxmat(1,1))
8723       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8724       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8725       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8726 #endif
8727       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8728       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8729       s2 = scalar2(b1(1,itk),vtemp1(1))
8730 #ifdef MOMENT
8731       call transpose2(AEA(1,1,2),atemp(1,1))
8732       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8733       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8734       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8735 #endif
8736       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8737       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8738       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8739 #ifdef MOMENT
8740       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8741       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8742       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8743       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8744       ss13 = scalar2(b1(1,itk),vtemp4(1))
8745       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8746 #endif
8747 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8748 c      s1=0.0d0
8749 c      s2=0.0d0
8750 c      s8=0.0d0
8751 c      s12=0.0d0
8752 c      s13=0.0d0
8753       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8754 C Derivatives in gamma(i+2)
8755       s1d =0.0d0
8756       s8d =0.0d0
8757 #ifdef MOMENT
8758       call transpose2(AEA(1,1,1),auxmatd(1,1))
8759       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8760       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8761       call transpose2(AEAderg(1,1,2),atempd(1,1))
8762       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8763       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8764 #endif
8765       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8766       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8767       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8768 c      s1d=0.0d0
8769 c      s2d=0.0d0
8770 c      s8d=0.0d0
8771 c      s12d=0.0d0
8772 c      s13d=0.0d0
8773       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8774 C Derivatives in gamma(i+3)
8775 #ifdef MOMENT
8776       call transpose2(AEA(1,1,1),auxmatd(1,1))
8777       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8778       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8779       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8780 #endif
8781       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8782       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8783       s2d = scalar2(b1(1,itk),vtemp1d(1))
8784 #ifdef MOMENT
8785       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8786       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8787 #endif
8788       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8789 #ifdef MOMENT
8790       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8791       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8792       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8793 #endif
8794 c      s1d=0.0d0
8795 c      s2d=0.0d0
8796 c      s8d=0.0d0
8797 c      s12d=0.0d0
8798 c      s13d=0.0d0
8799 #ifdef MOMENT
8800       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8801      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8802 #else
8803       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8804      &               -0.5d0*ekont*(s2d+s12d)
8805 #endif
8806 C Derivatives in gamma(i+4)
8807       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8808       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8809       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8810 #ifdef MOMENT
8811       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8812       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8813       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8814 #endif
8815 c      s1d=0.0d0
8816 c      s2d=0.0d0
8817 c      s8d=0.0d0
8818 C      s12d=0.0d0
8819 c      s13d=0.0d0
8820 #ifdef MOMENT
8821       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8822 #else
8823       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8824 #endif
8825 C Derivatives in gamma(i+5)
8826 #ifdef MOMENT
8827       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8828       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8829       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8830 #endif
8831       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8832       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8833       s2d = scalar2(b1(1,itk),vtemp1d(1))
8834 #ifdef MOMENT
8835       call transpose2(AEA(1,1,2),atempd(1,1))
8836       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8837       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8838 #endif
8839       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8840       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8841 #ifdef MOMENT
8842       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8843       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8844       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8845 #endif
8846 c      s1d=0.0d0
8847 c      s2d=0.0d0
8848 c      s8d=0.0d0
8849 c      s12d=0.0d0
8850 c      s13d=0.0d0
8851 #ifdef MOMENT
8852       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8853      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8854 #else
8855       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8856      &               -0.5d0*ekont*(s2d+s12d)
8857 #endif
8858 C Cartesian derivatives
8859       do iii=1,2
8860         do kkk=1,5
8861           do lll=1,3
8862 #ifdef MOMENT
8863             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8864             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8865             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8866 #endif
8867             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8868             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8869      &          vtemp1d(1))
8870             s2d = scalar2(b1(1,itk),vtemp1d(1))
8871 #ifdef MOMENT
8872             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8873             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8874             s8d = -(atempd(1,1)+atempd(2,2))*
8875      &           scalar2(cc(1,1,itl),vtemp2(1))
8876 #endif
8877             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8878      &           auxmatd(1,1))
8879             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8880             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8881 c      s1d=0.0d0
8882 c      s2d=0.0d0
8883 c      s8d=0.0d0
8884 c      s12d=0.0d0
8885 c      s13d=0.0d0
8886 #ifdef MOMENT
8887             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8888      &        - 0.5d0*(s1d+s2d)
8889 #else
8890             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8891      &        - 0.5d0*s2d
8892 #endif
8893 #ifdef MOMENT
8894             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8895      &        - 0.5d0*(s8d+s12d)
8896 #else
8897             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8898      &        - 0.5d0*s12d
8899 #endif
8900           enddo
8901         enddo
8902       enddo
8903 #ifdef MOMENT
8904       do kkk=1,5
8905         do lll=1,3
8906           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8907      &      achuj_tempd(1,1))
8908           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8909           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8910           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8911           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8912           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8913      &      vtemp4d(1))
8914           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8915           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8916           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8917         enddo
8918       enddo
8919 #endif
8920 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8921 cd     &  16*eel_turn6_num
8922 cd      goto 1112
8923       if (j.lt.nres-1) then
8924         j1=j+1
8925         j2=j-1
8926       else
8927         j1=j-1
8928         j2=j-2
8929       endif
8930       if (l.lt.nres-1) then
8931         l1=l+1
8932         l2=l-1
8933       else
8934         l1=l-1
8935         l2=l-2
8936       endif
8937       do ll=1,3
8938 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8939 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8940 cgrad        ghalf=0.5d0*ggg1(ll)
8941 cd        ghalf=0.0d0
8942         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8943         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8944         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8945      &    +ekont*derx_turn(ll,2,1)
8946         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8947         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8948      &    +ekont*derx_turn(ll,4,1)
8949         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8950         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8951         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8952 cgrad        ghalf=0.5d0*ggg2(ll)
8953 cd        ghalf=0.0d0
8954         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8955      &    +ekont*derx_turn(ll,2,2)
8956         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8957         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8958      &    +ekont*derx_turn(ll,4,2)
8959         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8960         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8961         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8962       enddo
8963 cd      goto 1112
8964 cgrad      do m=i+1,j-1
8965 cgrad        do ll=1,3
8966 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8967 cgrad        enddo
8968 cgrad      enddo
8969 cgrad      do m=k+1,l-1
8970 cgrad        do ll=1,3
8971 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8972 cgrad        enddo
8973 cgrad      enddo
8974 cgrad1112  continue
8975 cgrad      do m=i+2,j2
8976 cgrad        do ll=1,3
8977 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8978 cgrad        enddo
8979 cgrad      enddo
8980 cgrad      do m=k+2,l2
8981 cgrad        do ll=1,3
8982 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8983 cgrad        enddo
8984 cgrad      enddo
8985 cd      do iii=1,nres-3
8986 cd        write (2,*) iii,g_corr6_loc(iii)
8987 cd      enddo
8988       eello_turn6=ekont*eel_turn6
8989 cd      write (2,*) 'ekont',ekont
8990 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8991       return
8992       end
8993
8994 C-----------------------------------------------------------------------------
8995       double precision function scalar(u,v)
8996 !DIR$ INLINEALWAYS scalar
8997 #ifndef OSF
8998 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8999 #endif
9000       implicit none
9001       double precision u(3),v(3)
9002 cd      double precision sc
9003 cd      integer i
9004 cd      sc=0.0d0
9005 cd      do i=1,3
9006 cd        sc=sc+u(i)*v(i)
9007 cd      enddo
9008 cd      scalar=sc
9009
9010       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9011       return
9012       end
9013 crc-------------------------------------------------
9014       SUBROUTINE MATVEC2(A1,V1,V2)
9015 !DIR$ INLINEALWAYS MATVEC2
9016 #ifndef OSF
9017 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9018 #endif
9019       implicit real*8 (a-h,o-z)
9020       include 'DIMENSIONS'
9021       DIMENSION A1(2,2),V1(2),V2(2)
9022 c      DO 1 I=1,2
9023 c        VI=0.0
9024 c        DO 3 K=1,2
9025 c    3     VI=VI+A1(I,K)*V1(K)
9026 c        Vaux(I)=VI
9027 c    1 CONTINUE
9028
9029       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9030       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9031
9032       v2(1)=vaux1
9033       v2(2)=vaux2
9034       END
9035 C---------------------------------------
9036       SUBROUTINE MATMAT2(A1,A2,A3)
9037 #ifndef OSF
9038 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9039 #endif
9040       implicit real*8 (a-h,o-z)
9041       include 'DIMENSIONS'
9042       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9043 c      DIMENSION AI3(2,2)
9044 c        DO  J=1,2
9045 c          A3IJ=0.0
9046 c          DO K=1,2
9047 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9048 c          enddo
9049 c          A3(I,J)=A3IJ
9050 c       enddo
9051 c      enddo
9052
9053       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9054       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9055       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9056       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9057
9058       A3(1,1)=AI3_11
9059       A3(2,1)=AI3_21
9060       A3(1,2)=AI3_12
9061       A3(2,2)=AI3_22
9062       END
9063
9064 c-------------------------------------------------------------------------
9065       double precision function scalar2(u,v)
9066 !DIR$ INLINEALWAYS scalar2
9067       implicit none
9068       double precision u(2),v(2)
9069       double precision sc
9070       integer i
9071       scalar2=u(1)*v(1)+u(2)*v(2)
9072       return
9073       end
9074
9075 C-----------------------------------------------------------------------------
9076
9077       subroutine transpose2(a,at)
9078 !DIR$ INLINEALWAYS transpose2
9079 #ifndef OSF
9080 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9081 #endif
9082       implicit none
9083       double precision a(2,2),at(2,2)
9084       at(1,1)=a(1,1)
9085       at(1,2)=a(2,1)
9086       at(2,1)=a(1,2)
9087       at(2,2)=a(2,2)
9088       return
9089       end
9090 c--------------------------------------------------------------------------
9091       subroutine transpose(n,a,at)
9092       implicit none
9093       integer n,i,j
9094       double precision a(n,n),at(n,n)
9095       do i=1,n
9096         do j=1,n
9097           at(j,i)=a(i,j)
9098         enddo
9099       enddo
9100       return
9101       end
9102 C---------------------------------------------------------------------------
9103       subroutine prodmat3(a1,a2,kk,transp,prod)
9104 !DIR$ INLINEALWAYS prodmat3
9105 #ifndef OSF
9106 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9107 #endif
9108       implicit none
9109       integer i,j
9110       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9111       logical transp
9112 crc      double precision auxmat(2,2),prod_(2,2)
9113
9114       if (transp) then
9115 crc        call transpose2(kk(1,1),auxmat(1,1))
9116 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9117 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9118
9119            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9120      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9121            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9122      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9123            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9124      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9125            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9126      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9127
9128       else
9129 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9130 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9131
9132            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9133      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9134            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9135      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9136            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9137      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9138            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9139      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9140
9141       endif
9142 c      call transpose2(a2(1,1),a2t(1,1))
9143
9144 crc      print *,transp
9145 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9146 crc      print *,((prod(i,j),i=1,2),j=1,2)
9147
9148       return
9149       end
9150