source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102       goto (101,102,103,104,105,106) ipot
 103 C Lennard-Jones potential.
 104   101 call elj(evdw)
 105 cd    print '(a)','Exit ELJ'
 106       goto 107
 107 C Lennard-Jones-Kihara potential (shifted).
 108   102 call eljk(evdw)
 109       goto 107
 110 C Berne-Pechukas potential (dilated LJ, angular dependence).
 111   103 call ebp(evdw)
 112       goto 107
 113 C Gay-Berne potential (shifted LJ, angular dependence).
 114   104 call egb(evdw)
 115       goto 107
 116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 117   105 call egbv(evdw)
 118       goto 107
 119 C Soft-sphere potential
 120   106 call e_softsphere(evdw)
 121 C
 122 C Calculate electrostatic (H-bonding) energy of the main chain.
 123 C
 124   107 continue
 125 cmc
 126 cmc Sep-06: egb takes care of dynamic ss bonds too
 127 cmc
 128 c      if (dyn_ss) call dyn_set_nss
 129
 130 c      print *,"Processor",myrank," computed USCSC"
 131 #ifdef TIMING
 132       time01=MPI_Wtime()
 133 #endif
 134       call vec_and_deriv
 135 #ifdef TIMING
 136       time_vec=time_vec+MPI_Wtime()-time01
 137 #endif
 138 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 139       if (ipot.lt.6) then
 140 #ifdef SPLITELE
 141          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 142      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 143      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 144      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 145 #else
 146          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 147      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 148      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 149      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 150 #endif
 151             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 152          else
 153             ees=0.0d0
 154             evdw1=0.0d0
 155             eel_loc=0.0d0
 156             eello_turn3=0.0d0
 157             eello_turn4=0.0d0
 158          endif
 159       else
 160         write (iout,*) "Soft-spheer ELEC potential"
 161 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 162 c     &   eello_turn4)
 163       endif
 164 c      print *,"Processor",myrank," computed UELEC"
 165 C
 166 C Calculate excluded-volume interaction energy between peptide groups
 167 C and side chains.
 168 C
 169       if (ipot.lt.6) then
 170        if(wscp.gt.0d0) then
 171         call escp(evdw2,evdw2_14)
 172        else
 173         evdw2=0
 174         evdw2_14=0
 175        endif
 176       else
 177 c        write (iout,*) "Soft-sphere SCP potential"
 178         call escp_soft_sphere(evdw2,evdw2_14)
 179       endif
 180 c
 181 c Calculate the bond-stretching energy
 182 c
 183       call ebond(estr)
 184 C
 185 C Calculate the disulfide-bridge and other energy and the contributions
 186 C from other distance constraints.
 187 cd    print *,'Calling EHPB'
 188       call edis(ehpb)
 189 cd    print *,'EHPB exitted succesfully.'
 190 C
 191 C Calculate the virtual-bond-angle energy.
 192 C
 193       if (wang.gt.0d0) then
 194         call ebend(ebe)
 195       else
 196         ebe=0
 197       endif
 198 c      print *,"Processor",myrank," computed UB"
 199 C
 200 C Calculate the SC local energy.
 201 C
 202       call esc(escloc)
 203 c      print *,"Processor",myrank," computed USC"
 204 C
 205 C Calculate the virtual-bond torsional energy.
 206 C
 207 cd    print *,'nterm=',nterm
 208       if (wtor.gt.0) then
 209        call etor(etors,edihcnstr)
 210       else
 211        etors=0
 212        edihcnstr=0
 213       endif
 214 c      print *,"Processor",myrank," computed Utor"
 215 C
 216 C 6/23/01 Calculate double-torsional energy
 217 C
 218       if (wtor_d.gt.0) then
 219        call etor_d(etors_d)
 220       else
 221        etors_d=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utord"
 224 C
 225 C 21/5/07 Calculate local sicdechain correlation energy
 226 C
 227       if (wsccor.gt.0.0d0) then
 228         call eback_sc_corr(esccor)
 229       else
 230         esccor=0.0d0
 231       endif
 232 c      print *,"Processor",myrank," computed Usccorr"
 233 C
 234 C 12/1/95 Multi-body terms
 235 C
 236       n_corr=0
 237       n_corr1=0
 238       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 239      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 240          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 241 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 242 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 243       else
 244          ecorr=0.0d0
 245          ecorr5=0.0d0
 246          ecorr6=0.0d0
 247          eturn6=0.0d0
 248       endif
 249       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 250          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 251 cd         write (iout,*) "multibody_hb ecorr",ecorr
 252       endif
 253 c      print *,"Processor",myrank," computed Ucorr"
 254 C
 255 C If performing constraint dynamics, call the constraint energy
 256 C  after the equilibration time
 257       if(usampl.and.totT.gt.eq_time) then
 258          call EconstrQ
 259          call Econstr_back
 260       else
 261          Uconst=0.0d0
 262          Uconst_back=0.0d0
 263       endif
 264 #ifdef TIMING
 265       time_enecalc=time_enecalc+MPI_Wtime()-time00
 266 #endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 #ifdef TIMING
 269       time00=MPI_Wtime()
 270 #endif
 271 c
 272 C Sum the energies
 273 C
 274       energia(1)=evdw
 275 #ifdef SCP14
 276       energia(2)=evdw2-evdw2_14
 277       energia(18)=evdw2_14
 278 #else
 279       energia(2)=evdw2
 280       energia(18)=0.0d0
 281 #endif
 282 #ifdef SPLITELE
 283       energia(3)=ees
 284       energia(16)=evdw1
 285 #else
 286       energia(3)=ees+evdw1
 287       energia(16)=0.0d0
 288 #endif
 289       energia(4)=ecorr
 290       energia(5)=ecorr5
 291       energia(6)=ecorr6
 292       energia(7)=eel_loc
 293       energia(8)=eello_turn3
 294       energia(9)=eello_turn4
 295       energia(10)=eturn6
 296       energia(11)=ebe
 297       energia(12)=escloc
 298       energia(13)=etors
 299       energia(14)=etors_d
 300       energia(15)=ehpb
 301       energia(19)=edihcnstr
 302       energia(17)=estr
 303       energia(20)=Uconst+Uconst_back
 304       energia(21)=esccor
 305 c    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445 #endif
 446       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 447      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,ebr*nss,
 982      &  Uconst,etot
 983    10 format (/'Virtual-chain energies:'//
 984      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 985      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 986      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 987      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 988      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 989      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 990      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 991      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 992      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 993      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 994      & ' (SS bridges & dist. cnstr.)'/
 995      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 999      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1000      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1001      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1002      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1003      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1004      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1005      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1006      & 'ETOT=  ',1pE16.6,' (total)')
1007 #else
1008       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1009      &  estr,wbond,ebe,wang,
1010      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1011      &  ecorr,wcorr,
1012      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1013      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1014      &  ebr*nss,Uconst,etot
1015    10 format (/'Virtual-chain energies:'//
1016      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1017      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1018      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1019      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1020      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1021      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1022      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1023      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1024      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1025      & ' (SS bridges & dist. cnstr.)'/
1026      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1029      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1030      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1031      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1032      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1033      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1034      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1035      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1036      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1037      & 'ETOT=  ',1pE16.6,' (total)')
1038 #endif
1039       return
1040       end
1041 C-----------------------------------------------------------------------
1042       subroutine elj(evdw)
1043 C
1044 C This subroutine calculates the interaction energy of nonbonded side chains
1045 C assuming the LJ potential of interaction.
1046 C
1047       implicit real*8 (a-h,o-z)
1048       include 'DIMENSIONS'
1049       parameter (accur=1.0d-10)
1050       include 'COMMON.GEO'
1051       include 'COMMON.VAR'
1052       include 'COMMON.LOCAL'
1053       include 'COMMON.CHAIN'
1054       include 'COMMON.DERIV'
1055       include 'COMMON.INTERACT'
1056       include 'COMMON.TORSION'
1057       include 'COMMON.SBRIDGE'
1058       include 'COMMON.NAMES'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.CONTACTS'
1061       dimension gg(3)
1062 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1063       evdw=0.0D0
1064       do i=iatsc_s,iatsc_e
1065         itypi=iabs(itype(i))
1066         if (itypi.eq.ntyp1) cycle
1067         itypi1=iabs(itype(i+1))
1068         xi=c(1,nres+i)
1069         yi=c(2,nres+i)
1070         zi=c(3,nres+i)
1071 C Change 12/1/95
1072         num_conti=0
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1078 cd   &                  'iend=',iend(i,iint)
1079           do j=istart(i,iint),iend(i,iint)
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             xj=c(1,nres+j)-xi
1083             yj=c(2,nres+j)-yi
1084             zj=c(3,nres+j)-zi
1085 C Change 12/1/95 to calculate four-body interactions
1086             rij=xj*xj+yj*yj+zj*zj
1087             rrij=1.0D0/rij
1088 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1089             eps0ij=eps(itypi,itypj)
1090             fac=rrij**expon2
1091             e1=fac*fac*aa(itypi,itypj)
1092             e2=fac*bb(itypi,itypj)
1093             evdwij=e1+e2
1094 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1097 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1098 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1099 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1100             evdw=evdw+evdwij
1101 C
1102 C Calculate the components of the gradient in DC and X
1103 C
1104             fac=-rrij*(e1+evdwij)
1105             gg(1)=xj*fac
1106             gg(2)=yj*fac
1107             gg(3)=zj*fac
1108             do k=1,3
1109               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1110               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1111               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1112               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1113             enddo
1114 cgrad            do k=i,j-1
1115 cgrad              do l=1,3
1116 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1117 cgrad              enddo
1118 cgrad            enddo
1119 C
1120 C 12/1/95, revised on 5/20/97
1121 C
1122 C Calculate the contact function. The ith column of the array JCONT will
1123 C contain the numbers of atoms that make contacts with the atom I (of numbers
1124 C greater than I). The arrays FACONT and GACONT will contain the values of
1125 C the contact function and its derivative.
1126 C
1127 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1128 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1129 C Uncomment next line, if the correlation interactions are contact function only
1130             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1131               rij=dsqrt(rij)
1132               sigij=sigma(itypi,itypj)
1133               r0ij=rs0(itypi,itypj)
1134 C
1135 C Check whether the SC's are not too far to make a contact.
1136 C
1137               rcut=1.5d0*r0ij
1138               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1139 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1140 C
1141               if (fcont.gt.0.0D0) then
1142 C If the SC-SC distance if close to sigma, apply spline.
1143 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1144 cAdam &             fcont1,fprimcont1)
1145 cAdam           fcont1=1.0d0-fcont1
1146 cAdam           if (fcont1.gt.0.0d0) then
1147 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1148 cAdam             fcont=fcont*fcont1
1149 cAdam           endif
1150 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1151 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1152 cga             do k=1,3
1153 cga               gg(k)=gg(k)*eps0ij
1154 cga             enddo
1155 cga             eps0ij=-evdwij*eps0ij
1156 C Uncomment for AL's type of SC correlation interactions.
1157 cadam           eps0ij=-evdwij
1158                 num_conti=num_conti+1
1159                 jcont(num_conti,i)=j
1160                 facont(num_conti,i)=fcont*eps0ij
1161                 fprimcont=eps0ij*fprimcont/rij
1162                 fcont=expon*fcont
1163 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1164 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1165 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1166 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1167                 gacont(1,num_conti,i)=-fprimcont*xj
1168                 gacont(2,num_conti,i)=-fprimcont*yj
1169                 gacont(3,num_conti,i)=-fprimcont*zj
1170 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1171 cd              write (iout,'(2i3,3f10.5)')
1172 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1173               endif
1174             endif
1175           enddo      ! j
1176         enddo        ! iint
1177 C Change 12/1/95
1178         num_cont(i)=num_conti
1179       enddo          ! i
1180       do i=1,nct
1181         do j=1,3
1182           gvdwc(j,i)=expon*gvdwc(j,i)
1183           gvdwx(j,i)=expon*gvdwx(j,i)
1184         enddo
1185       enddo
1186 C******************************************************************************
1187 C
1188 C                              N O T E !!!
1189 C
1190 C To save time, the factor of EXPON has been extracted from ALL components
1191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1192 C use!
1193 C
1194 C******************************************************************************
1195       return
1196       end
1197 C-----------------------------------------------------------------------------
1198       subroutine eljk(evdw)
1199 C
1200 C This subroutine calculates the interaction energy of nonbonded side chains
1201 C assuming the LJK potential of interaction.
1202 C
1203       implicit real*8 (a-h,o-z)
1204       include 'DIMENSIONS'
1205       include 'COMMON.GEO'
1206       include 'COMMON.VAR'
1207       include 'COMMON.LOCAL'
1208       include 'COMMON.CHAIN'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       include 'COMMON.IOUNITS'
1212       include 'COMMON.NAMES'
1213       dimension gg(3)
1214       logical scheck
1215 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1216       evdw=0.0D0
1217       do i=iatsc_s,iatsc_e
1218         itypi=iabs(itype(i))
1219         if (itypi.eq.ntyp1) cycle
1220         itypi1=iabs(itype(i+1))
1221         xi=c(1,nres+i)
1222         yi=c(2,nres+i)
1223         zi=c(3,nres+i)
1224 C
1225 C Calculate SC interaction energy.
1226 C
1227         do iint=1,nint_gr(i)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             fac_augm=rrij**expon
1236             e_augm=augm(itypi,itypj)*fac_augm
1237             r_inv_ij=dsqrt(rrij)
1238             rij=1.0D0/r_inv_ij
1239             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1240             fac=r_shift_inv**expon
1241             e1=fac*fac*aa(itypi,itypj)
1242             e2=fac*bb(itypi,itypj)
1243             evdwij=e_augm+e1+e2
1244 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1245 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1246 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1247 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1248 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1249 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1250 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1251             evdw=evdw+evdwij
1252 C
1253 C Calculate the components of the gradient in DC and X
1254 C
1255             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1256             gg(1)=xj*fac
1257             gg(2)=yj*fac
1258             gg(3)=zj*fac
1259             do k=1,3
1260               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1261               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1262               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1263               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1264             enddo
1265 cgrad            do k=i,j-1
1266 cgrad              do l=1,3
1267 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1268 cgrad              enddo
1269 cgrad            enddo
1270           enddo      ! j
1271         enddo        ! iint
1272       enddo          ! i
1273       do i=1,nct
1274         do j=1,3
1275           gvdwc(j,i)=expon*gvdwc(j,i)
1276           gvdwx(j,i)=expon*gvdwx(j,i)
1277         enddo
1278       enddo
1279       return
1280       end
1281 C-----------------------------------------------------------------------------
1282       subroutine ebp(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the Berne-Pechukas potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       include 'COMMON.GEO'
1290       include 'COMMON.VAR'
1291       include 'COMMON.LOCAL'
1292       include 'COMMON.CHAIN'
1293       include 'COMMON.DERIV'
1294       include 'COMMON.NAMES'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.CALC'
1298       common /srutu/ icall
1299 c     double precision rrsave(maxdim)
1300       logical lprn
1301       evdw=0.0D0
1302 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304 c     if (icall.eq.0) then
1305 c       lprn=.true.
1306 c     else
1307         lprn=.false.
1308 c     endif
1309       ind=0
1310       do i=iatsc_s,iatsc_e
1311         itypi=iabs(itype(i))
1312         if (itypi.eq.ntyp1) cycle
1313         itypi1=iabs(itype(i+1))
1314         xi=c(1,nres+i)
1315         yi=c(2,nres+i)
1316         zi=c(3,nres+i)
1317         dxi=dc_norm(1,nres+i)
1318         dyi=dc_norm(2,nres+i)
1319         dzi=dc_norm(3,nres+i)
1320 c        dsci_inv=dsc_inv(itypi)
1321         dsci_inv=vbld_inv(i+nres)
1322 C
1323 C Calculate SC interaction energy.
1324 C
1325         do iint=1,nint_gr(i)
1326           do j=istart(i,iint),iend(i,iint)
1327             ind=ind+1
1328             itypj=iabs(itype(j))
1329             if (itypj.eq.ntyp1) cycle
1330 c            dscj_inv=dsc_inv(itypj)
1331             dscj_inv=vbld_inv(j+nres)
1332             chi1=chi(itypi,itypj)
1333             chi2=chi(itypj,itypi)
1334             chi12=chi1*chi2
1335             chip1=chip(itypi)
1336             chip2=chip(itypj)
1337             chip12=chip1*chip2
1338             alf1=alp(itypi)
1339             alf2=alp(itypj)
1340             alf12=0.5D0*(alf1+alf2)
1341 C For diagnostics only!!!
1342 c           chi1=0.0D0
1343 c           chi2=0.0D0
1344 c           chi12=0.0D0
1345 c           chip1=0.0D0
1346 c           chip2=0.0D0
1347 c           chip12=0.0D0
1348 c           alf1=0.0D0
1349 c           alf2=0.0D0
1350 c           alf12=0.0D0
1351             xj=c(1,nres+j)-xi
1352             yj=c(2,nres+j)-yi
1353             zj=c(3,nres+j)-zi
1354             dxj=dc_norm(1,nres+j)
1355             dyj=dc_norm(2,nres+j)
1356             dzj=dc_norm(3,nres+j)
1357             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1358 cd          if (icall.eq.0) then
1359 cd            rrsave(ind)=rrij
1360 cd          else
1361 cd            rrij=rrsave(ind)
1362 cd          endif
1363             rij=dsqrt(rrij)
1364 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1365             call sc_angular
1366 C Calculate whole angle-dependent part of epsilon and contributions
1367 C to its derivatives
1368             fac=(rrij*sigsq)**expon2
1369             e1=fac*fac*aa(itypi,itypj)
1370             e2=fac*bb(itypi,itypj)
1371             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1372             eps2der=evdwij*eps3rt
1373             eps3der=evdwij*eps2rt
1374             evdwij=evdwij*eps2rt*eps3rt
1375             evdw=evdw+evdwij
1376             if (lprn) then
1377             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1378             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1379 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1380 cd     &        restyp(itypi),i,restyp(itypj),j,
1381 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1382 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1383 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1384 cd     &        evdwij
1385             endif
1386 C Calculate gradient components.
1387             e1=e1*eps1*eps2rt**2*eps3rt**2
1388             fac=-expon*(e1+evdwij)
1389             sigder=fac/sigsq
1390             fac=rrij*fac
1391 C Calculate radial part of the gradient
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395 C Calculate the angular part of the gradient and sum add the contributions
1396 C to the appropriate components of the Cartesian gradient.
1397             call sc_grad
1398           enddo      ! j
1399         enddo        ! iint
1400       enddo          ! i
1401 c     stop
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine egb(evdw)
1406 C
1407 C This subroutine calculates the interaction energy of nonbonded side chains
1408 C assuming the Gay-Berne potential of interaction.
1409 C
1410       implicit real*8 (a-h,o-z)
1411       include 'DIMENSIONS'
1412       include 'COMMON.GEO'
1413       include 'COMMON.VAR'
1414       include 'COMMON.LOCAL'
1415       include 'COMMON.CHAIN'
1416       include 'COMMON.DERIV'
1417       include 'COMMON.NAMES'
1418       include 'COMMON.INTERACT'
1419       include 'COMMON.IOUNITS'
1420       include 'COMMON.CALC'
1421       include 'COMMON.CONTROL'
1422       include 'COMMON.SPLITELE'
1423       include 'COMMON.SBRIDGE'
1424       logical lprn
1425       integer xshift,yshift,zshift
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1434 C we have the original box)
1435 C      do xshift=-1,1
1436 C      do yshift=-1,1
1437 C      do zshift=-1,1
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445 C Return atom into box, boxxsize is size of box in x dimension
1446 c  134   continue
1447 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1448 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1449 C Condition for being inside the proper box
1450 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1451 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1452 c        go to 134
1453 c        endif
1454 c  135   continue
1455 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1456 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1457 C Condition for being inside the proper box
1458 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1459 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1460 c        go to 135
1461 c        endif
1462 c  136   continue
1463 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1464 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1465 C Condition for being inside the proper box
1466 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1467 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1468 c        go to 136
1469 c        endif
1470           xi=mod(xi,boxxsize)
1471           if (xi.lt.0) xi=xi+boxxsize
1472           yi=mod(yi,boxysize)
1473           if (yi.lt.0) yi=yi+boxysize
1474           zi=mod(zi,boxzsize)
1475           if (zi.lt.0) zi=zi+boxzsize
1476 C          xi=xi+xshift*boxxsize
1477 C          yi=yi+yshift*boxysize
1478 C          zi=zi+zshift*boxzsize
1479
1480         dxi=dc_norm(1,nres+i)
1481         dyi=dc_norm(2,nres+i)
1482         dzi=dc_norm(3,nres+i)
1483 c        dsci_inv=dsc_inv(itypi)
1484         dsci_inv=vbld_inv(i+nres)
1485 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1486 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1487 C
1488 C Calculate SC interaction energy.
1489 C
1490         do iint=1,nint_gr(i)
1491           do j=istart(i,iint),iend(i,iint)
1492             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1493               call dyn_ssbond_ene(i,j,evdwij)
1494               evdw=evdw+evdwij
1495               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1496      &                        'evdw',i,j,evdwij,' ss'
1497             ELSE
1498             ind=ind+1
1499             itypj=iabs(itype(j))
1500             if (itypj.eq.ntyp1) cycle
1501 c            dscj_inv=dsc_inv(itypj)
1502             dscj_inv=vbld_inv(j+nres)
1503 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1504 c     &       1.0d0/vbld(j+nres)
1505 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1506             sig0ij=sigma(itypi,itypj)
1507             chi1=chi(itypi,itypj)
1508             chi2=chi(itypj,itypi)
1509             chi12=chi1*chi2
1510             chip1=chip(itypi)
1511             chip2=chip(itypj)
1512             chip12=chip1*chip2
1513             alf1=alp(itypi)
1514             alf2=alp(itypj)
1515             alf12=0.5D0*(alf1+alf2)
1516 C For diagnostics only!!!
1517 c           chi1=0.0D0
1518 c           chi2=0.0D0
1519 c           chi12=0.0D0
1520 c           chip1=0.0D0
1521 c           chip2=0.0D0
1522 c           chip12=0.0D0
1523 c           alf1=0.0D0
1524 c           alf2=0.0D0
1525 c           alf12=0.0D0
1526             xj=c(1,nres+j)
1527             yj=c(2,nres+j)
1528             zj=c(3,nres+j)
1529 C Return atom J into box the original box
1530 c  137   continue
1531 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1532 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1533 C Condition for being inside the proper box
1534 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1535 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1536 c        go to 137
1537 c        endif
1538 c  138   continue
1539 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1540 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1541 C Condition for being inside the proper box
1542 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1543 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1544 c        go to 138
1545 c        endif
1546 c  139   continue
1547 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1548 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1549 C Condition for being inside the proper box
1550 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1551 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1552 c        go to 139
1553 c        endif
1554           xj=mod(xj,boxxsize)
1555           if (xj.lt.0) xj=xj+boxxsize
1556           yj=mod(yj,boxysize)
1557           if (yj.lt.0) yj=yj+boxysize
1558           zj=mod(zj,boxzsize)
1559           if (zj.lt.0) zj=zj+boxzsize
1560       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1561       xj_safe=xj
1562       yj_safe=yj
1563       zj_safe=zj
1564       subchap=0
1565       do xshift=-1,1
1566       do yshift=-1,1
1567       do zshift=-1,1
1568           xj=xj_safe+xshift*boxxsize
1569           yj=yj_safe+yshift*boxysize
1570           zj=zj_safe+zshift*boxzsize
1571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1572           if(dist_temp.lt.dist_init) then
1573             dist_init=dist_temp
1574             xj_temp=xj
1575             yj_temp=yj
1576             zj_temp=zj
1577             subchap=1
1578           endif
1579        enddo
1580        enddo
1581        enddo
1582        if (subchap.eq.1) then
1583           xj=xj_temp-xi
1584           yj=yj_temp-yi
1585           zj=zj_temp-zi
1586        else
1587           xj=xj_safe-xi
1588           yj=yj_safe-yi
1589           zj=zj_safe-zi
1590        endif
1591             dxj=dc_norm(1,nres+j)
1592             dyj=dc_norm(2,nres+j)
1593             dzj=dc_norm(3,nres+j)
1594 C            xj=xj-xi
1595 C            yj=yj-yi
1596 C            zj=zj-zi
1597 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1598 c            write (iout,*) "j",j," dc_norm",
1599 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1600             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1601             rij=dsqrt(rrij)
1602             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1603             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1604
1605 c            write (iout,'(a7,4f8.3)')
1606 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1607             if (sss.gt.0.0d0) then
1608 C Calculate angle-dependent terms of energy and contributions to their
1609 C derivatives.
1610             call sc_angular
1611             sigsq=1.0D0/sigsq
1612             sig=sig0ij*dsqrt(sigsq)
1613             rij_shift=1.0D0/rij-sig+sig0ij
1614 c for diagnostics; uncomment
1615 c            rij_shift=1.2*sig0ij
1616 C I hate to put IF's in the loops, but here don't have another choice!!!!
1617             if (rij_shift.le.0.0D0) then
1618               evdw=1.0D20
1619 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1620 cd     &        restyp(itypi),i,restyp(itypj),j,
1621 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1622               return
1623             endif
1624             sigder=-sig*sigsq
1625 c---------------------------------------------------------------
1626             rij_shift=1.0D0/rij_shift
1627             fac=rij_shift**expon
1628             e1=fac*fac*aa(itypi,itypj)
1629             e2=fac*bb(itypi,itypj)
1630             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1631             eps2der=evdwij*eps3rt
1632             eps3der=evdwij*eps2rt
1633 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1634 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1635             evdwij=evdwij*eps2rt*eps3rt
1636             evdw=evdw+evdwij*sss
1637             if (lprn) then
1638             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1639             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1640             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1641      &        restyp(itypi),i,restyp(itypj),j,
1642      &        epsi,sigm,chi1,chi2,chip1,chip2,
1643      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1644      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1645      &        evdwij
1646             endif
1647
1648             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1649      &                        'evdw',i,j,evdwij
1650
1651 C Calculate gradient components.
1652             e1=e1*eps1*eps2rt**2*eps3rt**2
1653             fac=-expon*(e1+evdwij)*rij_shift
1654             sigder=fac*sigder
1655             fac=rij*fac
1656 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1657 c     &      evdwij,fac,sigma(itypi,itypj),expon
1658             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1659 c            fac=0.0d0
1660 C Calculate the radial part of the gradient
1661             gg(1)=xj*fac
1662             gg(2)=yj*fac
1663             gg(3)=zj*fac
1664 C Calculate angular part of the gradient.
1665             call sc_grad
1666             endif    ! sss
1667             ENDIF    ! dyn_ss
1668           enddo      ! j
1669         enddo        ! iint
1670       enddo          ! i
1671 C      enddo          ! zshift
1672 C      enddo          ! yshift
1673 C      enddo          ! xshift
1674 c      write (iout,*) "Number of loop steps in EGB:",ind
1675 cccc      energy_dec=.false.
1676       return
1677       end
1678 C-----------------------------------------------------------------------------
1679       subroutine egbv(evdw)
1680 C
1681 C This subroutine calculates the interaction energy of nonbonded side chains
1682 C assuming the Gay-Berne-Vorobjev potential of interaction.
1683 C
1684       implicit real*8 (a-h,o-z)
1685       include 'DIMENSIONS'
1686       include 'COMMON.GEO'
1687       include 'COMMON.VAR'
1688       include 'COMMON.LOCAL'
1689       include 'COMMON.CHAIN'
1690       include 'COMMON.DERIV'
1691       include 'COMMON.NAMES'
1692       include 'COMMON.INTERACT'
1693       include 'COMMON.IOUNITS'
1694       include 'COMMON.CALC'
1695       common /srutu/ icall
1696       logical lprn
1697       evdw=0.0D0
1698 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1699       evdw=0.0D0
1700       lprn=.false.
1701 c     if (icall.eq.0) lprn=.true.
1702       ind=0
1703       do i=iatsc_s,iatsc_e
1704         itypi=iabs(itype(i))
1705         if (itypi.eq.ntyp1) cycle
1706         itypi1=iabs(itype(i+1))
1707         xi=c(1,nres+i)
1708         yi=c(2,nres+i)
1709         zi=c(3,nres+i)
1710         dxi=dc_norm(1,nres+i)
1711         dyi=dc_norm(2,nres+i)
1712         dzi=dc_norm(3,nres+i)
1713 c        dsci_inv=dsc_inv(itypi)
1714         dsci_inv=vbld_inv(i+nres)
1715 C
1716 C Calculate SC interaction energy.
1717 C
1718         do iint=1,nint_gr(i)
1719           do j=istart(i,iint),iend(i,iint)
1720             ind=ind+1
1721             itypj=iabs(itype(j))
1722             if (itypj.eq.ntyp1) cycle
1723 c            dscj_inv=dsc_inv(itypj)
1724             dscj_inv=vbld_inv(j+nres)
1725             sig0ij=sigma(itypi,itypj)
1726             r0ij=r0(itypi,itypj)
1727             chi1=chi(itypi,itypj)
1728             chi2=chi(itypj,itypi)
1729             chi12=chi1*chi2
1730             chip1=chip(itypi)
1731             chip2=chip(itypj)
1732             chip12=chip1*chip2
1733             alf1=alp(itypi)
1734             alf2=alp(itypj)
1735             alf12=0.5D0*(alf1+alf2)
1736 C For diagnostics only!!!
1737 c           chi1=0.0D0
1738 c           chi2=0.0D0
1739 c           chi12=0.0D0
1740 c           chip1=0.0D0
1741 c           chip2=0.0D0
1742 c           chip12=0.0D0
1743 c           alf1=0.0D0
1744 c           alf2=0.0D0
1745 c           alf12=0.0D0
1746             xj=c(1,nres+j)-xi
1747             yj=c(2,nres+j)-yi
1748             zj=c(3,nres+j)-zi
1749             dxj=dc_norm(1,nres+j)
1750             dyj=dc_norm(2,nres+j)
1751             dzj=dc_norm(3,nres+j)
1752             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1753             rij=dsqrt(rrij)
1754 C Calculate angle-dependent terms of energy and contributions to their
1755 C derivatives.
1756             call sc_angular
1757             sigsq=1.0D0/sigsq
1758             sig=sig0ij*dsqrt(sigsq)
1759             rij_shift=1.0D0/rij-sig+r0ij
1760 C I hate to put IF's in the loops, but here don't have another choice!!!!
1761             if (rij_shift.le.0.0D0) then
1762               evdw=1.0D20
1763               return
1764             endif
1765             sigder=-sig*sigsq
1766 c---------------------------------------------------------------
1767             rij_shift=1.0D0/rij_shift
1768             fac=rij_shift**expon
1769             e1=fac*fac*aa(itypi,itypj)
1770             e2=fac*bb(itypi,itypj)
1771             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1772             eps2der=evdwij*eps3rt
1773             eps3der=evdwij*eps2rt
1774             fac_augm=rrij**expon
1775             e_augm=augm(itypi,itypj)*fac_augm
1776             evdwij=evdwij*eps2rt*eps3rt
1777             evdw=evdw+evdwij+e_augm
1778             if (lprn) then
1779             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1780             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1781             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1782      &        restyp(itypi),i,restyp(itypj),j,
1783      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1784      &        chi1,chi2,chip1,chip2,
1785      &        eps1,eps2rt**2,eps3rt**2,
1786      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1787      &        evdwij+e_augm
1788             endif
1789 C Calculate gradient components.
1790             e1=e1*eps1*eps2rt**2*eps3rt**2
1791             fac=-expon*(e1+evdwij)*rij_shift
1792             sigder=fac*sigder
1793             fac=rij*fac-2*expon*rrij*e_augm
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799             call sc_grad
1800           enddo      ! j
1801         enddo        ! iint
1802       enddo          ! i
1803       end
1804 C-----------------------------------------------------------------------------
1805       subroutine sc_angular
1806 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1807 C om12. Called by ebp, egb, and egbv.
1808       implicit none
1809       include 'COMMON.CALC'
1810       include 'COMMON.IOUNITS'
1811       erij(1)=xj*rij
1812       erij(2)=yj*rij
1813       erij(3)=zj*rij
1814       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1815       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1816       om12=dxi*dxj+dyi*dyj+dzi*dzj
1817       chiom12=chi12*om12
1818 C Calculate eps1(om12) and its derivative in om12
1819       faceps1=1.0D0-om12*chiom12
1820       faceps1_inv=1.0D0/faceps1
1821       eps1=dsqrt(faceps1_inv)
1822 C Following variable is eps1*deps1/dom12
1823       eps1_om12=faceps1_inv*chiom12
1824 c diagnostics only
1825 c      faceps1_inv=om12
1826 c      eps1=om12
1827 c      eps1_om12=1.0d0
1828 c      write (iout,*) "om12",om12," eps1",eps1
1829 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1830 C and om12.
1831       om1om2=om1*om2
1832       chiom1=chi1*om1
1833       chiom2=chi2*om2
1834       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1835       sigsq=1.0D0-facsig*faceps1_inv
1836       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1837       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1838       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1839 c diagnostics only
1840 c      sigsq=1.0d0
1841 c      sigsq_om1=0.0d0
1842 c      sigsq_om2=0.0d0
1843 c      sigsq_om12=0.0d0
1844 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1845 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1846 c     &    " eps1",eps1
1847 C Calculate eps2 and its derivatives in om1, om2, and om12.
1848       chipom1=chip1*om1
1849       chipom2=chip2*om2
1850       chipom12=chip12*om12
1851       facp=1.0D0-om12*chipom12
1852       facp_inv=1.0D0/facp
1853       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1854 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1855 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1856 C Following variable is the square root of eps2
1857       eps2rt=1.0D0-facp1*facp_inv
1858 C Following three variables are the derivatives of the square root of eps
1859 C in om1, om2, and om12.
1860       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1861       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1862       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1863 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1864       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1865 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1866 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1867 c     &  " eps2rt_om12",eps2rt_om12
1868 C Calculate whole angle-dependent part of epsilon and contributions
1869 C to its derivatives
1870       return
1871       end
1872 C----------------------------------------------------------------------------
1873       subroutine sc_grad
1874       implicit real*8 (a-h,o-z)
1875       include 'DIMENSIONS'
1876       include 'COMMON.CHAIN'
1877       include 'COMMON.DERIV'
1878       include 'COMMON.CALC'
1879       include 'COMMON.IOUNITS'
1880       double precision dcosom1(3),dcosom2(3)
1881 cc      print *,'sss=',sss
1882       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1883       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1884       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1885      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1886 c diagnostics only
1887 c      eom1=0.0d0
1888 c      eom2=0.0d0
1889 c      eom12=evdwij*eps1_om12
1890 c end diagnostics
1891 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1892 c     &  " sigder",sigder
1893 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1894 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1895       do k=1,3
1896         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1897         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1898       enddo
1899       do k=1,3
1900         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1901       enddo
1902 c      write (iout,*) "gg",(gg(k),k=1,3)
1903       do k=1,3
1904         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1905      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1906      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1907         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1908      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1909      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1910 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1911 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1912 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914       enddo
1915 C
1916 C Calculate the components of the gradient in DC and X
1917 C
1918 cgrad      do k=i,j-1
1919 cgrad        do l=1,3
1920 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1921 cgrad        enddo
1922 cgrad      enddo
1923       do l=1,3
1924         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1925         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1926       enddo
1927       return
1928       end
1929 C-----------------------------------------------------------------------
1930       subroutine e_softsphere(evdw)
1931 C
1932 C This subroutine calculates the interaction energy of nonbonded side chains
1933 C assuming the LJ potential of interaction.
1934 C
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937       parameter (accur=1.0d-10)
1938       include 'COMMON.GEO'
1939       include 'COMMON.VAR'
1940       include 'COMMON.LOCAL'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.INTERACT'
1944       include 'COMMON.TORSION'
1945       include 'COMMON.SBRIDGE'
1946       include 'COMMON.NAMES'
1947       include 'COMMON.IOUNITS'
1948       include 'COMMON.CONTACTS'
1949       dimension gg(3)
1950 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1951       evdw=0.0D0
1952       do i=iatsc_s,iatsc_e
1953         itypi=iabs(itype(i))
1954         if (itypi.eq.ntyp1) cycle
1955         itypi1=iabs(itype(i+1))
1956         xi=c(1,nres+i)
1957         yi=c(2,nres+i)
1958         zi=c(3,nres+i)
1959 C
1960 C Calculate SC interaction energy.
1961 C
1962         do iint=1,nint_gr(i)
1963 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1964 cd   &                  'iend=',iend(i,iint)
1965           do j=istart(i,iint),iend(i,iint)
1966             itypj=iabs(itype(j))
1967             if (itypj.eq.ntyp1) cycle
1968             xj=c(1,nres+j)-xi
1969             yj=c(2,nres+j)-yi
1970             zj=c(3,nres+j)-zi
1971             rij=xj*xj+yj*yj+zj*zj
1972 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1973             r0ij=r0(itypi,itypj)
1974             r0ijsq=r0ij*r0ij
1975 c            print *,i,j,r0ij,dsqrt(rij)
1976             if (rij.lt.r0ijsq) then
1977               evdwij=0.25d0*(rij-r0ijsq)**2
1978               fac=rij-r0ijsq
1979             else
1980               evdwij=0.0d0
1981               fac=0.0d0
1982             endif
1983             evdw=evdw+evdwij
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987             gg(1)=xj*fac
1988             gg(2)=yj*fac
1989             gg(3)=zj*fac
1990             do k=1,3
1991               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1992               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1993               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1994               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1995             enddo
1996 cgrad            do k=i,j-1
1997 cgrad              do l=1,3
1998 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1999 cgrad              enddo
2000 cgrad            enddo
2001           enddo ! j
2002         enddo ! iint
2003       enddo ! i
2004       return
2005       end
2006 C--------------------------------------------------------------------------
2007       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2008      &              eello_turn4)
2009 C
2010 C Soft-sphere potential of p-p interaction
2011 C
2012       implicit real*8 (a-h,o-z)
2013       include 'DIMENSIONS'
2014       include 'COMMON.CONTROL'
2015       include 'COMMON.IOUNITS'
2016       include 'COMMON.GEO'
2017       include 'COMMON.VAR'
2018       include 'COMMON.LOCAL'
2019       include 'COMMON.CHAIN'
2020       include 'COMMON.DERIV'
2021       include 'COMMON.INTERACT'
2022       include 'COMMON.CONTACTS'
2023       include 'COMMON.TORSION'
2024       include 'COMMON.VECTORS'
2025       include 'COMMON.FFIELD'
2026       dimension ggg(3)
2027 C      write(iout,*) 'In EELEC_soft_sphere'
2028       ees=0.0D0
2029       evdw1=0.0D0
2030       eel_loc=0.0d0
2031       eello_turn3=0.0d0
2032       eello_turn4=0.0d0
2033       ind=0
2034       do i=iatel_s,iatel_e
2035         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2036         dxi=dc(1,i)
2037         dyi=dc(2,i)
2038         dzi=dc(3,i)
2039         xmedi=c(1,i)+0.5d0*dxi
2040         ymedi=c(2,i)+0.5d0*dyi
2041         zmedi=c(3,i)+0.5d0*dzi
2042           xmedi=mod(xmedi,boxxsize)
2043           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2044           ymedi=mod(ymedi,boxysize)
2045           if (ymedi.lt.0) ymedi=ymedi+boxysize
2046           zmedi=mod(zmedi,boxzsize)
2047           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2048         num_conti=0
2049 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2050         do j=ielstart(i),ielend(i)
2051           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2052           ind=ind+1
2053           iteli=itel(i)
2054           itelj=itel(j)
2055           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2056           r0ij=rpp(iteli,itelj)
2057           r0ijsq=r0ij*r0ij
2058           dxj=dc(1,j)
2059           dyj=dc(2,j)
2060           dzj=dc(3,j)
2061           xj=c(1,j)+0.5D0*dxj
2062           yj=c(2,j)+0.5D0*dyj
2063           zj=c(3,j)+0.5D0*dzj
2064           xj=mod(xj,boxxsize)
2065           if (xj.lt.0) xj=xj+boxxsize
2066           yj=mod(yj,boxysize)
2067           if (yj.lt.0) yj=yj+boxysize
2068           zj=mod(zj,boxzsize)
2069           if (zj.lt.0) zj=zj+boxzsize
2070       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2071       xj_safe=xj
2072       yj_safe=yj
2073       zj_safe=zj
2074       isubchap=0
2075       do xshift=-1,1
2076       do yshift=-1,1
2077       do zshift=-1,1
2078           xj=xj_safe+xshift*boxxsize
2079           yj=yj_safe+yshift*boxysize
2080           zj=zj_safe+zshift*boxzsize
2081           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2082           if(dist_temp.lt.dist_init) then
2083             dist_init=dist_temp
2084             xj_temp=xj
2085             yj_temp=yj
2086             zj_temp=zj
2087             isubchap=1
2088           endif
2089        enddo
2090        enddo
2091        enddo
2092        if (isubchap.eq.1) then
2093           xj=xj_temp-xmedi
2094           yj=yj_temp-ymedi
2095           zj=zj_temp-zmedi
2096        else
2097           xj=xj_safe-xmedi
2098           yj=yj_safe-ymedi
2099           zj=zj_safe-zmedi
2100        endif
2101           rij=xj*xj+yj*yj+zj*zj
2102             sss=sscale(sqrt(rij))
2103             sssgrad=sscagrad(sqrt(rij))
2104           if (rij.lt.r0ijsq) then
2105             evdw1ij=0.25d0*(rij-r0ijsq)**2
2106             fac=rij-r0ijsq
2107           else
2108             evdw1ij=0.0d0
2109             fac=0.0d0
2110           endif
2111           evdw1=evdw1+evdw1ij*sss
2112 C
2113 C Calculate contributions to the Cartesian gradient.
2114 C
2115           ggg(1)=fac*xj*sssgrad
2116           ggg(2)=fac*yj*sssgrad
2117           ggg(3)=fac*zj*sssgrad
2118           do k=1,3
2119             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2120             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2121           enddo
2122 *
2123 * Loop over residues i+1 thru j-1.
2124 *
2125 cgrad          do k=i+1,j-1
2126 cgrad            do l=1,3
2127 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2128 cgrad            enddo
2129 cgrad          enddo
2130         enddo ! j
2131       enddo   ! i
2132 cgrad      do i=nnt,nct-1
2133 cgrad        do k=1,3
2134 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2135 cgrad        enddo
2136 cgrad        do j=i+1,nct-1
2137 cgrad          do k=1,3
2138 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2139 cgrad          enddo
2140 cgrad        enddo
2141 cgrad      enddo
2142       return
2143       end
2144 c------------------------------------------------------------------------------
2145       subroutine vec_and_deriv
2146       implicit real*8 (a-h,o-z)
2147       include 'DIMENSIONS'
2148 #ifdef MPI
2149       include 'mpif.h'
2150 #endif
2151       include 'COMMON.IOUNITS'
2152       include 'COMMON.GEO'
2153       include 'COMMON.VAR'
2154       include 'COMMON.LOCAL'
2155       include 'COMMON.CHAIN'
2156       include 'COMMON.VECTORS'
2157       include 'COMMON.SETUP'
2158       include 'COMMON.TIME1'
2159       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2160 C Compute the local reference systems. For reference system (i), the
2161 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2162 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2163 #ifdef PARVEC
2164       do i=ivec_start,ivec_end
2165 #else
2166       do i=1,nres-1
2167 #endif
2168           if (i.eq.nres-1) then
2169 C Case of the last full residue
2170 C Compute the Z-axis
2171             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2172             costh=dcos(pi-theta(nres))
2173             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2174             do k=1,3
2175               uz(k,i)=fac*uz(k,i)
2176             enddo
2177 C Compute the derivatives of uz
2178             uzder(1,1,1)= 0.0d0
2179             uzder(2,1,1)=-dc_norm(3,i-1)
2180             uzder(3,1,1)= dc_norm(2,i-1)
2181             uzder(1,2,1)= dc_norm(3,i-1)
2182             uzder(2,2,1)= 0.0d0
2183             uzder(3,2,1)=-dc_norm(1,i-1)
2184             uzder(1,3,1)=-dc_norm(2,i-1)
2185             uzder(2,3,1)= dc_norm(1,i-1)
2186             uzder(3,3,1)= 0.0d0
2187             uzder(1,1,2)= 0.0d0
2188             uzder(2,1,2)= dc_norm(3,i)
2189             uzder(3,1,2)=-dc_norm(2,i)
2190             uzder(1,2,2)=-dc_norm(3,i)
2191             uzder(2,2,2)= 0.0d0
2192             uzder(3,2,2)= dc_norm(1,i)
2193             uzder(1,3,2)= dc_norm(2,i)
2194             uzder(2,3,2)=-dc_norm(1,i)
2195             uzder(3,3,2)= 0.0d0
2196 C Compute the Y-axis
2197             facy=fac
2198             do k=1,3
2199               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2200             enddo
2201 C Compute the derivatives of uy
2202             do j=1,3
2203               do k=1,3
2204                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2205      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2206                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2207               enddo
2208               uyder(j,j,1)=uyder(j,j,1)-costh
2209               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2210             enddo
2211             do j=1,2
2212               do k=1,3
2213                 do l=1,3
2214                   uygrad(l,k,j,i)=uyder(l,k,j)
2215                   uzgrad(l,k,j,i)=uzder(l,k,j)
2216                 enddo
2217               enddo
2218             enddo
2219             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2220             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2221             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2222             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2223           else
2224 C Other residues
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2227             costh=dcos(pi-theta(i+2))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i+1)
2235             uzder(3,1,1)= dc_norm(2,i+1)
2236             uzder(1,2,1)= dc_norm(3,i+1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i+1)
2239             uzder(1,3,1)=-dc_norm(2,i+1)
2240             uzder(2,3,1)= dc_norm(1,i+1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           endif
2279       enddo
2280       do i=1,nres-1
2281         vbld_inv_temp(1)=vbld_inv(i+1)
2282         if (i.lt.nres-1) then
2283           vbld_inv_temp(2)=vbld_inv(i+2)
2284           else
2285           vbld_inv_temp(2)=vbld_inv(i)
2286           endif
2287         do j=1,2
2288           do k=1,3
2289             do l=1,3
2290               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2291               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2292             enddo
2293           enddo
2294         enddo
2295       enddo
2296 #if defined(PARVEC) && defined(MPI)
2297       if (nfgtasks1.gt.1) then
2298         time00=MPI_Wtime()
2299 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2300 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2301 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2302         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2303      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2304      &   FG_COMM1,IERR)
2305         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2306      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2307      &   FG_COMM1,IERR)
2308         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2309      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2310      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2311         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2312      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2313      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2314         time_gather=time_gather+MPI_Wtime()-time00
2315       endif
2316 c      if (fg_rank.eq.0) then
2317 c        write (iout,*) "Arrays UY and UZ"
2318 c        do i=1,nres-1
2319 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2320 c     &     (uz(k,i),k=1,3)
2321 c        enddo
2322 c      endif
2323 #endif
2324       return
2325       end
2326 C-----------------------------------------------------------------------------
2327       subroutine check_vecgrad
2328       implicit real*8 (a-h,o-z)
2329       include 'DIMENSIONS'
2330       include 'COMMON.IOUNITS'
2331       include 'COMMON.GEO'
2332       include 'COMMON.VAR'
2333       include 'COMMON.LOCAL'
2334       include 'COMMON.CHAIN'
2335       include 'COMMON.VECTORS'
2336       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2337       dimension uyt(3,maxres),uzt(3,maxres)
2338       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2339       double precision delta /1.0d-7/
2340       call vec_and_deriv
2341 cd      do i=1,nres
2342 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2343 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2344 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2345 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2346 cd     &     (dc_norm(if90,i),if90=1,3)
2347 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2348 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2349 cd          write(iout,'(a)')
2350 cd      enddo
2351       do i=1,nres
2352         do j=1,2
2353           do k=1,3
2354             do l=1,3
2355               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2356               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2357             enddo
2358           enddo
2359         enddo
2360       enddo
2361       call vec_and_deriv
2362       do i=1,nres
2363         do j=1,3
2364           uyt(j,i)=uy(j,i)
2365           uzt(j,i)=uz(j,i)
2366         enddo
2367       enddo
2368       do i=1,nres
2369 cd        write (iout,*) 'i=',i
2370         do k=1,3
2371           erij(k)=dc_norm(k,i)
2372         enddo
2373         do j=1,3
2374           do k=1,3
2375             dc_norm(k,i)=erij(k)
2376           enddo
2377           dc_norm(j,i)=dc_norm(j,i)+delta
2378 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2379 c          do k=1,3
2380 c            dc_norm(k,i)=dc_norm(k,i)/fac
2381 c          enddo
2382 c          write (iout,*) (dc_norm(k,i),k=1,3)
2383 c          write (iout,*) (erij(k),k=1,3)
2384           call vec_and_deriv
2385           do k=1,3
2386             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2387             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2388             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2389             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2390           enddo
2391 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2392 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2393 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2394         enddo
2395         do k=1,3
2396           dc_norm(k,i)=erij(k)
2397         enddo
2398 cd        do k=1,3
2399 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2400 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2401 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2402 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2403 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2404 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2405 cd          write (iout,'(a)')
2406 cd        enddo
2407       enddo
2408       return
2409       end
2410 C--------------------------------------------------------------------------
2411       subroutine set_matrices
2412       implicit real*8 (a-h,o-z)
2413       include 'DIMENSIONS'
2414 #ifdef MPI
2415       include "mpif.h"
2416       include "COMMON.SETUP"
2417       integer IERR
2418       integer status(MPI_STATUS_SIZE)
2419 #endif
2420       include 'COMMON.IOUNITS'
2421       include 'COMMON.GEO'
2422       include 'COMMON.VAR'
2423       include 'COMMON.LOCAL'
2424       include 'COMMON.CHAIN'
2425       include 'COMMON.DERIV'
2426       include 'COMMON.INTERACT'
2427       include 'COMMON.CONTACTS'
2428       include 'COMMON.TORSION'
2429       include 'COMMON.VECTORS'
2430       include 'COMMON.FFIELD'
2431       double precision auxvec(2),auxmat(2,2)
2432 C
2433 C Compute the virtual-bond-torsional-angle dependent quantities needed
2434 C to calculate the el-loc multibody terms of various order.
2435 C
2436 c      write(iout,*) 'nphi=',nphi,nres
2437 #ifdef PARMAT
2438       do i=ivec_start+2,ivec_end+2
2439 #else
2440       do i=3,nres+1
2441 #endif
2442 #ifdef NEWCORR
2443         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2444           iti = itortyp(itype(i-2))
2445         else
2446           iti=ntortyp+1
2447         endif
2448 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2449         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2450           iti1 = itortyp(itype(i-1))
2451         else
2452           iti1=ntortyp+1
2453         endif
2454 c        write(iout,*),i
2455         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2456      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2457      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2458         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2459      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2460      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2461 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2462 c     &*(cos(theta(i)/2.0)
2463         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2464      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2465      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2466 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2467 c     &*(cos(theta(i)/2.0)
2468         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2469      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2470      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2471 c        if (ggb1(1,i).eq.0.0d0) then
2472 c        write(iout,*) 'i=',i,ggb1(1,i),
2473 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2474 c     &bnew1(2,1,iti)*cos(theta(i)),
2475 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2476 c        endif
2477         b1(2,i-2)=bnew1(1,2,iti)
2478         gtb1(2,i-2)=0.0
2479         b2(2,i-2)=bnew2(1,2,iti)
2480         gtb2(2,i-2)=0.0
2481         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2482         EE(1,2,i-2)=eeold(1,2,iti)
2483         EE(2,1,i-2)=eeold(2,1,iti)
2484         EE(2,2,i-2)=eeold(2,2,iti)
2485         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2486         gtEE(1,2,i-2)=0.0d0
2487         gtEE(2,2,i-2)=0.0d0
2488         gtEE(2,1,i-2)=0.0d0
2489 c        EE(2,2,iti)=0.0d0
2490 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2491 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2492 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2493 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2494        b1tilde(1,i-2)=b1(1,i-2)
2495        b1tilde(2,i-2)=-b1(2,i-2)
2496        b2tilde(1,i-2)=b2(1,i-2)
2497        b2tilde(2,i-2)=-b2(2,i-2)
2498 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2499 c       write(iout,*)  'b1=',b1(1,i-2)
2500 c       write (iout,*) 'theta=', theta(i-1)
2501        enddo
2502 #else
2503         b1(1,i-2)=b(3,iti)
2504         b1(2,i-2)=b(5,iti)
2505         b2(1,i-2)=b(2,iti)
2506         b2(2,i-2)=b(4,iti)
2507        b1tilde(1,i-2)=b1(1,i-2)
2508        b1tilde(2,i-2)=-b1(2,i-2)
2509        b2tilde(1,i-2)=b2(1,i-2)
2510        b2tilde(2,i-2)=-b2(2,i-2)
2511         EE(1,2,i-2)=eeold(1,2,iti)
2512         EE(2,1,i-2)=eeold(2,1,iti)
2513         EE(2,2,i-2)=eeold(2,2,iti)
2514         EE(1,1,i-2)=eeold(1,1,iti)
2515       enddo
2516 #endif
2517 #ifdef PARMAT
2518       do i=ivec_start+2,ivec_end+2
2519 #else
2520       do i=3,nres+1
2521 #endif
2522         if (i .lt. nres+1) then
2523           sin1=dsin(phi(i))
2524           cos1=dcos(phi(i))
2525           sintab(i-2)=sin1
2526           costab(i-2)=cos1
2527           obrot(1,i-2)=cos1
2528           obrot(2,i-2)=sin1
2529           sin2=dsin(2*phi(i))
2530           cos2=dcos(2*phi(i))
2531           sintab2(i-2)=sin2
2532           costab2(i-2)=cos2
2533           obrot2(1,i-2)=cos2
2534           obrot2(2,i-2)=sin2
2535           Ug(1,1,i-2)=-cos1
2536           Ug(1,2,i-2)=-sin1
2537           Ug(2,1,i-2)=-sin1
2538           Ug(2,2,i-2)= cos1
2539           Ug2(1,1,i-2)=-cos2
2540           Ug2(1,2,i-2)=-sin2
2541           Ug2(2,1,i-2)=-sin2
2542           Ug2(2,2,i-2)= cos2
2543         else
2544           costab(i-2)=1.0d0
2545           sintab(i-2)=0.0d0
2546           obrot(1,i-2)=1.0d0
2547           obrot(2,i-2)=0.0d0
2548           obrot2(1,i-2)=0.0d0
2549           obrot2(2,i-2)=0.0d0
2550           Ug(1,1,i-2)=1.0d0
2551           Ug(1,2,i-2)=0.0d0
2552           Ug(2,1,i-2)=0.0d0
2553           Ug(2,2,i-2)=1.0d0
2554           Ug2(1,1,i-2)=0.0d0
2555           Ug2(1,2,i-2)=0.0d0
2556           Ug2(2,1,i-2)=0.0d0
2557           Ug2(2,2,i-2)=0.0d0
2558         endif
2559         if (i .gt. 3 .and. i .lt. nres+1) then
2560           obrot_der(1,i-2)=-sin1
2561           obrot_der(2,i-2)= cos1
2562           Ugder(1,1,i-2)= sin1
2563           Ugder(1,2,i-2)=-cos1
2564           Ugder(2,1,i-2)=-cos1
2565           Ugder(2,2,i-2)=-sin1
2566           dwacos2=cos2+cos2
2567           dwasin2=sin2+sin2
2568           obrot2_der(1,i-2)=-dwasin2
2569           obrot2_der(2,i-2)= dwacos2
2570           Ug2der(1,1,i-2)= dwasin2
2571           Ug2der(1,2,i-2)=-dwacos2
2572           Ug2der(2,1,i-2)=-dwacos2
2573           Ug2der(2,2,i-2)=-dwasin2
2574         else
2575           obrot_der(1,i-2)=0.0d0
2576           obrot_der(2,i-2)=0.0d0
2577           Ugder(1,1,i-2)=0.0d0
2578           Ugder(1,2,i-2)=0.0d0
2579           Ugder(2,1,i-2)=0.0d0
2580           Ugder(2,2,i-2)=0.0d0
2581           obrot2_der(1,i-2)=0.0d0
2582           obrot2_der(2,i-2)=0.0d0
2583           Ug2der(1,1,i-2)=0.0d0
2584           Ug2der(1,2,i-2)=0.0d0
2585           Ug2der(2,1,i-2)=0.0d0
2586           Ug2der(2,2,i-2)=0.0d0
2587         endif
2588 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2589         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2590           iti = itortyp(itype(i-2))
2591         else
2592           iti=ntortyp
2593         endif
2594 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2595         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2596           iti1 = itortyp(itype(i-1))
2597         else
2598           iti1=ntortyp
2599         endif
2600 cd        write (iout,*) '*******i',i,' iti1',iti
2601 cd        write (iout,*) 'b1',b1(:,iti)
2602 cd        write (iout,*) 'b2',b2(:,iti)
2603 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2604 c        if (i .gt. iatel_s+2) then
2605         if (i .gt. nnt+2) then
2606           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2607 #ifdef NEWCORR
2608           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2609 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2610 #endif
2611 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2612 c     &    EE(1,2,iti),EE(2,2,iti)
2613           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2614           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2615 c          write(iout,*) "Macierz EUG",
2616 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2617 c     &    eug(2,2,i-2)
2618           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2619      &    then
2620           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2621           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2622           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2623           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2624           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2625           endif
2626         else
2627           do k=1,2
2628             Ub2(k,i-2)=0.0d0
2629             Ctobr(k,i-2)=0.0d0
2630             Dtobr2(k,i-2)=0.0d0
2631             do l=1,2
2632               EUg(l,k,i-2)=0.0d0
2633               CUg(l,k,i-2)=0.0d0
2634               DUg(l,k,i-2)=0.0d0
2635               DtUg2(l,k,i-2)=0.0d0
2636             enddo
2637           enddo
2638         endif
2639         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2640         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2641         do k=1,2
2642           muder(k,i-2)=Ub2der(k,i-2)
2643         enddo
2644 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2645         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2646           if (itype(i-1).le.ntyp) then
2647             iti1 = itortyp(itype(i-1))
2648           else
2649             iti1=ntortyp
2650           endif
2651         else
2652           iti1=ntortyp
2653         endif
2654         do k=1,2
2655           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2656         enddo
2657 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2658 cd        write (iout,*) 'mu1',mu1(:,i-2)
2659 cd        write (iout,*) 'mu2',mu2(:,i-2)
2660         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2661      &  then
2662         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2663         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2664         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2665         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2666         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2667 C Vectors and matrices dependent on a single virtual-bond dihedral.
2668         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2669         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2670         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2671         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2672         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2673         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2674         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2675         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2676         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2677         endif
2678       enddo
2679 C Matrices dependent on two consecutive virtual-bond dihedrals.
2680 C The order of matrices is from left to right.
2681       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2682      &then
2683 c      do i=max0(ivec_start,2),ivec_end
2684       do i=2,nres-1
2685         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2686         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2687         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2688         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2689         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2690         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2691         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2692         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2693       enddo
2694       endif
2695 #if defined(MPI) && defined(PARMAT)
2696 #ifdef DEBUG
2697 c      if (fg_rank.eq.0) then
2698         write (iout,*) "Arrays UG and UGDER before GATHER"
2699         do i=1,nres-1
2700           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2701      &     ((ug(l,k,i),l=1,2),k=1,2),
2702      &     ((ugder(l,k,i),l=1,2),k=1,2)
2703         enddo
2704         write (iout,*) "Arrays UG2 and UG2DER"
2705         do i=1,nres-1
2706           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2707      &     ((ug2(l,k,i),l=1,2),k=1,2),
2708      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2709         enddo
2710         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2711         do i=1,nres-1
2712           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2713      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2714      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2715         enddo
2716         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2717         do i=1,nres-1
2718           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2719      &     costab(i),sintab(i),costab2(i),sintab2(i)
2720         enddo
2721         write (iout,*) "Array MUDER"
2722         do i=1,nres-1
2723           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2724         enddo
2725 c      endif
2726 #endif
2727       if (nfgtasks.gt.1) then
2728         time00=MPI_Wtime()
2729 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2730 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2731 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2732 #ifdef MATGATHER
2733         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2740      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2752      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2753      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2755      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2756      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2758      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2759      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2760         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2761      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2762      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2763         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2764      &  then
2765         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2773      &   FG_COMM1,IERR)
2774        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2785      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2800      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2803      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2804      &   FG_COMM1,IERR)
2805         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2806      &   ivec_count(fg_rank1),
2807      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2817      &   FG_COMM1,IERR)
2818        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2819      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2820      &   FG_COMM1,IERR)
2821         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2822      &   ivec_count(fg_rank1),
2823      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2824      &   FG_COMM1,IERR)
2825         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2826      &   ivec_count(fg_rank1),
2827      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2828      &   FG_COMM1,IERR)
2829         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2830      &   ivec_count(fg_rank1),
2831      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2832      &   MPI_MAT2,FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2834      &   ivec_count(fg_rank1),
2835      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2836      &   MPI_MAT2,FG_COMM1,IERR)
2837         endif
2838 #else
2839 c Passes matrix info through the ring
2840       isend=fg_rank1
2841       irecv=fg_rank1-1
2842       if (irecv.lt.0) irecv=nfgtasks1-1
2843       iprev=irecv
2844       inext=fg_rank1+1
2845       if (inext.ge.nfgtasks1) inext=0
2846       do i=1,nfgtasks1-1
2847 c        write (iout,*) "isend",isend," irecv",irecv
2848 c        call flush(iout)
2849         lensend=lentyp(isend)
2850         lenrecv=lentyp(irecv)
2851 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2852 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2853 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2854 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2855 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2856 c        write (iout,*) "Gather ROTAT1"
2857 c        call flush(iout)
2858 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2859 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2860 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2861 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2862 c        write (iout,*) "Gather ROTAT2"
2863 c        call flush(iout)
2864         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2865      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2866      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2867      &   iprev,4400+irecv,FG_COMM,status,IERR)
2868 c        write (iout,*) "Gather ROTAT_OLD"
2869 c        call flush(iout)
2870         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2871      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2872      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2873      &   iprev,5500+irecv,FG_COMM,status,IERR)
2874 c        write (iout,*) "Gather PRECOMP11"
2875 c        call flush(iout)
2876         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2877      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2878      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2879      &   iprev,6600+irecv,FG_COMM,status,IERR)
2880 c        write (iout,*) "Gather PRECOMP12"
2881 c        call flush(iout)
2882         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2883      &  then
2884         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2885      &   MPI_ROTAT2(lensend),inext,7700+isend,
2886      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2887      &   iprev,7700+irecv,FG_COMM,status,IERR)
2888 c        write (iout,*) "Gather PRECOMP21"
2889 c        call flush(iout)
2890         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2891      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2892      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2893      &   iprev,8800+irecv,FG_COMM,status,IERR)
2894 c        write (iout,*) "Gather PRECOMP22"
2895 c        call flush(iout)
2896         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2897      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2898      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2899      &   MPI_PRECOMP23(lenrecv),
2900      &   iprev,9900+irecv,FG_COMM,status,IERR)
2901 c        write (iout,*) "Gather PRECOMP23"
2902 c        call flush(iout)
2903         endif
2904         isend=irecv
2905         irecv=irecv-1
2906         if (irecv.lt.0) irecv=nfgtasks1-1
2907       enddo
2908 #endif
2909         time_gather=time_gather+MPI_Wtime()-time00
2910       endif
2911 #ifdef DEBUG
2912 c      if (fg_rank.eq.0) then
2913         write (iout,*) "Arrays UG and UGDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2916      &     ((ug(l,k,i),l=1,2),k=1,2),
2917      &     ((ugder(l,k,i),l=1,2),k=1,2)
2918         enddo
2919         write (iout,*) "Arrays UG2 and UG2DER"
2920         do i=1,nres-1
2921           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2922      &     ((ug2(l,k,i),l=1,2),k=1,2),
2923      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2924         enddo
2925         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2926         do i=1,nres-1
2927           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2928      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2929      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2930         enddo
2931         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2932         do i=1,nres-1
2933           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2934      &     costab(i),sintab(i),costab2(i),sintab2(i)
2935         enddo
2936         write (iout,*) "Array MUDER"
2937         do i=1,nres-1
2938           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2939         enddo
2940 c      endif
2941 #endif
2942 #endif
2943 cd      do i=1,nres
2944 cd        iti = itortyp(itype(i))
2945 cd        write (iout,*) i
2946 cd        do j=1,2
2947 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2948 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2949 cd        enddo
2950 cd      enddo
2951       return
2952       end
2953 C--------------------------------------------------------------------------
2954       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2955 C
2956 C This subroutine calculates the average interaction energy and its gradient
2957 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2958 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2959 C The potential depends both on the distance of peptide-group centers and on
2960 C the orientation of the CA-CA virtual bonds.
2961 C
2962       implicit real*8 (a-h,o-z)
2963 #ifdef MPI
2964       include 'mpif.h'
2965 #endif
2966       include 'DIMENSIONS'
2967       include 'COMMON.CONTROL'
2968       include 'COMMON.SETUP'
2969       include 'COMMON.IOUNITS'
2970       include 'COMMON.GEO'
2971       include 'COMMON.VAR'
2972       include 'COMMON.LOCAL'
2973       include 'COMMON.CHAIN'
2974       include 'COMMON.DERIV'
2975       include 'COMMON.INTERACT'
2976       include 'COMMON.CONTACTS'
2977       include 'COMMON.TORSION'
2978       include 'COMMON.VECTORS'
2979       include 'COMMON.FFIELD'
2980       include 'COMMON.TIME1'
2981       include 'COMMON.SPLITELE'
2982       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2983      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2984       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2985      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2986       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2987      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2988      &    num_conti,j1,j2
2989 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2990 #ifdef MOMENT
2991       double precision scal_el /1.0d0/
2992 #else
2993       double precision scal_el /0.5d0/
2994 #endif
2995 C 12/13/98
2996 C 13-go grudnia roku pamietnego...
2997       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2998      &                   0.0d0,1.0d0,0.0d0,
2999      &                   0.0d0,0.0d0,1.0d0/
3000 cd      write(iout,*) 'In EELEC'
3001 cd      do i=1,nloctyp
3002 cd        write(iout,*) 'Type',i
3003 cd        write(iout,*) 'B1',B1(:,i)
3004 cd        write(iout,*) 'B2',B2(:,i)
3005 cd        write(iout,*) 'CC',CC(:,:,i)
3006 cd        write(iout,*) 'DD',DD(:,:,i)
3007 cd        write(iout,*) 'EE',EE(:,:,i)
3008 cd      enddo
3009 cd      call check_vecgrad
3010 cd      stop
3011       if (icheckgrad.eq.1) then
3012         do i=1,nres-1
3013           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3014           do k=1,3
3015             dc_norm(k,i)=dc(k,i)*fac
3016           enddo
3017 c          write (iout,*) 'i',i,' fac',fac
3018         enddo
3019       endif
3020       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3021      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3022      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3023 c        call vec_and_deriv
3024 #ifdef TIMING
3025         time01=MPI_Wtime()
3026 #endif
3027         call set_matrices
3028 #ifdef TIMING
3029         time_mat=time_mat+MPI_Wtime()-time01
3030 #endif
3031       endif
3032 cd      do i=1,nres-1
3033 cd        write (iout,*) 'i=',i
3034 cd        do k=1,3
3035 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3036 cd        enddo
3037 cd        do k=1,3
3038 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3039 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3040 cd        enddo
3041 cd      enddo
3042       t_eelecij=0.0d0
3043       ees=0.0D0
3044       evdw1=0.0D0
3045       eel_loc=0.0d0
3046       eello_turn3=0.0d0
3047       eello_turn4=0.0d0
3048       ind=0
3049       do i=1,nres
3050         num_cont_hb(i)=0
3051       enddo
3052 cd      print '(a)','Enter EELEC'
3053 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3054       do i=1,nres
3055         gel_loc_loc(i)=0.0d0
3056         gcorr_loc(i)=0.0d0
3057       enddo
3058 c
3059 c
3060 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3061 C
3062 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3063 C
3064 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3065       do i=iturn3_start,iturn3_end
3066         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3067 C changes suggested by Ana to avoid out of bounds
3068      & .or.((i+4).gt.nres)
3069      & .or.((i-1).le.0)
3070 C end of changes by Ana
3071      &  .or. itype(i+2).eq.ntyp1
3072      &  .or. itype(i+3).eq.ntyp1) cycle
3073         if(i.gt.1)then
3074           if(itype(i-1).eq.ntyp1)cycle
3075         end if
3076         if(i.LT.nres-3)then
3077           if (itype(i+4).eq.ntyp1) cycle
3078         end if
3079         dxi=dc(1,i)
3080         dyi=dc(2,i)
3081         dzi=dc(3,i)
3082         dx_normi=dc_norm(1,i)
3083         dy_normi=dc_norm(2,i)
3084         dz_normi=dc_norm(3,i)
3085         xmedi=c(1,i)+0.5d0*dxi
3086         ymedi=c(2,i)+0.5d0*dyi
3087         zmedi=c(3,i)+0.5d0*dzi
3088           xmedi=mod(xmedi,boxxsize)
3089           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3090           ymedi=mod(ymedi,boxysize)
3091           if (ymedi.lt.0) ymedi=ymedi+boxysize
3092           zmedi=mod(zmedi,boxzsize)
3093           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3094         num_conti=0
3095         call eelecij(i,i+2,ees,evdw1,eel_loc)
3096         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3097         num_cont_hb(i)=num_conti
3098       enddo
3099       do i=iturn4_start,iturn4_end
3100         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3101 C changes suggested by Ana to avoid out of bounds
3102      & .or.((i+5).gt.nres)
3103      & .or.((i-1).le.0)
3104 C end of changes suggested by Ana
3105      &    .or. itype(i+3).eq.ntyp1
3106      &    .or. itype(i+4).eq.ntyp1
3107      &    .or. itype(i+5).eq.ntyp1
3108      &    .or. itype(i).eq.ntyp1
3109      &    .or. itype(i-1).eq.ntyp1
3110      &                             ) cycle
3111         dxi=dc(1,i)
3112         dyi=dc(2,i)
3113         dzi=dc(3,i)
3114         dx_normi=dc_norm(1,i)
3115         dy_normi=dc_norm(2,i)
3116         dz_normi=dc_norm(3,i)
3117         xmedi=c(1,i)+0.5d0*dxi
3118         ymedi=c(2,i)+0.5d0*dyi
3119         zmedi=c(3,i)+0.5d0*dzi
3120 C Return atom into box, boxxsize is size of box in x dimension
3121 c  194   continue
3122 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3123 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3124 C Condition for being inside the proper box
3125 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3126 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3127 c        go to 194
3128 c        endif
3129 c  195   continue
3130 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3131 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3132 C Condition for being inside the proper box
3133 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3134 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3135 c        go to 195
3136 c        endif
3137 c  196   continue
3138 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3139 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3140 C Condition for being inside the proper box
3141 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3142 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3143 c        go to 196
3144 c        endif
3145           xmedi=mod(xmedi,boxxsize)
3146           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3147           ymedi=mod(ymedi,boxysize)
3148           if (ymedi.lt.0) ymedi=ymedi+boxysize
3149           zmedi=mod(zmedi,boxzsize)
3150           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3151
3152         num_conti=num_cont_hb(i)
3153 c        write(iout,*) "JESTEM W PETLI"
3154         call eelecij(i,i+3,ees,evdw1,eel_loc)
3155         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3156      &   call eturn4(i,eello_turn4)
3157         num_cont_hb(i)=num_conti
3158       enddo   ! i
3159 C Loop over all neighbouring boxes
3160 C      do xshift=-1,1
3161 C      do yshift=-1,1
3162 C      do zshift=-1,1
3163 c
3164 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3165 c
3166       do i=iatel_s,iatel_e
3167         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3168 C changes suggested by Ana to avoid out of bounds
3169      & .or.((i+2).gt.nres)
3170      & .or.((i-1).le.0)
3171 C end of changes by Ana
3172      &  .or. itype(i+2).eq.ntyp1
3173      &  .or. itype(i-1).eq.ntyp1
3174      &                ) cycle
3175         dxi=dc(1,i)
3176         dyi=dc(2,i)
3177         dzi=dc(3,i)
3178         dx_normi=dc_norm(1,i)
3179         dy_normi=dc_norm(2,i)
3180         dz_normi=dc_norm(3,i)
3181         xmedi=c(1,i)+0.5d0*dxi
3182         ymedi=c(2,i)+0.5d0*dyi
3183         zmedi=c(3,i)+0.5d0*dzi
3184           xmedi=mod(xmedi,boxxsize)
3185           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3186           ymedi=mod(ymedi,boxysize)
3187           if (ymedi.lt.0) ymedi=ymedi+boxysize
3188           zmedi=mod(zmedi,boxzsize)
3189           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3190 C          xmedi=xmedi+xshift*boxxsize
3191 C          ymedi=ymedi+yshift*boxysize
3192 C          zmedi=zmedi+zshift*boxzsize
3193
3194 C Return tom into box, boxxsize is size of box in x dimension
3195 c  164   continue
3196 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3197 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3198 C Condition for being inside the proper box
3199 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3200 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3201 c        go to 164
3202 c        endif
3203 c  165   continue
3204 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3205 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3206 C Condition for being inside the proper box
3207 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3208 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3209 c        go to 165
3210 c        endif
3211 c  166   continue
3212 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3213 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3214 cC Condition for being inside the proper box
3215 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3216 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3217 c        go to 166
3218 c        endif
3219
3220 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3221         num_conti=num_cont_hb(i)
3222         do j=ielstart(i),ielend(i)
3223 c          write (iout,*) i,j,itype(i),itype(j)
3224           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3225 C changes suggested by Ana to avoid out of bounds
3226      & .or.((j+2).gt.nres)
3227      & .or.((j-1).le.0)
3228 C end of changes by Ana
3229      & .or.itype(j+2).eq.ntyp1
3230      & .or.itype(j-1).eq.ntyp1
3231      &) cycle
3232           call eelecij(i,j,ees,evdw1,eel_loc)
3233         enddo ! j
3234         num_cont_hb(i)=num_conti
3235       enddo   ! i
3236 C     enddo   ! zshift
3237 C      enddo   ! yshift
3238 C      enddo   ! xshift
3239
3240 c      write (iout,*) "Number of loop steps in EELEC:",ind
3241 cd      do i=1,nres
3242 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3243 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3244 cd      enddo
3245 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3246 ccc      eel_loc=eel_loc+eello_turn3
3247 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3248       return
3249       end
3250 C-------------------------------------------------------------------------------
3251       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3252       implicit real*8 (a-h,o-z)
3253       include 'DIMENSIONS'
3254 #ifdef MPI
3255       include "mpif.h"
3256 #endif
3257       include 'COMMON.CONTROL'
3258       include 'COMMON.IOUNITS'
3259       include 'COMMON.GEO'
3260       include 'COMMON.VAR'
3261       include 'COMMON.LOCAL'
3262       include 'COMMON.CHAIN'
3263       include 'COMMON.DERIV'
3264       include 'COMMON.INTERACT'
3265       include 'COMMON.CONTACTS'
3266       include 'COMMON.TORSION'
3267       include 'COMMON.VECTORS'
3268       include 'COMMON.FFIELD'
3269       include 'COMMON.TIME1'
3270       include 'COMMON.SPLITELE'
3271       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3272      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3273       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3274      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3275      &    gmuij2(4),gmuji2(4)
3276       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3277      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3278      &    num_conti,j1,j2
3279 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3280 #ifdef MOMENT
3281       double precision scal_el /1.0d0/
3282 #else
3283       double precision scal_el /0.5d0/
3284 #endif
3285 C 12/13/98
3286 C 13-go grudnia roku pamietnego...
3287       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3288      &                   0.0d0,1.0d0,0.0d0,
3289      &                   0.0d0,0.0d0,1.0d0/
3290 c          time00=MPI_Wtime()
3291 cd      write (iout,*) "eelecij",i,j
3292 c          ind=ind+1
3293           iteli=itel(i)
3294           itelj=itel(j)
3295           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3296           aaa=app(iteli,itelj)
3297           bbb=bpp(iteli,itelj)
3298           ael6i=ael6(iteli,itelj)
3299           ael3i=ael3(iteli,itelj)
3300           dxj=dc(1,j)
3301           dyj=dc(2,j)
3302           dzj=dc(3,j)
3303           dx_normj=dc_norm(1,j)
3304           dy_normj=dc_norm(2,j)
3305           dz_normj=dc_norm(3,j)
3306 C          xj=c(1,j)+0.5D0*dxj-xmedi
3307 C          yj=c(2,j)+0.5D0*dyj-ymedi
3308 C          zj=c(3,j)+0.5D0*dzj-zmedi
3309           xj=c(1,j)+0.5D0*dxj
3310           yj=c(2,j)+0.5D0*dyj
3311           zj=c(3,j)+0.5D0*dzj
3312           xj=mod(xj,boxxsize)
3313           if (xj.lt.0) xj=xj+boxxsize
3314           yj=mod(yj,boxysize)
3315           if (yj.lt.0) yj=yj+boxysize
3316           zj=mod(zj,boxzsize)
3317           if (zj.lt.0) zj=zj+boxzsize
3318           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3319       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3320       xj_safe=xj
3321       yj_safe=yj
3322       zj_safe=zj
3323       isubchap=0
3324       do xshift=-1,1
3325       do yshift=-1,1
3326       do zshift=-1,1
3327           xj=xj_safe+xshift*boxxsize
3328           yj=yj_safe+yshift*boxysize
3329           zj=zj_safe+zshift*boxzsize
3330           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3331           if(dist_temp.lt.dist_init) then
3332             dist_init=dist_temp
3333             xj_temp=xj
3334             yj_temp=yj
3335             zj_temp=zj
3336             isubchap=1
3337           endif
3338        enddo
3339        enddo
3340        enddo
3341        if (isubchap.eq.1) then
3342           xj=xj_temp-xmedi
3343           yj=yj_temp-ymedi
3344           zj=zj_temp-zmedi
3345        else
3346           xj=xj_safe-xmedi
3347           yj=yj_safe-ymedi
3348           zj=zj_safe-zmedi
3349        endif
3350 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3351 c  174   continue
3352 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3353 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3354 C Condition for being inside the proper box
3355 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3356 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3357 c        go to 174
3358 c        endif
3359 c  175   continue
3360 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3361 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3362 C Condition for being inside the proper box
3363 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3364 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3365 c        go to 175
3366 c        endif
3367 c  176   continue
3368 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3369 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3370 C Condition for being inside the proper box
3371 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3372 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3373 c        go to 176
3374 c        endif
3375 C        endif !endPBC condintion
3376 C        xj=xj-xmedi
3377 C        yj=yj-ymedi
3378 C        zj=zj-zmedi
3379           rij=xj*xj+yj*yj+zj*zj
3380
3381             sss=sscale(sqrt(rij))
3382             sssgrad=sscagrad(sqrt(rij))
3383 c            if (sss.gt.0.0d0) then
3384           rrmij=1.0D0/rij
3385           rij=dsqrt(rij)
3386           rmij=1.0D0/rij
3387           r3ij=rrmij*rmij
3388           r6ij=r3ij*r3ij
3389           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3390           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3391           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3392           fac=cosa-3.0D0*cosb*cosg
3393           ev1=aaa*r6ij*r6ij
3394 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3395           if (j.eq.i+2) ev1=scal_el*ev1
3396           ev2=bbb*r6ij
3397           fac3=ael6i*r6ij
3398           fac4=ael3i*r3ij
3399           evdwij=(ev1+ev2)
3400           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3401           el2=fac4*fac
3402 C MARYSIA
3403           eesij=(el1+el2)
3404 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3405           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3406           ees=ees+eesij
3407           evdw1=evdw1+evdwij*sss
3408 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3409 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3410 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3411 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3412
3413           if (energy_dec) then
3414               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3415      &'evdw1',i,j,evdwij
3416      &,iteli,itelj,aaa,evdw1
3417               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3418           endif
3419
3420 C
3421 C Calculate contributions to the Cartesian gradient.
3422 C
3423 #ifdef SPLITELE
3424           facvdw=-6*rrmij*(ev1+evdwij)*sss
3425           facel=-3*rrmij*(el1+eesij)
3426           fac1=fac
3427           erij(1)=xj*rmij
3428           erij(2)=yj*rmij
3429           erij(3)=zj*rmij
3430 *
3431 * Radial derivatives. First process both termini of the fragment (i,j)
3432 *
3433           ggg(1)=facel*xj
3434           ggg(2)=facel*yj
3435           ggg(3)=facel*zj
3436 c          do k=1,3
3437 c            ghalf=0.5D0*ggg(k)
3438 c            gelc(k,i)=gelc(k,i)+ghalf
3439 c            gelc(k,j)=gelc(k,j)+ghalf
3440 c          enddo
3441 c 9/28/08 AL Gradient compotents will be summed only at the end
3442           do k=1,3
3443             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3444             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3445           enddo
3446 *
3447 * Loop over residues i+1 thru j-1.
3448 *
3449 cgrad          do k=i+1,j-1
3450 cgrad            do l=1,3
3451 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3452 cgrad            enddo
3453 cgrad          enddo
3454           if (sss.gt.0.0) then
3455           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3456           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3457           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3458           else
3459           ggg(1)=0.0
3460           ggg(2)=0.0
3461           ggg(3)=0.0
3462           endif
3463 c          do k=1,3
3464 c            ghalf=0.5D0*ggg(k)
3465 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3466 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3467 c          enddo
3468 c 9/28/08 AL Gradient compotents will be summed only at the end
3469           do k=1,3
3470             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3471             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3472           enddo
3473 *
3474 * Loop over residues i+1 thru j-1.
3475 *
3476 cgrad          do k=i+1,j-1
3477 cgrad            do l=1,3
3478 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3479 cgrad            enddo
3480 cgrad          enddo
3481 #else
3482 C MARYSIA
3483           facvdw=(ev1+evdwij)*sss
3484           facel=(el1+eesij)
3485           fac1=fac
3486           fac=-3*rrmij*(facvdw+facvdw+facel)
3487           erij(1)=xj*rmij
3488           erij(2)=yj*rmij
3489           erij(3)=zj*rmij
3490 *
3491 * Radial derivatives. First process both termini of the fragment (i,j)
3492 *
3493           ggg(1)=fac*xj
3494           ggg(2)=fac*yj
3495           ggg(3)=fac*zj
3496 c          do k=1,3
3497 c            ghalf=0.5D0*ggg(k)
3498 c            gelc(k,i)=gelc(k,i)+ghalf
3499 c            gelc(k,j)=gelc(k,j)+ghalf
3500 c          enddo
3501 c 9/28/08 AL Gradient compotents will be summed only at the end
3502           do k=1,3
3503             gelc_long(k,j)=gelc(k,j)+ggg(k)
3504             gelc_long(k,i)=gelc(k,i)-ggg(k)
3505           enddo
3506 *
3507 * Loop over residues i+1 thru j-1.
3508 *
3509 cgrad          do k=i+1,j-1
3510 cgrad            do l=1,3
3511 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3512 cgrad            enddo
3513 cgrad          enddo
3514 c 9/28/08 AL Gradient compotents will be summed only at the end
3515           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3516           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3517           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3518           do k=1,3
3519             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3520             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3521           enddo
3522 #endif
3523 *
3524 * Angular part
3525 *
3526           ecosa=2.0D0*fac3*fac1+fac4
3527           fac4=-3.0D0*fac4
3528           fac3=-6.0D0*fac3
3529           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3530           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3531           do k=1,3
3532             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3533             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3534           enddo
3535 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3536 cd   &          (dcosg(k),k=1,3)
3537           do k=1,3
3538             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3539           enddo
3540 c          do k=1,3
3541 c            ghalf=0.5D0*ggg(k)
3542 c            gelc(k,i)=gelc(k,i)+ghalf
3543 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3544 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3545 c            gelc(k,j)=gelc(k,j)+ghalf
3546 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3547 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3548 c          enddo
3549 cgrad          do k=i+1,j-1
3550 cgrad            do l=1,3
3551 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3552 cgrad            enddo
3553 cgrad          enddo
3554           do k=1,3
3555             gelc(k,i)=gelc(k,i)
3556      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3557      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3558             gelc(k,j)=gelc(k,j)
3559      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3560      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3561             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3562             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3563           enddo
3564 C MARYSIA
3565 c          endif !sscale
3566           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3567      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3568      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3569 C
3570 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3571 C   energy of a peptide unit is assumed in the form of a second-order
3572 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3573 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3574 C   are computed for EVERY pair of non-contiguous peptide groups.
3575 C
3576
3577           if (j.lt.nres-1) then
3578             j1=j+1
3579             j2=j-1
3580           else
3581             j1=j-1
3582             j2=j-2
3583           endif
3584           kkk=0
3585           lll=0
3586           do k=1,2
3587             do l=1,2
3588               kkk=kkk+1
3589               muij(kkk)=mu(k,i)*mu(l,j)
3590 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3591 #ifdef NEWCORR
3592              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3593 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3594              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3595              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3596 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3597              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3598 #endif
3599             enddo
3600           enddo
3601 cd         write (iout,*) 'EELEC: i',i,' j',j
3602 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3603 cd          write(iout,*) 'muij',muij
3604           ury=scalar(uy(1,i),erij)
3605           urz=scalar(uz(1,i),erij)
3606           vry=scalar(uy(1,j),erij)
3607           vrz=scalar(uz(1,j),erij)
3608           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3609           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3610           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3611           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3612           fac=dsqrt(-ael6i)*r3ij
3613           a22=a22*fac
3614           a23=a23*fac
3615           a32=a32*fac
3616           a33=a33*fac
3617 cd          write (iout,'(4i5,4f10.5)')
3618 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3619 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3620 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3621 cd     &      uy(:,j),uz(:,j)
3622 cd          write (iout,'(4f10.5)')
3623 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3624 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3625 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3626 cd           write (iout,'(9f10.5/)')
3627 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3628 C Derivatives of the elements of A in virtual-bond vectors
3629           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3630           do k=1,3
3631             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3632             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3633             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3634             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3635             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3636             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3637             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3638             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3639             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3640             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3641             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3642             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3643           enddo
3644 C Compute radial contributions to the gradient
3645           facr=-3.0d0*rrmij
3646           a22der=a22*facr
3647           a23der=a23*facr
3648           a32der=a32*facr
3649           a33der=a33*facr
3650           agg(1,1)=a22der*xj
3651           agg(2,1)=a22der*yj
3652           agg(3,1)=a22der*zj
3653           agg(1,2)=a23der*xj
3654           agg(2,2)=a23der*yj
3655           agg(3,2)=a23der*zj
3656           agg(1,3)=a32der*xj
3657           agg(2,3)=a32der*yj
3658           agg(3,3)=a32der*zj
3659           agg(1,4)=a33der*xj
3660           agg(2,4)=a33der*yj
3661           agg(3,4)=a33der*zj
3662 C Add the contributions coming from er
3663           fac3=-3.0d0*fac
3664           do k=1,3
3665             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3666             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3667             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3668             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3669           enddo
3670           do k=1,3
3671 C Derivatives in DC(i)
3672 cgrad            ghalf1=0.5d0*agg(k,1)
3673 cgrad            ghalf2=0.5d0*agg(k,2)
3674 cgrad            ghalf3=0.5d0*agg(k,3)
3675 cgrad            ghalf4=0.5d0*agg(k,4)
3676             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3677      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3678             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3679      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3680             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3681      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3682             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3683      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3684 C Derivatives in DC(i+1)
3685             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3686      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3687             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3688      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3689             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3690      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3691             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3692      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3693 C Derivatives in DC(j)
3694             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3695      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3696             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3697      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3698             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3699      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3700             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3701      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3702 C Derivatives in DC(j+1) or DC(nres-1)
3703             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3704      &      -3.0d0*vryg(k,3)*ury)
3705             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3706      &      -3.0d0*vrzg(k,3)*ury)
3707             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3708      &      -3.0d0*vryg(k,3)*urz)
3709             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3710      &      -3.0d0*vrzg(k,3)*urz)
3711 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3712 cgrad              do l=1,4
3713 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3714 cgrad              enddo
3715 cgrad            endif
3716           enddo
3717           acipa(1,1)=a22
3718           acipa(1,2)=a23
3719           acipa(2,1)=a32
3720           acipa(2,2)=a33
3721           a22=-a22
3722           a23=-a23
3723           do l=1,2
3724             do k=1,3
3725               agg(k,l)=-agg(k,l)
3726               aggi(k,l)=-aggi(k,l)
3727               aggi1(k,l)=-aggi1(k,l)
3728               aggj(k,l)=-aggj(k,l)
3729               aggj1(k,l)=-aggj1(k,l)
3730             enddo
3731           enddo
3732           if (j.lt.nres-1) then
3733             a22=-a22
3734             a32=-a32
3735             do l=1,3,2
3736               do k=1,3
3737                 agg(k,l)=-agg(k,l)
3738                 aggi(k,l)=-aggi(k,l)
3739                 aggi1(k,l)=-aggi1(k,l)
3740                 aggj(k,l)=-aggj(k,l)
3741                 aggj1(k,l)=-aggj1(k,l)
3742               enddo
3743             enddo
3744           else
3745             a22=-a22
3746             a23=-a23
3747             a32=-a32
3748             a33=-a33
3749             do l=1,4
3750               do k=1,3
3751                 agg(k,l)=-agg(k,l)
3752                 aggi(k,l)=-aggi(k,l)
3753                 aggi1(k,l)=-aggi1(k,l)
3754                 aggj(k,l)=-aggj(k,l)
3755                 aggj1(k,l)=-aggj1(k,l)
3756               enddo
3757             enddo
3758           endif
3759           ENDIF ! WCORR
3760           IF (wel_loc.gt.0.0d0) THEN
3761 C Contribution to the local-electrostatic energy coming from the i-j pair
3762           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3763      &     +a33*muij(4)
3764 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3765 c     &                     ' eel_loc_ij',eel_loc_ij
3766 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3767 C Calculate patrial derivative for theta angle
3768 #ifdef NEWCORR
3769          geel_loc_ij=a22*gmuij1(1)
3770      &     +a23*gmuij1(2)
3771      &     +a32*gmuij1(3)
3772      &     +a33*gmuij1(4)
3773 c         write(iout,*) "derivative over thatai"
3774 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3775 c     &   a33*gmuij1(4)
3776          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3777      &      geel_loc_ij*wel_loc
3778 c         write(iout,*) "derivative over thatai-1"
3779 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3780 c     &   a33*gmuij2(4)
3781          geel_loc_ij=
3782      &     a22*gmuij2(1)
3783      &     +a23*gmuij2(2)
3784      &     +a32*gmuij2(3)
3785      &     +a33*gmuij2(4)
3786          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3787      &      geel_loc_ij*wel_loc
3788 c  Derivative over j residue
3789          geel_loc_ji=a22*gmuji1(1)
3790      &     +a23*gmuji1(2)
3791      &     +a32*gmuji1(3)
3792      &     +a33*gmuji1(4)
3793 c         write(iout,*) "derivative over thataj"
3794 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3795 c     &   a33*gmuji1(4)
3796
3797         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3798      &      geel_loc_ji*wel_loc
3799          geel_loc_ji=
3800      &     +a22*gmuji2(1)
3801      &     +a23*gmuji2(2)
3802      &     +a32*gmuji2(3)
3803      &     +a33*gmuji2(4)
3804 c         write(iout,*) "derivative over thataj-1"
3805 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3806 c     &   a33*gmuji2(4)
3807          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3808      &      geel_loc_ji*wel_loc
3809 #endif
3810 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3811
3812           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3813      &            'eelloc',i,j,eel_loc_ij
3814 c           if (eel_loc_ij.ne.0)
3815 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3816 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3817
3818           eel_loc=eel_loc+eel_loc_ij
3819 C Partial derivatives in virtual-bond dihedral angles gamma
3820           if (i.gt.1)
3821      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3822      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3823      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3824           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3825      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3826      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3827 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3828           do l=1,3
3829             ggg(l)=agg(l,1)*muij(1)+
3830      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3831             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3832             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3833 cgrad            ghalf=0.5d0*ggg(l)
3834 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3835 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3836           enddo
3837 cgrad          do k=i+1,j2
3838 cgrad            do l=1,3
3839 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3840 cgrad            enddo
3841 cgrad          enddo
3842 C Remaining derivatives of eello
3843           do l=1,3
3844             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3845      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3846             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3847      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3848             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3849      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3850             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3851      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3852           enddo
3853           ENDIF
3854 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3855 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3856           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3857      &       .and. num_conti.le.maxconts) then
3858 c            write (iout,*) i,j," entered corr"
3859 C
3860 C Calculate the contact function. The ith column of the array JCONT will
3861 C contain the numbers of atoms that make contacts with the atom I (of numbers
3862 C greater than I). The arrays FACONT and GACONT will contain the values of
3863 C the contact function and its derivative.
3864 c           r0ij=1.02D0*rpp(iteli,itelj)
3865 c           r0ij=1.11D0*rpp(iteli,itelj)
3866             r0ij=2.20D0*rpp(iteli,itelj)
3867 c           r0ij=1.55D0*rpp(iteli,itelj)
3868             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3869             if (fcont.gt.0.0D0) then
3870               num_conti=num_conti+1
3871               if (num_conti.gt.maxconts) then
3872                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3873      &                         ' will skip next contacts for this conf.'
3874               else
3875                 jcont_hb(num_conti,i)=j
3876 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3877 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3878                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3879      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3880 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3881 C  terms.
3882                 d_cont(num_conti,i)=rij
3883 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3884 C     --- Electrostatic-interaction matrix ---
3885                 a_chuj(1,1,num_conti,i)=a22
3886                 a_chuj(1,2,num_conti,i)=a23
3887                 a_chuj(2,1,num_conti,i)=a32
3888                 a_chuj(2,2,num_conti,i)=a33
3889 C     --- Gradient of rij
3890                 do kkk=1,3
3891                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3892                 enddo
3893                 kkll=0
3894                 do k=1,2
3895                   do l=1,2
3896                     kkll=kkll+1
3897                     do m=1,3
3898                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3899                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3900                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3901                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3902                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3903                     enddo
3904                   enddo
3905                 enddo
3906                 ENDIF
3907                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3908 C Calculate contact energies
3909                 cosa4=4.0D0*cosa
3910                 wij=cosa-3.0D0*cosb*cosg
3911                 cosbg1=cosb+cosg
3912                 cosbg2=cosb-cosg
3913 c               fac3=dsqrt(-ael6i)/r0ij**3
3914                 fac3=dsqrt(-ael6i)*r3ij
3915 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3916                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3917                 if (ees0tmp.gt.0) then
3918                   ees0pij=dsqrt(ees0tmp)
3919                 else
3920                   ees0pij=0
3921                 endif
3922 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3923                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3924                 if (ees0tmp.gt.0) then
3925                   ees0mij=dsqrt(ees0tmp)
3926                 else
3927                   ees0mij=0
3928                 endif
3929 c               ees0mij=0.0D0
3930                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3931                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3932 C Diagnostics. Comment out or remove after debugging!
3933 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3934 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3935 c               ees0m(num_conti,i)=0.0D0
3936 C End diagnostics.
3937 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3938 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3939 C Angular derivatives of the contact function
3940                 ees0pij1=fac3/ees0pij
3941                 ees0mij1=fac3/ees0mij
3942                 fac3p=-3.0D0*fac3*rrmij
3943                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3944                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3945 c               ees0mij1=0.0D0
3946                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3947                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3948                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3949                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3950                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3951                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3952                 ecosap=ecosa1+ecosa2
3953                 ecosbp=ecosb1+ecosb2
3954                 ecosgp=ecosg1+ecosg2
3955                 ecosam=ecosa1-ecosa2
3956                 ecosbm=ecosb1-ecosb2
3957                 ecosgm=ecosg1-ecosg2
3958 C Diagnostics
3959 c               ecosap=ecosa1
3960 c               ecosbp=ecosb1
3961 c               ecosgp=ecosg1
3962 c               ecosam=0.0D0
3963 c               ecosbm=0.0D0
3964 c               ecosgm=0.0D0
3965 C End diagnostics
3966                 facont_hb(num_conti,i)=fcont
3967                 fprimcont=fprimcont/rij
3968 cd              facont_hb(num_conti,i)=1.0D0
3969 C Following line is for diagnostics.
3970 cd              fprimcont=0.0D0
3971                 do k=1,3
3972                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3973                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3974                 enddo
3975                 do k=1,3
3976                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3977                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3978                 enddo
3979                 gggp(1)=gggp(1)+ees0pijp*xj
3980                 gggp(2)=gggp(2)+ees0pijp*yj
3981                 gggp(3)=gggp(3)+ees0pijp*zj
3982                 gggm(1)=gggm(1)+ees0mijp*xj
3983                 gggm(2)=gggm(2)+ees0mijp*yj
3984                 gggm(3)=gggm(3)+ees0mijp*zj
3985 C Derivatives due to the contact function
3986                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3987                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3988                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3989                 do k=1,3
3990 c
3991 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3992 c          following the change of gradient-summation algorithm.
3993 c
3994 cgrad                  ghalfp=0.5D0*gggp(k)
3995 cgrad                  ghalfm=0.5D0*gggm(k)
3996                   gacontp_hb1(k,num_conti,i)=!ghalfp
3997      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3998      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3999                   gacontp_hb2(k,num_conti,i)=!ghalfp
4000      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4001      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4002                   gacontp_hb3(k,num_conti,i)=gggp(k)
4003                   gacontm_hb1(k,num_conti,i)=!ghalfm
4004      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4005      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4006                   gacontm_hb2(k,num_conti,i)=!ghalfm
4007      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4008      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4009                   gacontm_hb3(k,num_conti,i)=gggm(k)
4010                 enddo
4011 C Diagnostics. Comment out or remove after debugging!
4012 cdiag           do k=1,3
4013 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4014 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4015 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4016 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4017 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4018 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4019 cdiag           enddo
4020               ENDIF ! wcorr
4021               endif  ! num_conti.le.maxconts
4022             endif  ! fcont.gt.0
4023           endif    ! j.gt.i+1
4024           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4025             do k=1,4
4026               do l=1,3
4027                 ghalf=0.5d0*agg(l,k)
4028                 aggi(l,k)=aggi(l,k)+ghalf
4029                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4030                 aggj(l,k)=aggj(l,k)+ghalf
4031               enddo
4032             enddo
4033             if (j.eq.nres-1 .and. i.lt.j-2) then
4034               do k=1,4
4035                 do l=1,3
4036                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4037                 enddo
4038               enddo
4039             endif
4040           endif
4041 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4042       return
4043       end
4044 C-----------------------------------------------------------------------------
4045       subroutine eturn3(i,eello_turn3)
4046 C Third- and fourth-order contributions from turns
4047       implicit real*8 (a-h,o-z)
4048       include 'DIMENSIONS'
4049       include 'COMMON.IOUNITS'
4050       include 'COMMON.GEO'
4051       include 'COMMON.VAR'
4052       include 'COMMON.LOCAL'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.DERIV'
4055       include 'COMMON.INTERACT'
4056       include 'COMMON.CONTACTS'
4057       include 'COMMON.TORSION'
4058       include 'COMMON.VECTORS'
4059       include 'COMMON.FFIELD'
4060       include 'COMMON.CONTROL'
4061       dimension ggg(3)
4062       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4063      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4064      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4065      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4066      &  auxgmat2(2,2),auxgmatt2(2,2)
4067       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4068      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4069       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4070      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4071      &    num_conti,j1,j2
4072       j=i+2
4073 c      write (iout,*) "eturn3",i,j,j1,j2
4074       a_temp(1,1)=a22
4075       a_temp(1,2)=a23
4076       a_temp(2,1)=a32
4077       a_temp(2,2)=a33
4078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4079 C
4080 C               Third-order contributions
4081 C
4082 C                 (i+2)o----(i+3)
4083 C                      | |
4084 C                      | |
4085 C                 (i+1)o----i
4086 C
4087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4088 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4089         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4090 c auxalary matices for theta gradient
4091 c auxalary matrix for i+1 and constant i+2
4092         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4093 c auxalary matrix for i+2 and constant i+1
4094         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4095         call transpose2(auxmat(1,1),auxmat1(1,1))
4096         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4097         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4098         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4099         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4100         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4101         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4102 C Derivatives in theta
4103         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4104      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4105         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4106      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4107
4108         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4109      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4110 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4111 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4112 cd     &    ' eello_turn3_num',4*eello_turn3_num
4113 C Derivatives in gamma(i)
4114         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4115         call transpose2(auxmat2(1,1),auxmat3(1,1))
4116         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4117         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4118 C Derivatives in gamma(i+1)
4119         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4120         call transpose2(auxmat2(1,1),auxmat3(1,1))
4121         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4122         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4123      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4124 C Cartesian derivatives
4125         do l=1,3
4126 c            ghalf1=0.5d0*agg(l,1)
4127 c            ghalf2=0.5d0*agg(l,2)
4128 c            ghalf3=0.5d0*agg(l,3)
4129 c            ghalf4=0.5d0*agg(l,4)
4130           a_temp(1,1)=aggi(l,1)!+ghalf1
4131           a_temp(1,2)=aggi(l,2)!+ghalf2
4132           a_temp(2,1)=aggi(l,3)!+ghalf3
4133           a_temp(2,2)=aggi(l,4)!+ghalf4
4134           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4135           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4136      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4137           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4138           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4139           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4140           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4141           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4142           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4143      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4144           a_temp(1,1)=aggj(l,1)!+ghalf1
4145           a_temp(1,2)=aggj(l,2)!+ghalf2
4146           a_temp(2,1)=aggj(l,3)!+ghalf3
4147           a_temp(2,2)=aggj(l,4)!+ghalf4
4148           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4149           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4150      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4151           a_temp(1,1)=aggj1(l,1)
4152           a_temp(1,2)=aggj1(l,2)
4153           a_temp(2,1)=aggj1(l,3)
4154           a_temp(2,2)=aggj1(l,4)
4155           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4156           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4157      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4158         enddo
4159       return
4160       end
4161 C-------------------------------------------------------------------------------
4162       subroutine eturn4(i,eello_turn4)
4163 C Third- and fourth-order contributions from turns
4164       implicit real*8 (a-h,o-z)
4165       include 'DIMENSIONS'
4166       include 'COMMON.IOUNITS'
4167       include 'COMMON.GEO'
4168       include 'COMMON.VAR'
4169       include 'COMMON.LOCAL'
4170       include 'COMMON.CHAIN'
4171       include 'COMMON.DERIV'
4172       include 'COMMON.INTERACT'
4173       include 'COMMON.CONTACTS'
4174       include 'COMMON.TORSION'
4175       include 'COMMON.VECTORS'
4176       include 'COMMON.FFIELD'
4177       include 'COMMON.CONTROL'
4178       dimension ggg(3)
4179       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4180      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4181      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4182      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4183      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4184      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4185      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4186       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4187      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4188       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4189      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4190      &    num_conti,j1,j2
4191       j=i+3
4192 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4193 C
4194 C               Fourth-order contributions
4195 C
4196 C                 (i+3)o----(i+4)
4197 C                     /  |
4198 C               (i+2)o   |
4199 C                     \  |
4200 C                 (i+1)o----i
4201 C
4202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4203 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4204 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4205 c        write(iout,*)"WCHODZE W PROGRAM"
4206         a_temp(1,1)=a22
4207         a_temp(1,2)=a23
4208         a_temp(2,1)=a32
4209         a_temp(2,2)=a33
4210         iti1=itortyp(itype(i+1))
4211         iti2=itortyp(itype(i+2))
4212         iti3=itortyp(itype(i+3))
4213 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4214         call transpose2(EUg(1,1,i+1),e1t(1,1))
4215         call transpose2(Eug(1,1,i+2),e2t(1,1))
4216         call transpose2(Eug(1,1,i+3),e3t(1,1))
4217 C Ematrix derivative in theta
4218         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4219         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4220         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4221         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4222 c       eta1 in derivative theta
4223         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4224         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4225 c       auxgvec is derivative of Ub2 so i+3 theta
4226         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4227 c       auxalary matrix of E i+1
4228         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4229 c        s1=0.0
4230 c        gs1=0.0
4231         s1=scalar2(b1(1,i+2),auxvec(1))
4232 c derivative of theta i+2 with constant i+3
4233         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4234 c derivative of theta i+2 with constant i+2
4235         gs32=scalar2(b1(1,i+2),auxgvec(1))
4236 c derivative of E matix in theta of i+1
4237         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4238
4239         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4240 c       ea31 in derivative theta
4241         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4242         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4243 c auxilary matrix auxgvec of Ub2 with constant E matirx
4244         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4245 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4246         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4247
4248 c        s2=0.0
4249 c        gs2=0.0
4250         s2=scalar2(b1(1,i+1),auxvec(1))
4251 c derivative of theta i+1 with constant i+3
4252         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4253 c derivative of theta i+2 with constant i+1
4254         gs21=scalar2(b1(1,i+1),auxgvec(1))
4255 c derivative of theta i+3 with constant i+1
4256         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4257 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4258 c     &  gtb1(1,i+1)
4259         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4260 c two derivatives over diffetent matrices
4261 c gtae3e2 is derivative over i+3
4262         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4263 c ae3gte2 is derivative over i+2
4264         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4265         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4266 c three possible derivative over theta E matices
4267 c i+1
4268         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4269 c i+2
4270         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4271 c i+3
4272         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4273         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4274
4275         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4276         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4277         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4278
4279         eello_turn4=eello_turn4-(s1+s2+s3)
4280 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4281         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4282      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4283 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4284 cd     &    ' eello_turn4_num',8*eello_turn4_num
4285 #ifdef NEWCORR
4286         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4287      &                  -(gs13+gsE13+gsEE1)*wturn4
4288         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4289      &                    -(gs23+gs21+gsEE2)*wturn4
4290         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4291      &                    -(gs32+gsE31+gsEE3)*wturn4
4292 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4293 c     &   gs2
4294 #endif
4295         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4296      &      'eturn4',i,j,-(s1+s2+s3)
4297 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4298 c     &    ' eello_turn4_num',8*eello_turn4_num
4299 C Derivatives in gamma(i)
4300         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4301         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4302         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4303         s1=scalar2(b1(1,i+2),auxvec(1))
4304         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4305         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4306         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4307 C Derivatives in gamma(i+1)
4308         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4309         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4310         s2=scalar2(b1(1,i+1),auxvec(1))
4311         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4312         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4313         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4314         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4315 C Derivatives in gamma(i+2)
4316         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4317         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4318         s1=scalar2(b1(1,i+2),auxvec(1))
4319         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4320         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4321         s2=scalar2(b1(1,i+1),auxvec(1))
4322         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4323         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4324         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4325         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4326 C Cartesian derivatives
4327 C Derivatives of this turn contributions in DC(i+2)
4328         if (j.lt.nres-1) then
4329           do l=1,3
4330             a_temp(1,1)=agg(l,1)
4331             a_temp(1,2)=agg(l,2)
4332             a_temp(2,1)=agg(l,3)
4333             a_temp(2,2)=agg(l,4)
4334             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4335             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4336             s1=scalar2(b1(1,i+2),auxvec(1))
4337             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4338             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4339             s2=scalar2(b1(1,i+1),auxvec(1))
4340             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4341             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4342             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4343             ggg(l)=-(s1+s2+s3)
4344             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4345           enddo
4346         endif
4347 C Remaining derivatives of this turn contribution
4348         do l=1,3
4349           a_temp(1,1)=aggi(l,1)
4350           a_temp(1,2)=aggi(l,2)
4351           a_temp(2,1)=aggi(l,3)
4352           a_temp(2,2)=aggi(l,4)
4353           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4354           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4355           s1=scalar2(b1(1,i+2),auxvec(1))
4356           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4357           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4358           s2=scalar2(b1(1,i+1),auxvec(1))
4359           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4360           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4361           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4362           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4363           a_temp(1,1)=aggi1(l,1)
4364           a_temp(1,2)=aggi1(l,2)
4365           a_temp(2,1)=aggi1(l,3)
4366           a_temp(2,2)=aggi1(l,4)
4367           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4368           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4369           s1=scalar2(b1(1,i+2),auxvec(1))
4370           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4371           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4372           s2=scalar2(b1(1,i+1),auxvec(1))
4373           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4374           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4375           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4376           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4377           a_temp(1,1)=aggj(l,1)
4378           a_temp(1,2)=aggj(l,2)
4379           a_temp(2,1)=aggj(l,3)
4380           a_temp(2,2)=aggj(l,4)
4381           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4382           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4383           s1=scalar2(b1(1,i+2),auxvec(1))
4384           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4385           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4386           s2=scalar2(b1(1,i+1),auxvec(1))
4387           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4388           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4389           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4390           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4391           a_temp(1,1)=aggj1(l,1)
4392           a_temp(1,2)=aggj1(l,2)
4393           a_temp(2,1)=aggj1(l,3)
4394           a_temp(2,2)=aggj1(l,4)
4395           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4396           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4397           s1=scalar2(b1(1,i+2),auxvec(1))
4398           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4399           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4400           s2=scalar2(b1(1,i+1),auxvec(1))
4401           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4402           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4403           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4404 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4405           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4406         enddo
4407       return
4408       end
4409 C-----------------------------------------------------------------------------
4410       subroutine vecpr(u,v,w)
4411       implicit real*8(a-h,o-z)
4412       dimension u(3),v(3),w(3)
4413       w(1)=u(2)*v(3)-u(3)*v(2)
4414       w(2)=-u(1)*v(3)+u(3)*v(1)
4415       w(3)=u(1)*v(2)-u(2)*v(1)
4416       return
4417       end
4418 C-----------------------------------------------------------------------------
4419       subroutine unormderiv(u,ugrad,unorm,ungrad)
4420 C This subroutine computes the derivatives of a normalized vector u, given
4421 C the derivatives computed without normalization conditions, ugrad. Returns
4422 C ungrad.
4423       implicit none
4424       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4425       double precision vec(3)
4426       double precision scalar
4427       integer i,j
4428 c      write (2,*) 'ugrad',ugrad
4429 c      write (2,*) 'u',u
4430       do i=1,3
4431         vec(i)=scalar(ugrad(1,i),u(1))
4432       enddo
4433 c      write (2,*) 'vec',vec
4434       do i=1,3
4435         do j=1,3
4436           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4437         enddo
4438       enddo
4439 c      write (2,*) 'ungrad',ungrad
4440       return
4441       end
4442 C-----------------------------------------------------------------------------
4443       subroutine escp_soft_sphere(evdw2,evdw2_14)
4444 C
4445 C This subroutine calculates the excluded-volume interaction energy between
4446 C peptide-group centers and side chains and its gradient in virtual-bond and
4447 C side-chain vectors.
4448 C
4449       implicit real*8 (a-h,o-z)
4450       include 'DIMENSIONS'
4451       include 'COMMON.GEO'
4452       include 'COMMON.VAR'
4453       include 'COMMON.LOCAL'
4454       include 'COMMON.CHAIN'
4455       include 'COMMON.DERIV'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.FFIELD'
4458       include 'COMMON.IOUNITS'
4459       include 'COMMON.CONTROL'
4460       dimension ggg(3)
4461       evdw2=0.0D0
4462       evdw2_14=0.0d0
4463       r0_scp=4.5d0
4464 cd    print '(a)','Enter ESCP'
4465 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4466 C      do xshift=-1,1
4467 C      do yshift=-1,1
4468 C      do zshift=-1,1
4469       do i=iatscp_s,iatscp_e
4470         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4471         iteli=itel(i)
4472         xi=0.5D0*(c(1,i)+c(1,i+1))
4473         yi=0.5D0*(c(2,i)+c(2,i+1))
4474         zi=0.5D0*(c(3,i)+c(3,i+1))
4475 C Return atom into box, boxxsize is size of box in x dimension
4476 c  134   continue
4477 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4478 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4479 C Condition for being inside the proper box
4480 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4481 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4482 c        go to 134
4483 c        endif
4484 c  135   continue
4485 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4486 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4487 C Condition for being inside the proper box
4488 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4489 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4490 c        go to 135
4491 c c       endif
4492 c  136   continue
4493 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4494 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4495 cC Condition for being inside the proper box
4496 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4497 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4498 c        go to 136
4499 c        endif
4500           xi=mod(xi,boxxsize)
4501           if (xi.lt.0) xi=xi+boxxsize
4502           yi=mod(yi,boxysize)
4503           if (yi.lt.0) yi=yi+boxysize
4504           zi=mod(zi,boxzsize)
4505           if (zi.lt.0) zi=zi+boxzsize
4506 C          xi=xi+xshift*boxxsize
4507 C          yi=yi+yshift*boxysize
4508 C          zi=zi+zshift*boxzsize
4509         do iint=1,nscp_gr(i)
4510
4511         do j=iscpstart(i,iint),iscpend(i,iint)
4512           if (itype(j).eq.ntyp1) cycle
4513           itypj=iabs(itype(j))
4514 C Uncomment following three lines for SC-p interactions
4515 c         xj=c(1,nres+j)-xi
4516 c         yj=c(2,nres+j)-yi
4517 c         zj=c(3,nres+j)-zi
4518 C Uncomment following three lines for Ca-p interactions
4519           xj=c(1,j)
4520           yj=c(2,j)
4521           zj=c(3,j)
4522 c  174   continue
4523 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4524 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4525 C Condition for being inside the proper box
4526 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4527 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4528 c        go to 174
4529 c        endif
4530 c  175   continue
4531 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4532 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4533 cC Condition for being inside the proper box
4534 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4535 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4536 c        go to 175
4537 c        endif
4538 c  176   continue
4539 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4540 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4541 C Condition for being inside the proper box
4542 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4543 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4544 c        go to 176
4545           xj=mod(xj,boxxsize)
4546           if (xj.lt.0) xj=xj+boxxsize
4547           yj=mod(yj,boxysize)
4548           if (yj.lt.0) yj=yj+boxysize
4549           zj=mod(zj,boxzsize)
4550           if (zj.lt.0) zj=zj+boxzsize
4551       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4552       xj_safe=xj
4553       yj_safe=yj
4554       zj_safe=zj
4555       subchap=0
4556       do xshift=-1,1
4557       do yshift=-1,1
4558       do zshift=-1,1
4559           xj=xj_safe+xshift*boxxsize
4560           yj=yj_safe+yshift*boxysize
4561           zj=zj_safe+zshift*boxzsize
4562           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4563           if(dist_temp.lt.dist_init) then
4564             dist_init=dist_temp
4565             xj_temp=xj
4566             yj_temp=yj
4567             zj_temp=zj
4568             subchap=1
4569           endif
4570        enddo
4571        enddo
4572        enddo
4573        if (subchap.eq.1) then
4574           xj=xj_temp-xi
4575           yj=yj_temp-yi
4576           zj=zj_temp-zi
4577        else
4578           xj=xj_safe-xi
4579           yj=yj_safe-yi
4580           zj=zj_safe-zi
4581        endif
4582 c c       endif
4583 C          xj=xj-xi
4584 C          yj=yj-yi
4585 C          zj=zj-zi
4586           rij=xj*xj+yj*yj+zj*zj
4587
4588           r0ij=r0_scp
4589           r0ijsq=r0ij*r0ij
4590           if (rij.lt.r0ijsq) then
4591             evdwij=0.25d0*(rij-r0ijsq)**2
4592             fac=rij-r0ijsq
4593           else
4594             evdwij=0.0d0
4595             fac=0.0d0
4596           endif
4597           evdw2=evdw2+evdwij
4598 C
4599 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4600 C
4601           ggg(1)=xj*fac
4602           ggg(2)=yj*fac
4603           ggg(3)=zj*fac
4604 cgrad          if (j.lt.i) then
4605 cd          write (iout,*) 'j<i'
4606 C Uncomment following three lines for SC-p interactions
4607 c           do k=1,3
4608 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4609 c           enddo
4610 cgrad          else
4611 cd          write (iout,*) 'j>i'
4612 cgrad            do k=1,3
4613 cgrad              ggg(k)=-ggg(k)
4614 C Uncomment following line for SC-p interactions
4615 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4616 cgrad            enddo
4617 cgrad          endif
4618 cgrad          do k=1,3
4619 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4620 cgrad          enddo
4621 cgrad          kstart=min0(i+1,j)
4622 cgrad          kend=max0(i-1,j-1)
4623 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4624 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4625 cgrad          do k=kstart,kend
4626 cgrad            do l=1,3
4627 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4628 cgrad            enddo
4629 cgrad          enddo
4630           do k=1,3
4631             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4632             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4633           enddo
4634         enddo
4635
4636         enddo ! iint
4637       enddo ! i
4638 C      enddo !zshift
4639 C      enddo !yshift
4640 C      enddo !xshift
4641       return
4642       end
4643 C-----------------------------------------------------------------------------
4644       subroutine escp(evdw2,evdw2_14)
4645 C
4646 C This subroutine calculates the excluded-volume interaction energy between
4647 C peptide-group centers and side chains and its gradient in virtual-bond and
4648 C side-chain vectors.
4649 C
4650       implicit real*8 (a-h,o-z)
4651       include 'DIMENSIONS'
4652       include 'COMMON.GEO'
4653       include 'COMMON.VAR'
4654       include 'COMMON.LOCAL'
4655       include 'COMMON.CHAIN'
4656       include 'COMMON.DERIV'
4657       include 'COMMON.INTERACT'
4658       include 'COMMON.FFIELD'
4659       include 'COMMON.IOUNITS'
4660       include 'COMMON.CONTROL'
4661       include 'COMMON.SPLITELE'
4662       dimension ggg(3)
4663       evdw2=0.0D0
4664       evdw2_14=0.0d0
4665 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4666 cd    print '(a)','Enter ESCP'
4667 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4668 C      do xshift=-1,1
4669 C      do yshift=-1,1
4670 C      do zshift=-1,1
4671       do i=iatscp_s,iatscp_e
4672         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4673         iteli=itel(i)
4674         xi=0.5D0*(c(1,i)+c(1,i+1))
4675         yi=0.5D0*(c(2,i)+c(2,i+1))
4676         zi=0.5D0*(c(3,i)+c(3,i+1))
4677           xi=mod(xi,boxxsize)
4678           if (xi.lt.0) xi=xi+boxxsize
4679           yi=mod(yi,boxysize)
4680           if (yi.lt.0) yi=yi+boxysize
4681           zi=mod(zi,boxzsize)
4682           if (zi.lt.0) zi=zi+boxzsize
4683 c          xi=xi+xshift*boxxsize
4684 c          yi=yi+yshift*boxysize
4685 c          zi=zi+zshift*boxzsize
4686 c        print *,xi,yi,zi,'polozenie i'
4687 C Return atom into box, boxxsize is size of box in x dimension
4688 c  134   continue
4689 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4690 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4691 C Condition for being inside the proper box
4692 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4693 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4694 c        go to 134
4695 c        endif
4696 c  135   continue
4697 c          print *,xi,boxxsize,"pierwszy"
4698
4699 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4700 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4701 C Condition for being inside the proper box
4702 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4703 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4704 c        go to 135
4705 c        endif
4706 c  136   continue
4707 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4708 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4709 C Condition for being inside the proper box
4710 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4711 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4712 c        go to 136
4713 c        endif
4714         do iint=1,nscp_gr(i)
4715
4716         do j=iscpstart(i,iint),iscpend(i,iint)
4717           itypj=iabs(itype(j))
4718           if (itypj.eq.ntyp1) cycle
4719 C Uncomment following three lines for SC-p interactions
4720 c         xj=c(1,nres+j)-xi
4721 c         yj=c(2,nres+j)-yi
4722 c         zj=c(3,nres+j)-zi
4723 C Uncomment following three lines for Ca-p interactions
4724           xj=c(1,j)
4725           yj=c(2,j)
4726           zj=c(3,j)
4727           xj=mod(xj,boxxsize)
4728           if (xj.lt.0) xj=xj+boxxsize
4729           yj=mod(yj,boxysize)
4730           if (yj.lt.0) yj=yj+boxysize
4731           zj=mod(zj,boxzsize)
4732           if (zj.lt.0) zj=zj+boxzsize
4733 c  174   continue
4734 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4735 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4736 C Condition for being inside the proper box
4737 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4738 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4739 c        go to 174
4740 c        endif
4741 c  175   continue
4742 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4743 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4744 cC Condition for being inside the proper box
4745 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4746 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4747 c        go to 175
4748 c        endif
4749 c  176   continue
4750 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4751 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4752 C Condition for being inside the proper box
4753 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4754 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4755 c        go to 176
4756 c        endif
4757 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4758       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4759       xj_safe=xj
4760       yj_safe=yj
4761       zj_safe=zj
4762       subchap=0
4763       do xshift=-1,1
4764       do yshift=-1,1
4765       do zshift=-1,1
4766           xj=xj_safe+xshift*boxxsize
4767           yj=yj_safe+yshift*boxysize
4768           zj=zj_safe+zshift*boxzsize
4769           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4770           if(dist_temp.lt.dist_init) then
4771             dist_init=dist_temp
4772             xj_temp=xj
4773             yj_temp=yj
4774             zj_temp=zj
4775             subchap=1
4776           endif
4777        enddo
4778        enddo
4779        enddo
4780        if (subchap.eq.1) then
4781           xj=xj_temp-xi
4782           yj=yj_temp-yi
4783           zj=zj_temp-zi
4784        else
4785           xj=xj_safe-xi
4786           yj=yj_safe-yi
4787           zj=zj_safe-zi
4788        endif
4789 c          print *,xj,yj,zj,'polozenie j'
4790           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4791 c          print *,rrij
4792           sss=sscale(1.0d0/(dsqrt(rrij)))
4793 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4794 c          if (sss.eq.0) print *,'czasem jest OK'
4795           if (sss.le.0.0d0) cycle
4796           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4797           fac=rrij**expon2
4798           e1=fac*fac*aad(itypj,iteli)
4799           e2=fac*bad(itypj,iteli)
4800           if (iabs(j-i) .le. 2) then
4801             e1=scal14*e1
4802             e2=scal14*e2
4803             evdw2_14=evdw2_14+(e1+e2)*sss
4804           endif
4805           evdwij=e1+e2
4806           evdw2=evdw2+evdwij*sss
4807           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4808      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4809      &       bad(itypj,iteli)
4810 C
4811 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4812 C
4813           fac=-(evdwij+e1)*rrij*sss
4814           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4815           ggg(1)=xj*fac
4816           ggg(2)=yj*fac
4817           ggg(3)=zj*fac
4818 cgrad          if (j.lt.i) then
4819 cd          write (iout,*) 'j<i'
4820 C Uncomment following three lines for SC-p interactions
4821 c           do k=1,3
4822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4823 c           enddo
4824 cgrad          else
4825 cd          write (iout,*) 'j>i'
4826 cgrad            do k=1,3
4827 cgrad              ggg(k)=-ggg(k)
4828 C Uncomment following line for SC-p interactions
4829 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4830 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4831 cgrad            enddo
4832 cgrad          endif
4833 cgrad          do k=1,3
4834 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4835 cgrad          enddo
4836 cgrad          kstart=min0(i+1,j)
4837 cgrad          kend=max0(i-1,j-1)
4838 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4839 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4840 cgrad          do k=kstart,kend
4841 cgrad            do l=1,3
4842 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4843 cgrad            enddo
4844 cgrad          enddo
4845           do k=1,3
4846             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4847             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4848           enddo
4849 c        endif !endif for sscale cutoff
4850         enddo ! j
4851
4852         enddo ! iint
4853       enddo ! i
4854 c      enddo !zshift
4855 c      enddo !yshift
4856 c      enddo !xshift
4857       do i=1,nct
4858         do j=1,3
4859           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4860           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4861           gradx_scp(j,i)=expon*gradx_scp(j,i)
4862         enddo
4863       enddo
4864 C******************************************************************************
4865 C
4866 C                              N O T E !!!
4867 C
4868 C To save time the factor EXPON has been extracted from ALL components
4869 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4870 C use!
4871 C
4872 C******************************************************************************
4873       return
4874       end
4875 C--------------------------------------------------------------------------
4876       subroutine edis(ehpb)
4877 C
4878 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4879 C
4880       implicit real*8 (a-h,o-z)
4881       include 'DIMENSIONS'
4882       include 'COMMON.SBRIDGE'
4883       include 'COMMON.CHAIN'
4884       include 'COMMON.DERIV'
4885       include 'COMMON.VAR'
4886       include 'COMMON.INTERACT'
4887       include 'COMMON.IOUNITS'
4888       dimension ggg(3)
4889       ehpb=0.0D0
4890 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4891 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4892       if (link_end.eq.0) return
4893       do i=link_start,link_end
4894 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4895 C CA-CA distance used in regularization of structure.
4896         ii=ihpb(i)
4897         jj=jhpb(i)
4898 C iii and jjj point to the residues for which the distance is assigned.
4899         if (ii.gt.nres) then
4900           iii=ii-nres
4901           jjj=jj-nres
4902         else
4903           iii=ii
4904           jjj=jj
4905         endif
4906 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4907 c     &    dhpb(i),dhpb1(i),forcon(i)
4908 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4909 C    distance and angle dependent SS bond potential.
4910         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4911      & iabs(itype(jjj)).eq.1) then
4912 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4913 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4914         if (.not.dyn_ss .and. i.le.nss) then
4915 C 15/02/13 CC dynamic SSbond - additional check
4916          if (ii.gt.nres
4917      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4918           call ssbond_ene(iii,jjj,eij)
4919           ehpb=ehpb+2*eij
4920          endif
4921 cd          write (iout,*) "eij",eij
4922         else
4923 C Calculate the distance between the two points and its difference from the
4924 C target distance.
4925           dd=dist(ii,jj)
4926             rdis=dd-dhpb(i)
4927 C Get the force constant corresponding to this distance.
4928             waga=forcon(i)
4929 C Calculate the contribution to energy.
4930             ehpb=ehpb+waga*rdis*rdis
4931 C
4932 C Evaluate gradient.
4933 C
4934             fac=waga*rdis/dd
4935 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4936 cd   &   ' waga=',waga,' fac=',fac
4937             do j=1,3
4938               ggg(j)=fac*(c(j,jj)-c(j,ii))
4939             enddo
4940 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4941 C If this is a SC-SC distance, we need to calculate the contributions to the
4942 C Cartesian gradient in the SC vectors (ghpbx).
4943           if (iii.lt.ii) then
4944           do j=1,3
4945             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4946             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4947           enddo
4948           endif
4949 cgrad        do j=iii,jjj-1
4950 cgrad          do k=1,3
4951 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4952 cgrad          enddo
4953 cgrad        enddo
4954           do k=1,3
4955             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4956             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4957           enddo
4958         endif
4959        endif
4960       enddo
4961       ehpb=0.5D0*ehpb
4962       return
4963       end
4964 C--------------------------------------------------------------------------
4965       subroutine ssbond_ene(i,j,eij)
4966 C
4967 C Calculate the distance and angle dependent SS-bond potential energy
4968 C using a free-energy function derived based on RHF/6-31G** ab initio
4969 C calculations of diethyl disulfide.
4970 C
4971 C A. Liwo and U. Kozlowska, 11/24/03
4972 C
4973       implicit real*8 (a-h,o-z)
4974       include 'DIMENSIONS'
4975       include 'COMMON.SBRIDGE'
4976       include 'COMMON.CHAIN'
4977       include 'COMMON.DERIV'
4978       include 'COMMON.LOCAL'
4979       include 'COMMON.INTERACT'
4980       include 'COMMON.VAR'
4981       include 'COMMON.IOUNITS'
4982       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4983       itypi=iabs(itype(i))
4984       xi=c(1,nres+i)
4985       yi=c(2,nres+i)
4986       zi=c(3,nres+i)
4987       dxi=dc_norm(1,nres+i)
4988       dyi=dc_norm(2,nres+i)
4989       dzi=dc_norm(3,nres+i)
4990 c      dsci_inv=dsc_inv(itypi)
4991       dsci_inv=vbld_inv(nres+i)
4992       itypj=iabs(itype(j))
4993 c      dscj_inv=dsc_inv(itypj)
4994       dscj_inv=vbld_inv(nres+j)
4995       xj=c(1,nres+j)-xi
4996       yj=c(2,nres+j)-yi
4997       zj=c(3,nres+j)-zi
4998       dxj=dc_norm(1,nres+j)
4999       dyj=dc_norm(2,nres+j)
5000       dzj=dc_norm(3,nres+j)
5001       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5002       rij=dsqrt(rrij)
5003       erij(1)=xj*rij
5004       erij(2)=yj*rij
5005       erij(3)=zj*rij
5006       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5007       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5008       om12=dxi*dxj+dyi*dyj+dzi*dzj
5009       do k=1,3
5010         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5011         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5012       enddo
5013       rij=1.0d0/rij
5014       deltad=rij-d0cm
5015       deltat1=1.0d0-om1
5016       deltat2=1.0d0+om2
5017       deltat12=om2-om1+2.0d0
5018       cosphi=om12-om1*om2
5019       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5020      &  +akct*deltad*deltat12
5021      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5022 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5023 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5024 c     &  " deltat12",deltat12," eij",eij
5025       ed=2*akcm*deltad+akct*deltat12
5026       pom1=akct*deltad
5027       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5028       eom1=-2*akth*deltat1-pom1-om2*pom2
5029       eom2= 2*akth*deltat2+pom1-om1*pom2
5030       eom12=pom2
5031       do k=1,3
5032         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5033         ghpbx(k,i)=ghpbx(k,i)-ggk
5034      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5035      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5036         ghpbx(k,j)=ghpbx(k,j)+ggk
5037      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5038      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5039         ghpbc(k,i)=ghpbc(k,i)-ggk
5040         ghpbc(k,j)=ghpbc(k,j)+ggk
5041       enddo
5042 C
5043 C Calculate the components of the gradient in DC and X
5044 C
5045 cgrad      do k=i,j-1
5046 cgrad        do l=1,3
5047 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5048 cgrad        enddo
5049 cgrad      enddo
5050       return
5051       end
5052 C--------------------------------------------------------------------------
5053       subroutine ebond(estr)
5054 c
5055 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5056 c
5057       implicit real*8 (a-h,o-z)
5058       include 'DIMENSIONS'
5059       include 'COMMON.LOCAL'
5060       include 'COMMON.GEO'
5061       include 'COMMON.INTERACT'
5062       include 'COMMON.DERIV'
5063       include 'COMMON.VAR'
5064       include 'COMMON.CHAIN'
5065       include 'COMMON.IOUNITS'
5066       include 'COMMON.NAMES'
5067       include 'COMMON.FFIELD'
5068       include 'COMMON.CONTROL'
5069       include 'COMMON.SETUP'
5070       double precision u(3),ud(3)
5071       estr=0.0d0
5072       estr1=0.0d0
5073       do i=ibondp_start,ibondp_end
5074         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5075 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5076 c          do j=1,3
5077 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5078 c     &      *dc(j,i-1)/vbld(i)
5079 c          enddo
5080 c          if (energy_dec) write(iout,*)
5081 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5082 c        else
5083 C       Checking if it involves dummy (NH3+ or COO-) group
5084          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5085 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5086         diff = vbld(i)-vbldpDUM
5087          else
5088 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5089         diff = vbld(i)-vbldp0
5090          endif
5091         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5092      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5093         estr=estr+diff*diff
5094         do j=1,3
5095           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5096         enddo
5097 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5098 c        endif
5099       enddo
5100       estr=0.5d0*AKP*estr+estr1
5101 c
5102 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5103 c
5104       do i=ibond_start,ibond_end
5105         iti=iabs(itype(i))
5106         if (iti.ne.10 .and. iti.ne.ntyp1) then
5107           nbi=nbondterm(iti)
5108           if (nbi.eq.1) then
5109             diff=vbld(i+nres)-vbldsc0(1,iti)
5110             if (energy_dec)  write (iout,*)
5111      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5112      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5113             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5114             do j=1,3
5115               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5116             enddo
5117           else
5118             do j=1,nbi
5119               diff=vbld(i+nres)-vbldsc0(j,iti)
5120               ud(j)=aksc(j,iti)*diff
5121               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5122             enddo
5123             uprod=u(1)
5124             do j=2,nbi
5125               uprod=uprod*u(j)
5126             enddo
5127             usum=0.0d0
5128             usumsqder=0.0d0
5129             do j=1,nbi
5130               uprod1=1.0d0
5131               uprod2=1.0d0
5132               do k=1,nbi
5133                 if (k.ne.j) then
5134                   uprod1=uprod1*u(k)
5135                   uprod2=uprod2*u(k)*u(k)
5136                 endif
5137               enddo
5138               usum=usum+uprod1
5139               usumsqder=usumsqder+ud(j)*uprod2
5140             enddo
5141             estr=estr+uprod/usum
5142             do j=1,3
5143              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5144             enddo
5145           endif
5146         endif
5147       enddo
5148       return
5149       end
5150 #ifdef CRYST_THETA
5151 C--------------------------------------------------------------------------
5152       subroutine ebend(etheta)
5153 C
5154 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5155 C angles gamma and its derivatives in consecutive thetas and gammas.
5156 C
5157       implicit real*8 (a-h,o-z)
5158       include 'DIMENSIONS'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.GEO'
5161       include 'COMMON.INTERACT'
5162       include 'COMMON.DERIV'
5163       include 'COMMON.VAR'
5164       include 'COMMON.CHAIN'
5165       include 'COMMON.IOUNITS'
5166       include 'COMMON.NAMES'
5167       include 'COMMON.FFIELD'
5168       include 'COMMON.CONTROL'
5169       common /calcthet/ term1,term2,termm,diffak,ratak,
5170      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5171      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5172       double precision y(2),z(2)
5173       delta=0.02d0*pi
5174 c      time11=dexp(-2*time)
5175 c      time12=1.0d0
5176       etheta=0.0D0
5177 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5178       do i=ithet_start,ithet_end
5179         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5180      &  .or.itype(i).eq.ntyp1) cycle
5181 C Zero the energy function and its derivative at 0 or pi.
5182         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5183         it=itype(i-1)
5184         ichir1=isign(1,itype(i-2))
5185         ichir2=isign(1,itype(i))
5186          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5187          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5188          if (itype(i-1).eq.10) then
5189           itype1=isign(10,itype(i-2))
5190           ichir11=isign(1,itype(i-2))
5191           ichir12=isign(1,itype(i-2))
5192           itype2=isign(10,itype(i))
5193           ichir21=isign(1,itype(i))
5194           ichir22=isign(1,itype(i))
5195          endif
5196
5197         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5198 #ifdef OSF
5199           phii=phi(i)
5200           if (phii.ne.phii) phii=150.0
5201 #else
5202           phii=phi(i)
5203 #endif
5204           y(1)=dcos(phii)
5205           y(2)=dsin(phii)
5206         else
5207           y(1)=0.0D0
5208           y(2)=0.0D0
5209         endif
5210         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5211 #ifdef OSF
5212           phii1=phi(i+1)
5213           if (phii1.ne.phii1) phii1=150.0
5214           phii1=pinorm(phii1)
5215           z(1)=cos(phii1)
5216 #else
5217           phii1=phi(i+1)
5218 #endif
5219           z(1)=dcos(phii1)
5220           z(2)=dsin(phii1)
5221         else
5222           z(1)=0.0D0
5223           z(2)=0.0D0
5224         endif
5225 C Calculate the "mean" value of theta from the part of the distribution
5226 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5227 C In following comments this theta will be referred to as t_c.
5228         thet_pred_mean=0.0d0
5229         do k=1,2
5230             athetk=athet(k,it,ichir1,ichir2)
5231             bthetk=bthet(k,it,ichir1,ichir2)
5232           if (it.eq.10) then
5233              athetk=athet(k,itype1,ichir11,ichir12)
5234              bthetk=bthet(k,itype2,ichir21,ichir22)
5235           endif
5236          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5237 c         write(iout,*) 'chuj tu', y(k),z(k)
5238         enddo
5239         dthett=thet_pred_mean*ssd
5240         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5241 C Derivatives of the "mean" values in gamma1 and gamma2.
5242         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5243      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5244          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5245      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5246          if (it.eq.10) then
5247       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5248      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5249         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5250      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5251          endif
5252         if (theta(i).gt.pi-delta) then
5253           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5254      &         E_tc0)
5255           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5256           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5257           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5258      &        E_theta)
5259           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5260      &        E_tc)
5261         else if (theta(i).lt.delta) then
5262           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5263           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5264           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5265      &        E_theta)
5266           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5267           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5268      &        E_tc)
5269         else
5270           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5271      &        E_theta,E_tc)
5272         endif
5273         etheta=etheta+ethetai
5274         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5275      &      'ebend',i,ethetai,theta(i),itype(i)
5276         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5277         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5278         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5279       enddo
5280 C Ufff.... We've done all this!!!
5281       return
5282       end
5283 C---------------------------------------------------------------------------
5284       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5285      &     E_tc)
5286       implicit real*8 (a-h,o-z)
5287       include 'DIMENSIONS'
5288       include 'COMMON.LOCAL'
5289       include 'COMMON.IOUNITS'
5290       common /calcthet/ term1,term2,termm,diffak,ratak,
5291      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5292      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5293 C Calculate the contributions to both Gaussian lobes.
5294 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5295 C The "polynomial part" of the "standard deviation" of this part of
5296 C the distributioni.
5297 ccc        write (iout,*) thetai,thet_pred_mean
5298         sig=polthet(3,it)
5299         do j=2,0,-1
5300           sig=sig*thet_pred_mean+polthet(j,it)
5301         enddo
5302 C Derivative of the "interior part" of the "standard deviation of the"
5303 C gamma-dependent Gaussian lobe in t_c.
5304         sigtc=3*polthet(3,it)
5305         do j=2,1,-1
5306           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5307         enddo
5308         sigtc=sig*sigtc
5309 C Set the parameters of both Gaussian lobes of the distribution.
5310 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5311         fac=sig*sig+sigc0(it)
5312         sigcsq=fac+fac
5313         sigc=1.0D0/sigcsq
5314 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5315         sigsqtc=-4.0D0*sigcsq*sigtc
5316 c       print *,i,sig,sigtc,sigsqtc
5317 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5318         sigtc=-sigtc/(fac*fac)
5319 C Following variable is sigma(t_c)**(-2)
5320         sigcsq=sigcsq*sigcsq
5321         sig0i=sig0(it)
5322         sig0inv=1.0D0/sig0i**2
5323         delthec=thetai-thet_pred_mean
5324         delthe0=thetai-theta0i
5325         term1=-0.5D0*sigcsq*delthec*delthec
5326         term2=-0.5D0*sig0inv*delthe0*delthe0
5327 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5328 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5329 C NaNs in taking the logarithm. We extract the largest exponent which is added
5330 C to the energy (this being the log of the distribution) at the end of energy
5331 C term evaluation for this virtual-bond angle.
5332         if (term1.gt.term2) then
5333           termm=term1
5334           term2=dexp(term2-termm)
5335           term1=1.0d0
5336         else
5337           termm=term2
5338           term1=dexp(term1-termm)
5339           term2=1.0d0
5340         endif
5341 C The ratio between the gamma-independent and gamma-dependent lobes of
5342 C the distribution is a Gaussian function of thet_pred_mean too.
5343         diffak=gthet(2,it)-thet_pred_mean
5344         ratak=diffak/gthet(3,it)**2
5345         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5346 C Let's differentiate it in thet_pred_mean NOW.
5347         aktc=ak*ratak
5348 C Now put together the distribution terms to make complete distribution.
5349         termexp=term1+ak*term2
5350         termpre=sigc+ak*sig0i
5351 C Contribution of the bending energy from this theta is just the -log of
5352 C the sum of the contributions from the two lobes and the pre-exponential
5353 C factor. Simple enough, isn't it?
5354         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5355 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5356 C NOW the derivatives!!!
5357 C 6/6/97 Take into account the deformation.
5358         E_theta=(delthec*sigcsq*term1
5359      &       +ak*delthe0*sig0inv*term2)/termexp
5360         E_tc=((sigtc+aktc*sig0i)/termpre
5361      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5362      &       aktc*term2)/termexp)
5363       return
5364       end
5365 c-----------------------------------------------------------------------------
5366       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5367       implicit real*8 (a-h,o-z)
5368       include 'DIMENSIONS'
5369       include 'COMMON.LOCAL'
5370       include 'COMMON.IOUNITS'
5371       common /calcthet/ term1,term2,termm,diffak,ratak,
5372      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5373      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5374       delthec=thetai-thet_pred_mean
5375       delthe0=thetai-theta0i
5376 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5377       t3 = thetai-thet_pred_mean
5378       t6 = t3**2
5379       t9 = term1
5380       t12 = t3*sigcsq
5381       t14 = t12+t6*sigsqtc
5382       t16 = 1.0d0
5383       t21 = thetai-theta0i
5384       t23 = t21**2
5385       t26 = term2
5386       t27 = t21*t26
5387       t32 = termexp
5388       t40 = t32**2
5389       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5390      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5391      & *(-t12*t9-ak*sig0inv*t27)
5392       return
5393       end
5394 #else
5395 C--------------------------------------------------------------------------
5396       subroutine ebend(etheta)
5397 C
5398 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5399 C angles gamma and its derivatives in consecutive thetas and gammas.
5400 C ab initio-derived potentials from
5401 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5402 C
5403       implicit real*8 (a-h,o-z)
5404       include 'DIMENSIONS'
5405       include 'COMMON.LOCAL'
5406       include 'COMMON.GEO'
5407       include 'COMMON.INTERACT'
5408       include 'COMMON.DERIV'
5409       include 'COMMON.VAR'
5410       include 'COMMON.CHAIN'
5411       include 'COMMON.IOUNITS'
5412       include 'COMMON.NAMES'
5413       include 'COMMON.FFIELD'
5414       include 'COMMON.CONTROL'
5415       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5416      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5417      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5418      & sinph1ph2(maxdouble,maxdouble)
5419       logical lprn /.false./, lprn1 /.false./
5420       etheta=0.0D0
5421       do i=ithet_start,ithet_end
5422 c        print *,i,itype(i-1),itype(i),itype(i-2)
5423         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5424      &  .or.itype(i).eq.ntyp1) cycle
5425 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5426
5427         if (iabs(itype(i+1)).eq.20) iblock=2
5428         if (iabs(itype(i+1)).ne.20) iblock=1
5429         dethetai=0.0d0
5430         dephii=0.0d0
5431         dephii1=0.0d0
5432         theti2=0.5d0*theta(i)
5433         ityp2=ithetyp((itype(i-1)))
5434         do k=1,nntheterm
5435           coskt(k)=dcos(k*theti2)
5436           sinkt(k)=dsin(k*theti2)
5437         enddo
5438         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5439 #ifdef OSF
5440           phii=phi(i)
5441           if (phii.ne.phii) phii=150.0
5442 #else
5443           phii=phi(i)
5444 #endif
5445           ityp1=ithetyp((itype(i-2)))
5446 C propagation of chirality for glycine type
5447           do k=1,nsingle
5448             cosph1(k)=dcos(k*phii)
5449             sinph1(k)=dsin(k*phii)
5450           enddo
5451         else
5452           phii=0.0d0
5453           ityp1=nthetyp+1
5454           do k=1,nsingle
5455             cosph1(k)=0.0d0
5456             sinph1(k)=0.0d0
5457           enddo
5458         endif
5459         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5460 #ifdef OSF
5461           phii1=phi(i+1)
5462           if (phii1.ne.phii1) phii1=150.0
5463           phii1=pinorm(phii1)
5464 #else
5465           phii1=phi(i+1)
5466 #endif
5467           ityp3=ithetyp((itype(i)))
5468           do k=1,nsingle
5469             cosph2(k)=dcos(k*phii1)
5470             sinph2(k)=dsin(k*phii1)
5471           enddo
5472         else
5473           phii1=0.0d0
5474           ityp3=nthetyp+1
5475           do k=1,nsingle
5476             cosph2(k)=0.0d0
5477             sinph2(k)=0.0d0
5478           enddo
5479         endif
5480         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5481         do k=1,ndouble
5482           do l=1,k-1
5483             ccl=cosph1(l)*cosph2(k-l)
5484             ssl=sinph1(l)*sinph2(k-l)
5485             scl=sinph1(l)*cosph2(k-l)
5486             csl=cosph1(l)*sinph2(k-l)
5487             cosph1ph2(l,k)=ccl-ssl
5488             cosph1ph2(k,l)=ccl+ssl
5489             sinph1ph2(l,k)=scl+csl
5490             sinph1ph2(k,l)=scl-csl
5491           enddo
5492         enddo
5493         if (lprn) then
5494         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5495      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5496         write (iout,*) "coskt and sinkt"
5497         do k=1,nntheterm
5498           write (iout,*) k,coskt(k),sinkt(k)
5499         enddo
5500         endif
5501         do k=1,ntheterm
5502           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5503           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5504      &      *coskt(k)
5505           if (lprn)
5506      &    write (iout,*) "k",k,"
5507      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5508      &     " ethetai",ethetai
5509         enddo
5510         if (lprn) then
5511         write (iout,*) "cosph and sinph"
5512         do k=1,nsingle
5513           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5514         enddo
5515         write (iout,*) "cosph1ph2 and sinph2ph2"
5516         do k=2,ndouble
5517           do l=1,k-1
5518             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5519      &         sinph1ph2(l,k),sinph1ph2(k,l)
5520           enddo
5521         enddo
5522         write(iout,*) "ethetai",ethetai
5523         endif
5524         do m=1,ntheterm2
5525           do k=1,nsingle
5526             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5527      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5528      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5529      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5530             ethetai=ethetai+sinkt(m)*aux
5531             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5532             dephii=dephii+k*sinkt(m)*(
5533      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5534      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5535             dephii1=dephii1+k*sinkt(m)*(
5536      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5537      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5538             if (lprn)
5539      &      write (iout,*) "m",m," k",k," bbthet",
5540      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5541      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5542      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5543      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5544           enddo
5545         enddo
5546         if (lprn)
5547      &  write(iout,*) "ethetai",ethetai
5548         do m=1,ntheterm3
5549           do k=2,ndouble
5550             do l=1,k-1
5551               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5552      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5553      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5554      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5555               ethetai=ethetai+sinkt(m)*aux
5556               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5557               dephii=dephii+l*sinkt(m)*(
5558      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5559      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5560      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5561      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5562               dephii1=dephii1+(k-l)*sinkt(m)*(
5563      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5564      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5565      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5566      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5567               if (lprn) then
5568               write (iout,*) "m",m," k",k," l",l," ffthet",
5569      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5570      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5571      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5572      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5573      &            " ethetai",ethetai
5574               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5575      &            cosph1ph2(k,l)*sinkt(m),
5576      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5577               endif
5578             enddo
5579           enddo
5580         enddo
5581 10      continue
5582 c        lprn1=.true.
5583         if (lprn1)
5584      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5585      &   i,theta(i)*rad2deg,phii*rad2deg,
5586      &   phii1*rad2deg,ethetai
5587 c        lprn1=.false.
5588         etheta=etheta+ethetai
5589         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5590         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5591         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5592       enddo
5593       return
5594       end
5595 #endif
5596 #ifdef CRYST_SC
5597 c-----------------------------------------------------------------------------
5598       subroutine esc(escloc)
5599 C Calculate the local energy of a side chain and its derivatives in the
5600 C corresponding virtual-bond valence angles THETA and the spherical angles
5601 C ALPHA and OMEGA.
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'COMMON.GEO'
5605       include 'COMMON.LOCAL'
5606       include 'COMMON.VAR'
5607       include 'COMMON.INTERACT'
5608       include 'COMMON.DERIV'
5609       include 'COMMON.CHAIN'
5610       include 'COMMON.IOUNITS'
5611       include 'COMMON.NAMES'
5612       include 'COMMON.FFIELD'
5613       include 'COMMON.CONTROL'
5614       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5615      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5616       common /sccalc/ time11,time12,time112,theti,it,nlobit
5617       delta=0.02d0*pi
5618       escloc=0.0D0
5619 c     write (iout,'(a)') 'ESC'
5620       do i=loc_start,loc_end
5621         it=itype(i)
5622         if (it.eq.ntyp1) cycle
5623         if (it.eq.10) goto 1
5624         nlobit=nlob(iabs(it))
5625 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5626 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5627         theti=theta(i+1)-pipol
5628         x(1)=dtan(theti)
5629         x(2)=alph(i)
5630         x(3)=omeg(i)
5631
5632         if (x(2).gt.pi-delta) then
5633           xtemp(1)=x(1)
5634           xtemp(2)=pi-delta
5635           xtemp(3)=x(3)
5636           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5637           xtemp(2)=pi
5638           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5639           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5640      &        escloci,dersc(2))
5641           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5642      &        ddersc0(1),dersc(1))
5643           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5644      &        ddersc0(3),dersc(3))
5645           xtemp(2)=pi-delta
5646           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5647           xtemp(2)=pi
5648           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5649           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5650      &            dersc0(2),esclocbi,dersc02)
5651           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5652      &            dersc12,dersc01)
5653           call splinthet(x(2),0.5d0*delta,ss,ssd)
5654           dersc0(1)=dersc01
5655           dersc0(2)=dersc02
5656           dersc0(3)=0.0d0
5657           do k=1,3
5658             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5659           enddo
5660           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5661 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5662 c    &             esclocbi,ss,ssd
5663           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5664 c         escloci=esclocbi
5665 c         write (iout,*) escloci
5666         else if (x(2).lt.delta) then
5667           xtemp(1)=x(1)
5668           xtemp(2)=delta
5669           xtemp(3)=x(3)
5670           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5671           xtemp(2)=0.0d0
5672           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5673           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5674      &        escloci,dersc(2))
5675           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5676      &        ddersc0(1),dersc(1))
5677           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5678      &        ddersc0(3),dersc(3))
5679           xtemp(2)=delta
5680           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5681           xtemp(2)=0.0d0
5682           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5683           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5684      &            dersc0(2),esclocbi,dersc02)
5685           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5686      &            dersc12,dersc01)
5687           dersc0(1)=dersc01
5688           dersc0(2)=dersc02
5689           dersc0(3)=0.0d0
5690           call splinthet(x(2),0.5d0*delta,ss,ssd)
5691           do k=1,3
5692             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5693           enddo
5694           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5695 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5696 c    &             esclocbi,ss,ssd
5697           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5698 c         write (iout,*) escloci
5699         else
5700           call enesc(x,escloci,dersc,ddummy,.false.)
5701         endif
5702
5703         escloc=escloc+escloci
5704         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5705      &     'escloc',i,escloci
5706 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5707
5708         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5709      &   wscloc*dersc(1)
5710         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5711         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5712     1   continue
5713       enddo
5714       return
5715       end
5716 C---------------------------------------------------------------------------
5717       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5718       implicit real*8 (a-h,o-z)
5719       include 'DIMENSIONS'
5720       include 'COMMON.GEO'
5721       include 'COMMON.LOCAL'
5722       include 'COMMON.IOUNITS'
5723       common /sccalc/ time11,time12,time112,theti,it,nlobit
5724       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5725       double precision contr(maxlob,-1:1)
5726       logical mixed
5727 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5728         escloc_i=0.0D0
5729         do j=1,3
5730           dersc(j)=0.0D0
5731           if (mixed) ddersc(j)=0.0d0
5732         enddo
5733         x3=x(3)
5734
5735 C Because of periodicity of the dependence of the SC energy in omega we have
5736 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5737 C To avoid underflows, first compute & store the exponents.
5738
5739         do iii=-1,1
5740
5741           x(3)=x3+iii*dwapi
5742
5743           do j=1,nlobit
5744             do k=1,3
5745               z(k)=x(k)-censc(k,j,it)
5746             enddo
5747             do k=1,3
5748               Axk=0.0D0
5749               do l=1,3
5750                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5751               enddo
5752               Ax(k,j,iii)=Axk
5753             enddo
5754             expfac=0.0D0
5755             do k=1,3
5756               expfac=expfac+Ax(k,j,iii)*z(k)
5757             enddo
5758             contr(j,iii)=expfac
5759           enddo ! j
5760
5761         enddo ! iii
5762
5763         x(3)=x3
5764 C As in the case of ebend, we want to avoid underflows in exponentiation and
5765 C subsequent NaNs and INFs in energy calculation.
5766 C Find the largest exponent
5767         emin=contr(1,-1)
5768         do iii=-1,1
5769           do j=1,nlobit
5770             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5771           enddo
5772         enddo
5773         emin=0.5D0*emin
5774 cd      print *,'it=',it,' emin=',emin
5775
5776 C Compute the contribution to SC energy and derivatives
5777         do iii=-1,1
5778
5779           do j=1,nlobit
5780 #ifdef OSF
5781             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5782             if(adexp.ne.adexp) adexp=1.0
5783             expfac=dexp(adexp)
5784 #else
5785             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5786 #endif
5787 cd          print *,'j=',j,' expfac=',expfac
5788             escloc_i=escloc_i+expfac
5789             do k=1,3
5790               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5791             enddo
5792             if (mixed) then
5793               do k=1,3,2
5794                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5795      &            +gaussc(k,2,j,it))*expfac
5796               enddo
5797             endif
5798           enddo
5799
5800         enddo ! iii
5801
5802         dersc(1)=dersc(1)/cos(theti)**2
5803         ddersc(1)=ddersc(1)/cos(theti)**2
5804         ddersc(3)=ddersc(3)
5805
5806         escloci=-(dlog(escloc_i)-emin)
5807         do j=1,3
5808           dersc(j)=dersc(j)/escloc_i
5809         enddo
5810         if (mixed) then
5811           do j=1,3,2
5812             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5813           enddo
5814         endif
5815       return
5816       end
5817 C------------------------------------------------------------------------------
5818       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5819       implicit real*8 (a-h,o-z)
5820       include 'DIMENSIONS'
5821       include 'COMMON.GEO'
5822       include 'COMMON.LOCAL'
5823       include 'COMMON.IOUNITS'
5824       common /sccalc/ time11,time12,time112,theti,it,nlobit
5825       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5826       double precision contr(maxlob)
5827       logical mixed
5828
5829       escloc_i=0.0D0
5830
5831       do j=1,3
5832         dersc(j)=0.0D0
5833       enddo
5834
5835       do j=1,nlobit
5836         do k=1,2
5837           z(k)=x(k)-censc(k,j,it)
5838         enddo
5839         z(3)=dwapi
5840         do k=1,3
5841           Axk=0.0D0
5842           do l=1,3
5843             Axk=Axk+gaussc(l,k,j,it)*z(l)
5844           enddo
5845           Ax(k,j)=Axk
5846         enddo
5847         expfac=0.0D0
5848         do k=1,3
5849           expfac=expfac+Ax(k,j)*z(k)
5850         enddo
5851         contr(j)=expfac
5852       enddo ! j
5853
5854 C As in the case of ebend, we want to avoid underflows in exponentiation and
5855 C subsequent NaNs and INFs in energy calculation.
5856 C Find the largest exponent
5857       emin=contr(1)
5858       do j=1,nlobit
5859         if (emin.gt.contr(j)) emin=contr(j)
5860       enddo
5861       emin=0.5D0*emin
5862
5863 C Compute the contribution to SC energy and derivatives
5864
5865       dersc12=0.0d0
5866       do j=1,nlobit
5867         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5868         escloc_i=escloc_i+expfac
5869         do k=1,2
5870           dersc(k)=dersc(k)+Ax(k,j)*expfac
5871         enddo
5872         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5873      &            +gaussc(1,2,j,it))*expfac
5874         dersc(3)=0.0d0
5875       enddo
5876
5877       dersc(1)=dersc(1)/cos(theti)**2
5878       dersc12=dersc12/cos(theti)**2
5879       escloci=-(dlog(escloc_i)-emin)
5880       do j=1,2
5881         dersc(j)=dersc(j)/escloc_i
5882       enddo
5883       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5884       return
5885       end
5886 #else
5887 c----------------------------------------------------------------------------------
5888       subroutine esc(escloc)
5889 C Calculate the local energy of a side chain and its derivatives in the
5890 C corresponding virtual-bond valence angles THETA and the spherical angles
5891 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5892 C added by Urszula Kozlowska. 07/11/2007
5893 C
5894       implicit real*8 (a-h,o-z)
5895       include 'DIMENSIONS'
5896       include 'COMMON.GEO'
5897       include 'COMMON.LOCAL'
5898       include 'COMMON.VAR'
5899       include 'COMMON.SCROT'
5900       include 'COMMON.INTERACT'
5901       include 'COMMON.DERIV'
5902       include 'COMMON.CHAIN'
5903       include 'COMMON.IOUNITS'
5904       include 'COMMON.NAMES'
5905       include 'COMMON.FFIELD'
5906       include 'COMMON.CONTROL'
5907       include 'COMMON.VECTORS'
5908       double precision x_prime(3),y_prime(3),z_prime(3)
5909      &    , sumene,dsc_i,dp2_i,x(65),
5910      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5911      &    de_dxx,de_dyy,de_dzz,de_dt
5912       double precision s1_t,s1_6_t,s2_t,s2_6_t
5913       double precision
5914      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5915      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5916      & dt_dCi(3),dt_dCi1(3)
5917       common /sccalc/ time11,time12,time112,theti,it,nlobit
5918       delta=0.02d0*pi
5919       escloc=0.0D0
5920       do i=loc_start,loc_end
5921         if (itype(i).eq.ntyp1) cycle
5922         costtab(i+1) =dcos(theta(i+1))
5923         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5924         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5925         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5926         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5927         cosfac=dsqrt(cosfac2)
5928         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5929         sinfac=dsqrt(sinfac2)
5930         it=iabs(itype(i))
5931         if (it.eq.10) goto 1
5932 c
5933 C  Compute the axes of tghe local cartesian coordinates system; store in
5934 c   x_prime, y_prime and z_prime
5935 c
5936         do j=1,3
5937           x_prime(j) = 0.00
5938           y_prime(j) = 0.00
5939           z_prime(j) = 0.00
5940         enddo
5941 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5942 C     &   dc_norm(3,i+nres)
5943         do j = 1,3
5944           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5945           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5946         enddo
5947         do j = 1,3
5948           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5949         enddo
5950 c       write (2,*) "i",i
5951 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5952 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5953 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5954 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5955 c      & " xy",scalar(x_prime(1),y_prime(1)),
5956 c      & " xz",scalar(x_prime(1),z_prime(1)),
5957 c      & " yy",scalar(y_prime(1),y_prime(1)),
5958 c      & " yz",scalar(y_prime(1),z_prime(1)),
5959 c      & " zz",scalar(z_prime(1),z_prime(1))
5960 c
5961 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5962 C to local coordinate system. Store in xx, yy, zz.
5963 c
5964         xx=0.0d0
5965         yy=0.0d0
5966         zz=0.0d0
5967         do j = 1,3
5968           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5969           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5970           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5971         enddo
5972
5973         xxtab(i)=xx
5974         yytab(i)=yy
5975         zztab(i)=zz
5976 C
5977 C Compute the energy of the ith side cbain
5978 C
5979 c        write (2,*) "xx",xx," yy",yy," zz",zz
5980         it=iabs(itype(i))
5981         do j = 1,65
5982           x(j) = sc_parmin(j,it)
5983         enddo
5984 #ifdef CHECK_COORD
5985 Cc diagnostics - remove later
5986         xx1 = dcos(alph(2))
5987         yy1 = dsin(alph(2))*dcos(omeg(2))
5988         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5989         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5990      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5991      &    xx1,yy1,zz1
5992 C,"  --- ", xx_w,yy_w,zz_w
5993 c end diagnostics
5994 #endif
5995         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5996      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5997      &   + x(10)*yy*zz
5998         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5999      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6000      & + x(20)*yy*zz
6001         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6002      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6003      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6004      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6005      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6006      &  +x(40)*xx*yy*zz
6007         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6008      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6009      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6010      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6011      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6012      &  +x(60)*xx*yy*zz
6013         dsc_i   = 0.743d0+x(61)
6014         dp2_i   = 1.9d0+x(62)
6015         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6016      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6017         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6018      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6019         s1=(1+x(63))/(0.1d0 + dscp1)
6020         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6021         s2=(1+x(65))/(0.1d0 + dscp2)
6022         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6023         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6024      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6025 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6026 c     &   sumene4,
6027 c     &   dscp1,dscp2,sumene
6028 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6029         escloc = escloc + sumene
6030 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6031 c     & ,zz,xx,yy
6032 c#define DEBUG
6033 #ifdef DEBUG
6034 C
6035 C This section to check the numerical derivatives of the energy of ith side
6036 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6037 C #define DEBUG in the code to turn it on.
6038 C
6039         write (2,*) "sumene               =",sumene
6040         aincr=1.0d-7
6041         xxsave=xx
6042         xx=xx+aincr
6043         write (2,*) xx,yy,zz
6044         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6045         de_dxx_num=(sumenep-sumene)/aincr
6046         xx=xxsave
6047         write (2,*) "xx+ sumene from enesc=",sumenep
6048         yysave=yy
6049         yy=yy+aincr
6050         write (2,*) xx,yy,zz
6051         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6052         de_dyy_num=(sumenep-sumene)/aincr
6053         yy=yysave
6054         write (2,*) "yy+ sumene from enesc=",sumenep
6055         zzsave=zz
6056         zz=zz+aincr
6057         write (2,*) xx,yy,zz
6058         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6059         de_dzz_num=(sumenep-sumene)/aincr
6060         zz=zzsave
6061         write (2,*) "zz+ sumene from enesc=",sumenep
6062         costsave=cost2tab(i+1)
6063         sintsave=sint2tab(i+1)
6064         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6065         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6066         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6067         de_dt_num=(sumenep-sumene)/aincr
6068         write (2,*) " t+ sumene from enesc=",sumenep
6069         cost2tab(i+1)=costsave
6070         sint2tab(i+1)=sintsave
6071 C End of diagnostics section.
6072 #endif
6073 C
6074 C Compute the gradient of esc
6075 C
6076 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6077         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6078         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6079         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6080         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6081         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6082         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6083         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6084         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6085         pom1=(sumene3*sint2tab(i+1)+sumene1)
6086      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6087         pom2=(sumene4*cost2tab(i+1)+sumene2)
6088      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6089         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6090         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6091      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6092      &  +x(40)*yy*zz
6093         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6094         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6095      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6096      &  +x(60)*yy*zz
6097         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6098      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6099      &        +(pom1+pom2)*pom_dx
6100 #ifdef DEBUG
6101         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6102 #endif
6103 C
6104         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6105         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6106      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6107      &  +x(40)*xx*zz
6108         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6109         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6110      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6111      &  +x(59)*zz**2 +x(60)*xx*zz
6112         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6113      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6114      &        +(pom1-pom2)*pom_dy
6115 #ifdef DEBUG
6116         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6117 #endif
6118 C
6119         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6120      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6121      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6122      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6123      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6124      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6125      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6126      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6127 #ifdef DEBUG
6128         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6129 #endif
6130 C
6131         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6132      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6133      &  +pom1*pom_dt1+pom2*pom_dt2
6134 #ifdef DEBUG
6135         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6136 #endif
6137 c#undef DEBUG
6138 c
6139 C
6140        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6141        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6142        cosfac2xx=cosfac2*xx
6143        sinfac2yy=sinfac2*yy
6144        do k = 1,3
6145          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6146      &      vbld_inv(i+1)
6147          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6148      &      vbld_inv(i)
6149          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6150          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6151 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6152 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6153 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6154 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6155          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6156          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6157          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6158          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6159          dZZ_Ci1(k)=0.0d0
6160          dZZ_Ci(k)=0.0d0
6161          do j=1,3
6162            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6163      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6164            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6165      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6166          enddo
6167
6168          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6169          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6170          dZZ_XYZ(k)=vbld_inv(i+nres)*
6171      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6172 c
6173          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6174          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6175        enddo
6176
6177        do k=1,3
6178          dXX_Ctab(k,i)=dXX_Ci(k)
6179          dXX_C1tab(k,i)=dXX_Ci1(k)
6180          dYY_Ctab(k,i)=dYY_Ci(k)
6181          dYY_C1tab(k,i)=dYY_Ci1(k)
6182          dZZ_Ctab(k,i)=dZZ_Ci(k)
6183          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6184          dXX_XYZtab(k,i)=dXX_XYZ(k)
6185          dYY_XYZtab(k,i)=dYY_XYZ(k)
6186          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6187        enddo
6188
6189        do k = 1,3
6190 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6191 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6192 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6193 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6194 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6195 c     &    dt_dci(k)
6196 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6197 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6198          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6199      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6200          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6201      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6202          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6203      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6204        enddo
6205 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6206 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6207
6208 C to check gradient call subroutine check_grad
6209
6210     1 continue
6211       enddo
6212       return
6213       end
6214 c------------------------------------------------------------------------------
6215       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6216       implicit none
6217       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6218      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6219       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6220      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6221      &   + x(10)*yy*zz
6222       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6223      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6224      & + x(20)*yy*zz
6225       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6226      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6227      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6228      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6229      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6230      &  +x(40)*xx*yy*zz
6231       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6232      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6233      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6234      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6235      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6236      &  +x(60)*xx*yy*zz
6237       dsc_i   = 0.743d0+x(61)
6238       dp2_i   = 1.9d0+x(62)
6239       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6240      &          *(xx*cost2+yy*sint2))
6241       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6242      &          *(xx*cost2-yy*sint2))
6243       s1=(1+x(63))/(0.1d0 + dscp1)
6244       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6245       s2=(1+x(65))/(0.1d0 + dscp2)
6246       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6247       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6248      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6249       enesc=sumene
6250       return
6251       end
6252 #endif
6253 c------------------------------------------------------------------------------
6254       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6255 C
6256 C This procedure calculates two-body contact function g(rij) and its derivative:
6257 C
6258 C           eps0ij                                     !       x < -1
6259 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6260 C            0                                         !       x > 1
6261 C
6262 C where x=(rij-r0ij)/delta
6263 C
6264 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6265 C
6266       implicit none
6267       double precision rij,r0ij,eps0ij,fcont,fprimcont
6268       double precision x,x2,x4,delta
6269 c     delta=0.02D0*r0ij
6270 c      delta=0.2D0*r0ij
6271       x=(rij-r0ij)/delta
6272       if (x.lt.-1.0D0) then
6273         fcont=eps0ij
6274         fprimcont=0.0D0
6275       else if (x.le.1.0D0) then
6276         x2=x*x
6277         x4=x2*x2
6278         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6279         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6280       else
6281         fcont=0.0D0
6282         fprimcont=0.0D0
6283       endif
6284       return
6285       end
6286 c------------------------------------------------------------------------------
6287       subroutine splinthet(theti,delta,ss,ssder)
6288       implicit real*8 (a-h,o-z)
6289       include 'DIMENSIONS'
6290       include 'COMMON.VAR'
6291       include 'COMMON.GEO'
6292       thetup=pi-delta
6293       thetlow=delta
6294       if (theti.gt.pipol) then
6295         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6296       else
6297         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6298         ssder=-ssder
6299       endif
6300       return
6301       end
6302 c------------------------------------------------------------------------------
6303       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6304       implicit none
6305       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6306       double precision ksi,ksi2,ksi3,a1,a2,a3
6307       a1=fprim0*delta/(f1-f0)
6308       a2=3.0d0-2.0d0*a1
6309       a3=a1-2.0d0
6310       ksi=(x-x0)/delta
6311       ksi2=ksi*ksi
6312       ksi3=ksi2*ksi
6313       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6314       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6315       return
6316       end
6317 c------------------------------------------------------------------------------
6318       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6319       implicit none
6320       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6321       double precision ksi,ksi2,ksi3,a1,a2,a3
6322       ksi=(x-x0)/delta
6323       ksi2=ksi*ksi
6324       ksi3=ksi2*ksi
6325       a1=fprim0x*delta
6326       a2=3*(f1x-f0x)-2*fprim0x*delta
6327       a3=fprim0x*delta-2*(f1x-f0x)
6328       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6329       return
6330       end
6331 C-----------------------------------------------------------------------------
6332 #ifdef CRYST_TOR
6333 C-----------------------------------------------------------------------------
6334       subroutine etor(etors,edihcnstr)
6335       implicit real*8 (a-h,o-z)
6336       include 'DIMENSIONS'
6337       include 'COMMON.VAR'
6338       include 'COMMON.GEO'
6339       include 'COMMON.LOCAL'
6340       include 'COMMON.TORSION'
6341       include 'COMMON.INTERACT'
6342       include 'COMMON.DERIV'
6343       include 'COMMON.CHAIN'
6344       include 'COMMON.NAMES'
6345       include 'COMMON.IOUNITS'
6346       include 'COMMON.FFIELD'
6347       include 'COMMON.TORCNSTR'
6348       include 'COMMON.CONTROL'
6349       logical lprn
6350 C Set lprn=.true. for debugging
6351       lprn=.false.
6352 c      lprn=.true.
6353       etors=0.0D0
6354       do i=iphi_start,iphi_end
6355       etors_ii=0.0D0
6356         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6357      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6358         itori=itortyp(itype(i-2))
6359         itori1=itortyp(itype(i-1))
6360         phii=phi(i)
6361         gloci=0.0D0
6362 C Proline-Proline pair is a special case...
6363         if (itori.eq.3 .and. itori1.eq.3) then
6364           if (phii.gt.-dwapi3) then
6365             cosphi=dcos(3*phii)
6366             fac=1.0D0/(1.0D0-cosphi)
6367             etorsi=v1(1,3,3)*fac
6368             etorsi=etorsi+etorsi
6369             etors=etors+etorsi-v1(1,3,3)
6370             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6371             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6372           endif
6373           do j=1,3
6374             v1ij=v1(j+1,itori,itori1)
6375             v2ij=v2(j+1,itori,itori1)
6376             cosphi=dcos(j*phii)
6377             sinphi=dsin(j*phii)
6378             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6379             if (energy_dec) etors_ii=etors_ii+
6380      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6381             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6382           enddo
6383         else
6384           do j=1,nterm_old
6385             v1ij=v1(j,itori,itori1)
6386             v2ij=v2(j,itori,itori1)
6387             cosphi=dcos(j*phii)
6388             sinphi=dsin(j*phii)
6389             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6390             if (energy_dec) etors_ii=etors_ii+
6391      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6392             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6393           enddo
6394         endif
6395         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6396              'etor',i,etors_ii
6397         if (lprn)
6398      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6399      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6400      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6401         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6402 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6403       enddo
6404 ! 6/20/98 - dihedral angle constraints
6405       edihcnstr=0.0d0
6406       do i=1,ndih_constr
6407         itori=idih_constr(i)
6408         phii=phi(itori)
6409         difi=phii-phi0(i)
6410         if (difi.gt.drange(i)) then
6411           difi=difi-drange(i)
6412           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6413           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6414         else if (difi.lt.-drange(i)) then
6415           difi=difi+drange(i)
6416           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6417           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6418         endif
6419 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6420 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6421       enddo
6422 !      write (iout,*) 'edihcnstr',edihcnstr
6423       return
6424       end
6425 c------------------------------------------------------------------------------
6426       subroutine etor_d(etors_d)
6427       etors_d=0.0d0
6428       return
6429       end
6430 c----------------------------------------------------------------------------
6431 #else
6432       subroutine etor(etors,edihcnstr)
6433       implicit real*8 (a-h,o-z)
6434       include 'DIMENSIONS'
6435       include 'COMMON.VAR'
6436       include 'COMMON.GEO'
6437       include 'COMMON.LOCAL'
6438       include 'COMMON.TORSION'
6439       include 'COMMON.INTERACT'
6440       include 'COMMON.DERIV'
6441       include 'COMMON.CHAIN'
6442       include 'COMMON.NAMES'
6443       include 'COMMON.IOUNITS'
6444       include 'COMMON.FFIELD'
6445       include 'COMMON.TORCNSTR'
6446       include 'COMMON.CONTROL'
6447       logical lprn
6448 C Set lprn=.true. for debugging
6449       lprn=.false.
6450 c     lprn=.true.
6451       etors=0.0D0
6452       do i=iphi_start,iphi_end
6453 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6454 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6455 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6456 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6457         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6458      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6459 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6460 C For introducing the NH3+ and COO- group please check the etor_d for reference
6461 C and guidance
6462         etors_ii=0.0D0
6463          if (iabs(itype(i)).eq.20) then
6464          iblock=2
6465          else
6466          iblock=1
6467          endif
6468         itori=itortyp(itype(i-2))
6469         itori1=itortyp(itype(i-1))
6470         phii=phi(i)
6471         gloci=0.0D0
6472 C Regular cosine and sine terms
6473         do j=1,nterm(itori,itori1,iblock)
6474           v1ij=v1(j,itori,itori1,iblock)
6475           v2ij=v2(j,itori,itori1,iblock)
6476           cosphi=dcos(j*phii)
6477           sinphi=dsin(j*phii)
6478           etors=etors+v1ij*cosphi+v2ij*sinphi
6479           if (energy_dec) etors_ii=etors_ii+
6480      &                v1ij*cosphi+v2ij*sinphi
6481           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6482         enddo
6483 C Lorentz terms
6484 C                         v1
6485 C  E = SUM ----------------------------------- - v1
6486 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6487 C
6488         cosphi=dcos(0.5d0*phii)
6489         sinphi=dsin(0.5d0*phii)
6490         do j=1,nlor(itori,itori1,iblock)
6491           vl1ij=vlor1(j,itori,itori1)
6492           vl2ij=vlor2(j,itori,itori1)
6493           vl3ij=vlor3(j,itori,itori1)
6494           pom=vl2ij*cosphi+vl3ij*sinphi
6495           pom1=1.0d0/(pom*pom+1.0d0)
6496           etors=etors+vl1ij*pom1
6497           if (energy_dec) etors_ii=etors_ii+
6498      &                vl1ij*pom1
6499           pom=-pom*pom1*pom1
6500           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6501         enddo
6502 C Subtract the constant term
6503         etors=etors-v0(itori,itori1,iblock)
6504           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6505      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6506         if (lprn)
6507      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6508      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6509      &  (v1(j,itori,itori1,iblock),j=1,6),
6510      &  (v2(j,itori,itori1,iblock),j=1,6)
6511         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6512 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6513       enddo
6514 ! 6/20/98 - dihedral angle constraints
6515       edihcnstr=0.0d0
6516 c      do i=1,ndih_constr
6517       do i=idihconstr_start,idihconstr_end
6518         itori=idih_constr(i)
6519         phii=phi(itori)
6520         difi=pinorm(phii-phi0(i))
6521         if (difi.gt.drange(i)) then
6522           difi=difi-drange(i)
6523           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6524           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6525         else if (difi.lt.-drange(i)) then
6526           difi=difi+drange(i)
6527           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6528           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6529         else
6530           difi=0.0
6531         endif
6532 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6533 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6534 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6535       enddo
6536 cd       write (iout,*) 'edihcnstr',edihcnstr
6537       return
6538       end
6539 c----------------------------------------------------------------------------
6540       subroutine etor_d(etors_d)
6541 C 6/23/01 Compute double torsional energy
6542       implicit real*8 (a-h,o-z)
6543       include 'DIMENSIONS'
6544       include 'COMMON.VAR'
6545       include 'COMMON.GEO'
6546       include 'COMMON.LOCAL'
6547       include 'COMMON.TORSION'
6548       include 'COMMON.INTERACT'
6549       include 'COMMON.DERIV'
6550       include 'COMMON.CHAIN'
6551       include 'COMMON.NAMES'
6552       include 'COMMON.IOUNITS'
6553       include 'COMMON.FFIELD'
6554       include 'COMMON.TORCNSTR'
6555       logical lprn
6556 C Set lprn=.true. for debugging
6557       lprn=.false.
6558 c     lprn=.true.
6559       etors_d=0.0D0
6560 c      write(iout,*) "a tu??"
6561       do i=iphid_start,iphid_end
6562 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6563 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6564 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6565 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6566 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6567          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6568      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6569      &  (itype(i+1).eq.ntyp1)) cycle
6570 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6571         itori=itortyp(itype(i-2))
6572         itori1=itortyp(itype(i-1))
6573         itori2=itortyp(itype(i))
6574         phii=phi(i)
6575         phii1=phi(i+1)
6576         gloci1=0.0D0
6577         gloci2=0.0D0
6578         iblock=1
6579         if (iabs(itype(i+1)).eq.20) iblock=2
6580 C Iblock=2 Proline type
6581 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6582 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6583 C        if (itype(i+1).eq.ntyp1) iblock=3
6584 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6585 C IS or IS NOT need for this
6586 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6587 C        is (itype(i-3).eq.ntyp1) ntblock=2
6588 C        ntblock is N-terminal blocking group
6589
6590 C Regular cosine and sine terms
6591         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6592 C Example of changes for NH3+ blocking group
6593 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6594 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6595           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6596           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6597           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6598           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6599           cosphi1=dcos(j*phii)
6600           sinphi1=dsin(j*phii)
6601           cosphi2=dcos(j*phii1)
6602           sinphi2=dsin(j*phii1)
6603           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6604      &     v2cij*cosphi2+v2sij*sinphi2
6605           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6606           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6607         enddo
6608         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6609           do l=1,k-1
6610             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6611             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6612             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6613             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6614             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6615             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6616             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6617             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6618             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6619      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6620             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6621      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6622             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6623      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6624           enddo
6625         enddo
6626         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6627         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6628       enddo
6629       return
6630       end
6631 #endif
6632 c------------------------------------------------------------------------------
6633       subroutine eback_sc_corr(esccor)
6634 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6635 c        conformational states; temporarily implemented as differences
6636 c        between UNRES torsional potentials (dependent on three types of
6637 c        residues) and the torsional potentials dependent on all 20 types
6638 c        of residues computed from AM1  energy surfaces of terminally-blocked
6639 c        amino-acid residues.
6640       implicit real*8 (a-h,o-z)
6641       include 'DIMENSIONS'
6642       include 'COMMON.VAR'
6643       include 'COMMON.GEO'
6644       include 'COMMON.LOCAL'
6645       include 'COMMON.TORSION'
6646       include 'COMMON.SCCOR'
6647       include 'COMMON.INTERACT'
6648       include 'COMMON.DERIV'
6649       include 'COMMON.CHAIN'
6650       include 'COMMON.NAMES'
6651       include 'COMMON.IOUNITS'
6652       include 'COMMON.FFIELD'
6653       include 'COMMON.CONTROL'
6654       logical lprn
6655 C Set lprn=.true. for debugging
6656       lprn=.false.
6657 c      lprn=.true.
6658 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6659       esccor=0.0D0
6660       do i=itau_start,itau_end
6661         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6662         esccor_ii=0.0D0
6663         isccori=isccortyp(itype(i-2))
6664         isccori1=isccortyp(itype(i-1))
6665 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6666         phii=phi(i)
6667         do intertyp=1,3 !intertyp
6668 cc Added 09 May 2012 (Adasko)
6669 cc  Intertyp means interaction type of backbone mainchain correlation:
6670 c   1 = SC...Ca...Ca...Ca
6671 c   2 = Ca...Ca...Ca...SC
6672 c   3 = SC...Ca...Ca...SCi
6673         gloci=0.0D0
6674         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6675      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6676      &      (itype(i-1).eq.ntyp1)))
6677      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6678      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6679      &     .or.(itype(i).eq.ntyp1)))
6680      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6681      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6682      &      (itype(i-3).eq.ntyp1)))) cycle
6683         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6684         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6685      & cycle
6686        do j=1,nterm_sccor(isccori,isccori1)
6687           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6688           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6689           cosphi=dcos(j*tauangle(intertyp,i))
6690           sinphi=dsin(j*tauangle(intertyp,i))
6691           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6692           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6693         enddo
6694 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6695         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6696         if (lprn)
6697      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6698      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6699      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6700      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6701         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6702        enddo !intertyp
6703       enddo
6704
6705       return
6706       end
6707 c----------------------------------------------------------------------------
6708       subroutine multibody(ecorr)
6709 C This subroutine calculates multi-body contributions to energy following
6710 C the idea of Skolnick et al. If side chains I and J make a contact and
6711 C at the same time side chains I+1 and J+1 make a contact, an extra
6712 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6713       implicit real*8 (a-h,o-z)
6714       include 'DIMENSIONS'
6715       include 'COMMON.IOUNITS'
6716       include 'COMMON.DERIV'
6717       include 'COMMON.INTERACT'
6718       include 'COMMON.CONTACTS'
6719       double precision gx(3),gx1(3)
6720       logical lprn
6721
6722 C Set lprn=.true. for debugging
6723       lprn=.false.
6724
6725       if (lprn) then
6726         write (iout,'(a)') 'Contact function values:'
6727         do i=nnt,nct-2
6728           write (iout,'(i2,20(1x,i2,f10.5))')
6729      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6730         enddo
6731       endif
6732       ecorr=0.0D0
6733       do i=nnt,nct
6734         do j=1,3
6735           gradcorr(j,i)=0.0D0
6736           gradxorr(j,i)=0.0D0
6737         enddo
6738       enddo
6739       do i=nnt,nct-2
6740
6741         DO ISHIFT = 3,4
6742
6743         i1=i+ishift
6744         num_conti=num_cont(i)
6745         num_conti1=num_cont(i1)
6746         do jj=1,num_conti
6747           j=jcont(jj,i)
6748           do kk=1,num_conti1
6749             j1=jcont(kk,i1)
6750             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6751 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6752 cd   &                   ' ishift=',ishift
6753 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6754 C The system gains extra energy.
6755               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6756             endif   ! j1==j+-ishift
6757           enddo     ! kk
6758         enddo       ! jj
6759
6760         ENDDO ! ISHIFT
6761
6762       enddo         ! i
6763       return
6764       end
6765 c------------------------------------------------------------------------------
6766       double precision function esccorr(i,j,k,l,jj,kk)
6767       implicit real*8 (a-h,o-z)
6768       include 'DIMENSIONS'
6769       include 'COMMON.IOUNITS'
6770       include 'COMMON.DERIV'
6771       include 'COMMON.INTERACT'
6772       include 'COMMON.CONTACTS'
6773       double precision gx(3),gx1(3)
6774       logical lprn
6775       lprn=.false.
6776       eij=facont(jj,i)
6777       ekl=facont(kk,k)
6778 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6779 C Calculate the multi-body contribution to energy.
6780 C Calculate multi-body contributions to the gradient.
6781 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6782 cd   & k,l,(gacont(m,kk,k),m=1,3)
6783       do m=1,3
6784         gx(m) =ekl*gacont(m,jj,i)
6785         gx1(m)=eij*gacont(m,kk,k)
6786         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6787         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6788         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6789         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6790       enddo
6791       do m=i,j-1
6792         do ll=1,3
6793           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6794         enddo
6795       enddo
6796       do m=k,l-1
6797         do ll=1,3
6798           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6799         enddo
6800       enddo
6801       esccorr=-eij*ekl
6802       return
6803       end
6804 c------------------------------------------------------------------------------
6805       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6806 C This subroutine calculates multi-body contributions to hydrogen-bonding
6807       implicit real*8 (a-h,o-z)
6808       include 'DIMENSIONS'
6809       include 'COMMON.IOUNITS'
6810 #ifdef MPI
6811       include "mpif.h"
6812       parameter (max_cont=maxconts)
6813       parameter (max_dim=26)
6814       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6815       double precision zapas(max_dim,maxconts,max_fg_procs),
6816      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6817       common /przechowalnia/ zapas
6818       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6819      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6820 #endif
6821       include 'COMMON.SETUP'
6822       include 'COMMON.FFIELD'
6823       include 'COMMON.DERIV'
6824       include 'COMMON.INTERACT'
6825       include 'COMMON.CONTACTS'
6826       include 'COMMON.CONTROL'
6827       include 'COMMON.LOCAL'
6828       double precision gx(3),gx1(3),time00
6829       logical lprn,ldone
6830
6831 C Set lprn=.true. for debugging
6832       lprn=.false.
6833 #ifdef MPI
6834       n_corr=0
6835       n_corr1=0
6836       if (nfgtasks.le.1) goto 30
6837       if (lprn) then
6838         write (iout,'(a)') 'Contact function values before RECEIVE:'
6839         do i=nnt,nct-2
6840           write (iout,'(2i3,50(1x,i2,f5.2))')
6841      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6842      &    j=1,num_cont_hb(i))
6843         enddo
6844       endif
6845       call flush(iout)
6846       do i=1,ntask_cont_from
6847         ncont_recv(i)=0
6848       enddo
6849       do i=1,ntask_cont_to
6850         ncont_sent(i)=0
6851       enddo
6852 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6853 c     & ntask_cont_to
6854 C Make the list of contacts to send to send to other procesors
6855 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6856 c      call flush(iout)
6857       do i=iturn3_start,iturn3_end
6858 c        write (iout,*) "make contact list turn3",i," num_cont",
6859 c     &    num_cont_hb(i)
6860         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6861       enddo
6862       do i=iturn4_start,iturn4_end
6863 c        write (iout,*) "make contact list turn4",i," num_cont",
6864 c     &   num_cont_hb(i)
6865         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6866       enddo
6867       do ii=1,nat_sent
6868         i=iat_sent(ii)
6869 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6870 c     &    num_cont_hb(i)
6871         do j=1,num_cont_hb(i)
6872         do k=1,4
6873           jjc=jcont_hb(j,i)
6874           iproc=iint_sent_local(k,jjc,ii)
6875 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6876           if (iproc.gt.0) then
6877             ncont_sent(iproc)=ncont_sent(iproc)+1
6878             nn=ncont_sent(iproc)
6879             zapas(1,nn,iproc)=i
6880             zapas(2,nn,iproc)=jjc
6881             zapas(3,nn,iproc)=facont_hb(j,i)
6882             zapas(4,nn,iproc)=ees0p(j,i)
6883             zapas(5,nn,iproc)=ees0m(j,i)
6884             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6885             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6886             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6887             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6888             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6889             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6890             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6891             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6892             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6893             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6894             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6895             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6896             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6897             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6898             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6899             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6900             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6901             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6902             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6903             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6904             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6905           endif
6906         enddo
6907         enddo
6908       enddo
6909       if (lprn) then
6910       write (iout,*)
6911      &  "Numbers of contacts to be sent to other processors",
6912      &  (ncont_sent(i),i=1,ntask_cont_to)
6913       write (iout,*) "Contacts sent"
6914       do ii=1,ntask_cont_to
6915         nn=ncont_sent(ii)
6916         iproc=itask_cont_to(ii)
6917         write (iout,*) nn," contacts to processor",iproc,
6918      &   " of CONT_TO_COMM group"
6919         do i=1,nn
6920           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6921         enddo
6922       enddo
6923       call flush(iout)
6924       endif
6925       CorrelType=477
6926       CorrelID=fg_rank+1
6927       CorrelType1=478
6928       CorrelID1=nfgtasks+fg_rank+1
6929       ireq=0
6930 C Receive the numbers of needed contacts from other processors
6931       do ii=1,ntask_cont_from
6932         iproc=itask_cont_from(ii)
6933         ireq=ireq+1
6934         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6935      &    FG_COMM,req(ireq),IERR)
6936       enddo
6937 c      write (iout,*) "IRECV ended"
6938 c      call flush(iout)
6939 C Send the number of contacts needed by other processors
6940       do ii=1,ntask_cont_to
6941         iproc=itask_cont_to(ii)
6942         ireq=ireq+1
6943         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6944      &    FG_COMM,req(ireq),IERR)
6945       enddo
6946 c      write (iout,*) "ISEND ended"
6947 c      write (iout,*) "number of requests (nn)",ireq
6948       call flush(iout)
6949       if (ireq.gt.0)
6950      &  call MPI_Waitall(ireq,req,status_array,ierr)
6951 c      write (iout,*)
6952 c     &  "Numbers of contacts to be received from other processors",
6953 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6954 c      call flush(iout)
6955 C Receive contacts
6956       ireq=0
6957       do ii=1,ntask_cont_from
6958         iproc=itask_cont_from(ii)
6959         nn=ncont_recv(ii)
6960 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6961 c     &   " of CONT_TO_COMM group"
6962         call flush(iout)
6963         if (nn.gt.0) then
6964           ireq=ireq+1
6965           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6966      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6967 c          write (iout,*) "ireq,req",ireq,req(ireq)
6968         endif
6969       enddo
6970 C Send the contacts to processors that need them
6971       do ii=1,ntask_cont_to
6972         iproc=itask_cont_to(ii)
6973         nn=ncont_sent(ii)
6974 c        write (iout,*) nn," contacts to processor",iproc,
6975 c     &   " of CONT_TO_COMM group"
6976         if (nn.gt.0) then
6977           ireq=ireq+1
6978           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6979      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6980 c          write (iout,*) "ireq,req",ireq,req(ireq)
6981 c          do i=1,nn
6982 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6983 c          enddo
6984         endif
6985       enddo
6986 c      write (iout,*) "number of requests (contacts)",ireq
6987 c      write (iout,*) "req",(req(i),i=1,4)
6988 c      call flush(iout)
6989       if (ireq.gt.0)
6990      & call MPI_Waitall(ireq,req,status_array,ierr)
6991       do iii=1,ntask_cont_from
6992         iproc=itask_cont_from(iii)
6993         nn=ncont_recv(iii)
6994         if (lprn) then
6995         write (iout,*) "Received",nn," contacts from processor",iproc,
6996      &   " of CONT_FROM_COMM group"
6997         call flush(iout)
6998         do i=1,nn
6999           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7000         enddo
7001         call flush(iout)
7002         endif
7003         do i=1,nn
7004           ii=zapas_recv(1,i,iii)
7005 c Flag the received contacts to prevent double-counting
7006           jj=-zapas_recv(2,i,iii)
7007 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7008 c          call flush(iout)
7009           nnn=num_cont_hb(ii)+1
7010           num_cont_hb(ii)=nnn
7011           jcont_hb(nnn,ii)=jj
7012           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7013           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7014           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7015           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7016           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7017           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7018           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7019           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7020           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7021           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7022           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7023           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7024           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7025           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7026           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7027           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7028           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7029           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7030           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7031           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7032           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7033           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7034           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7035           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7036         enddo
7037       enddo
7038       call flush(iout)
7039       if (lprn) then
7040         write (iout,'(a)') 'Contact function values after receive:'
7041         do i=nnt,nct-2
7042           write (iout,'(2i3,50(1x,i3,f5.2))')
7043      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7044      &    j=1,num_cont_hb(i))
7045         enddo
7046         call flush(iout)
7047       endif
7048    30 continue
7049 #endif
7050       if (lprn) then
7051         write (iout,'(a)') 'Contact function values:'
7052         do i=nnt,nct-2
7053           write (iout,'(2i3,50(1x,i3,f5.2))')
7054      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7055      &    j=1,num_cont_hb(i))
7056         enddo
7057       endif
7058       ecorr=0.0D0
7059 C Remove the loop below after debugging !!!
7060       do i=nnt,nct
7061         do j=1,3
7062           gradcorr(j,i)=0.0D0
7063           gradxorr(j,i)=0.0D0
7064         enddo
7065       enddo
7066 C Calculate the local-electrostatic correlation terms
7067       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7068         i1=i+1
7069         num_conti=num_cont_hb(i)
7070         num_conti1=num_cont_hb(i+1)
7071         do jj=1,num_conti
7072           j=jcont_hb(jj,i)
7073           jp=iabs(j)
7074           do kk=1,num_conti1
7075             j1=jcont_hb(kk,i1)
7076             jp1=iabs(j1)
7077 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7078 c     &         ' jj=',jj,' kk=',kk
7079             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7080      &          .or. j.lt.0 .and. j1.gt.0) .and.
7081      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7082 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7083 C The system gains extra energy.
7084               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7085               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7086      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7087               n_corr=n_corr+1
7088             else if (j1.eq.j) then
7089 C Contacts I-J and I-(J+1) occur simultaneously.
7090 C The system loses extra energy.
7091 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7092             endif
7093           enddo ! kk
7094           do kk=1,num_conti
7095             j1=jcont_hb(kk,i)
7096 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7097 c    &         ' jj=',jj,' kk=',kk
7098             if (j1.eq.j+1) then
7099 C Contacts I-J and (I+1)-J occur simultaneously.
7100 C The system loses extra energy.
7101 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7102             endif ! j1==j+1
7103           enddo ! kk
7104         enddo ! jj
7105       enddo ! i
7106       return
7107       end
7108 c------------------------------------------------------------------------------
7109       subroutine add_hb_contact(ii,jj,itask)
7110       implicit real*8 (a-h,o-z)
7111       include "DIMENSIONS"
7112       include "COMMON.IOUNITS"
7113       integer max_cont
7114       integer max_dim
7115       parameter (max_cont=maxconts)
7116       parameter (max_dim=26)
7117       include "COMMON.CONTACTS"
7118       double precision zapas(max_dim,maxconts,max_fg_procs),
7119      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7120       common /przechowalnia/ zapas
7121       integer i,j,ii,jj,iproc,itask(4),nn
7122 c      write (iout,*) "itask",itask
7123       do i=1,2
7124         iproc=itask(i)
7125         if (iproc.gt.0) then
7126           do j=1,num_cont_hb(ii)
7127             jjc=jcont_hb(j,ii)
7128 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7129             if (jjc.eq.jj) then
7130               ncont_sent(iproc)=ncont_sent(iproc)+1
7131               nn=ncont_sent(iproc)
7132               zapas(1,nn,iproc)=ii
7133               zapas(2,nn,iproc)=jjc
7134               zapas(3,nn,iproc)=facont_hb(j,ii)
7135               zapas(4,nn,iproc)=ees0p(j,ii)
7136               zapas(5,nn,iproc)=ees0m(j,ii)
7137               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7138               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7139               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7140               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7141               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7142               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7143               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7144               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7145               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7146               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7147               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7148               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7149               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7150               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7151               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7152               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7153               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7154               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7155               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7156               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7157               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7158               exit
7159             endif
7160           enddo
7161         endif
7162       enddo
7163       return
7164       end
7165 c------------------------------------------------------------------------------
7166       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7167      &  n_corr1)
7168 C This subroutine calculates multi-body contributions to hydrogen-bonding
7169       implicit real*8 (a-h,o-z)
7170       include 'DIMENSIONS'
7171       include 'COMMON.IOUNITS'
7172 #ifdef MPI
7173       include "mpif.h"
7174       parameter (max_cont=maxconts)
7175       parameter (max_dim=70)
7176       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7177       double precision zapas(max_dim,maxconts,max_fg_procs),
7178      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7179       common /przechowalnia/ zapas
7180       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7181      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7182 #endif
7183       include 'COMMON.SETUP'
7184       include 'COMMON.FFIELD'
7185       include 'COMMON.DERIV'
7186       include 'COMMON.LOCAL'
7187       include 'COMMON.INTERACT'
7188       include 'COMMON.CONTACTS'
7189       include 'COMMON.CHAIN'
7190       include 'COMMON.CONTROL'
7191       double precision gx(3),gx1(3)
7192       integer num_cont_hb_old(maxres)
7193       logical lprn,ldone
7194       double precision eello4,eello5,eelo6,eello_turn6
7195       external eello4,eello5,eello6,eello_turn6
7196 C Set lprn=.true. for debugging
7197       lprn=.false.
7198       eturn6=0.0d0
7199 #ifdef MPI
7200       do i=1,nres
7201         num_cont_hb_old(i)=num_cont_hb(i)
7202       enddo
7203       n_corr=0
7204       n_corr1=0
7205       if (nfgtasks.le.1) goto 30
7206       if (lprn) then
7207         write (iout,'(a)') 'Contact function values before RECEIVE:'
7208         do i=nnt,nct-2
7209           write (iout,'(2i3,50(1x,i2,f5.2))')
7210      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7211      &    j=1,num_cont_hb(i))
7212         enddo
7213       endif
7214       call flush(iout)
7215       do i=1,ntask_cont_from
7216         ncont_recv(i)=0
7217       enddo
7218       do i=1,ntask_cont_to
7219         ncont_sent(i)=0
7220       enddo
7221 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7222 c     & ntask_cont_to
7223 C Make the list of contacts to send to send to other procesors
7224       do i=iturn3_start,iturn3_end
7225 c        write (iout,*) "make contact list turn3",i," num_cont",
7226 c     &    num_cont_hb(i)
7227         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7228       enddo
7229       do i=iturn4_start,iturn4_end
7230 c        write (iout,*) "make contact list turn4",i," num_cont",
7231 c     &   num_cont_hb(i)
7232         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7233       enddo
7234       do ii=1,nat_sent
7235         i=iat_sent(ii)
7236 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7237 c     &    num_cont_hb(i)
7238         do j=1,num_cont_hb(i)
7239         do k=1,4
7240           jjc=jcont_hb(j,i)
7241           iproc=iint_sent_local(k,jjc,ii)
7242 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7243           if (iproc.ne.0) then
7244             ncont_sent(iproc)=ncont_sent(iproc)+1
7245             nn=ncont_sent(iproc)
7246             zapas(1,nn,iproc)=i
7247             zapas(2,nn,iproc)=jjc
7248             zapas(3,nn,iproc)=d_cont(j,i)
7249             ind=3
7250             do kk=1,3
7251               ind=ind+1
7252               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7253             enddo
7254             do kk=1,2
7255               do ll=1,2
7256                 ind=ind+1
7257                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7258               enddo
7259             enddo
7260             do jj=1,5
7261               do kk=1,3
7262                 do ll=1,2
7263                   do mm=1,2
7264                     ind=ind+1
7265                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7266                   enddo
7267                 enddo
7268               enddo
7269             enddo
7270           endif
7271         enddo
7272         enddo
7273       enddo
7274       if (lprn) then
7275       write (iout,*)
7276      &  "Numbers of contacts to be sent to other processors",
7277      &  (ncont_sent(i),i=1,ntask_cont_to)
7278       write (iout,*) "Contacts sent"
7279       do ii=1,ntask_cont_to
7280         nn=ncont_sent(ii)
7281         iproc=itask_cont_to(ii)
7282         write (iout,*) nn," contacts to processor",iproc,
7283      &   " of CONT_TO_COMM group"
7284         do i=1,nn
7285           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7286         enddo
7287       enddo
7288       call flush(iout)
7289       endif
7290       CorrelType=477
7291       CorrelID=fg_rank+1
7292       CorrelType1=478
7293       CorrelID1=nfgtasks+fg_rank+1
7294       ireq=0
7295 C Receive the numbers of needed contacts from other processors
7296       do ii=1,ntask_cont_from
7297         iproc=itask_cont_from(ii)
7298         ireq=ireq+1
7299         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7300      &    FG_COMM,req(ireq),IERR)
7301       enddo
7302 c      write (iout,*) "IRECV ended"
7303 c      call flush(iout)
7304 C Send the number of contacts needed by other processors
7305       do ii=1,ntask_cont_to
7306         iproc=itask_cont_to(ii)
7307         ireq=ireq+1
7308         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7309      &    FG_COMM,req(ireq),IERR)
7310       enddo
7311 c      write (iout,*) "ISEND ended"
7312 c      write (iout,*) "number of requests (nn)",ireq
7313       call flush(iout)
7314       if (ireq.gt.0)
7315      &  call MPI_Waitall(ireq,req,status_array,ierr)
7316 c      write (iout,*)
7317 c     &  "Numbers of contacts to be received from other processors",
7318 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7319 c      call flush(iout)
7320 C Receive contacts
7321       ireq=0
7322       do ii=1,ntask_cont_from
7323         iproc=itask_cont_from(ii)
7324         nn=ncont_recv(ii)
7325 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7326 c     &   " of CONT_TO_COMM group"
7327         call flush(iout)
7328         if (nn.gt.0) then
7329           ireq=ireq+1
7330           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7331      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7332 c          write (iout,*) "ireq,req",ireq,req(ireq)
7333         endif
7334       enddo
7335 C Send the contacts to processors that need them
7336       do ii=1,ntask_cont_to
7337         iproc=itask_cont_to(ii)
7338         nn=ncont_sent(ii)
7339 c        write (iout,*) nn," contacts to processor",iproc,
7340 c     &   " of CONT_TO_COMM group"
7341         if (nn.gt.0) then
7342           ireq=ireq+1
7343           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7344      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7345 c          write (iout,*) "ireq,req",ireq,req(ireq)
7346 c          do i=1,nn
7347 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7348 c          enddo
7349         endif
7350       enddo
7351 c      write (iout,*) "number of requests (contacts)",ireq
7352 c      write (iout,*) "req",(req(i),i=1,4)
7353 c      call flush(iout)
7354       if (ireq.gt.0)
7355      & call MPI_Waitall(ireq,req,status_array,ierr)
7356       do iii=1,ntask_cont_from
7357         iproc=itask_cont_from(iii)
7358         nn=ncont_recv(iii)
7359         if (lprn) then
7360         write (iout,*) "Received",nn," contacts from processor",iproc,
7361      &   " of CONT_FROM_COMM group"
7362         call flush(iout)
7363         do i=1,nn
7364           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7365         enddo
7366         call flush(iout)
7367         endif
7368         do i=1,nn
7369           ii=zapas_recv(1,i,iii)
7370 c Flag the received contacts to prevent double-counting
7371           jj=-zapas_recv(2,i,iii)
7372 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7373 c          call flush(iout)
7374           nnn=num_cont_hb(ii)+1
7375           num_cont_hb(ii)=nnn
7376           jcont_hb(nnn,ii)=jj
7377           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7378           ind=3
7379           do kk=1,3
7380             ind=ind+1
7381             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7382           enddo
7383           do kk=1,2
7384             do ll=1,2
7385               ind=ind+1
7386               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7387             enddo
7388           enddo
7389           do jj=1,5
7390             do kk=1,3
7391               do ll=1,2
7392                 do mm=1,2
7393                   ind=ind+1
7394                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7395                 enddo
7396               enddo
7397             enddo
7398           enddo
7399         enddo
7400       enddo
7401       call flush(iout)
7402       if (lprn) then
7403         write (iout,'(a)') 'Contact function values after receive:'
7404         do i=nnt,nct-2
7405           write (iout,'(2i3,50(1x,i3,5f6.3))')
7406      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7407      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7408         enddo
7409         call flush(iout)
7410       endif
7411    30 continue
7412 #endif
7413       if (lprn) then
7414         write (iout,'(a)') 'Contact function values:'
7415         do i=nnt,nct-2
7416           write (iout,'(2i3,50(1x,i2,5f6.3))')
7417      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7418      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7419         enddo
7420       endif
7421       ecorr=0.0D0
7422       ecorr5=0.0d0
7423       ecorr6=0.0d0
7424 C Remove the loop below after debugging !!!
7425       do i=nnt,nct
7426         do j=1,3
7427           gradcorr(j,i)=0.0D0
7428           gradxorr(j,i)=0.0D0
7429         enddo
7430       enddo
7431 C Calculate the dipole-dipole interaction energies
7432       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7433       do i=iatel_s,iatel_e+1
7434         num_conti=num_cont_hb(i)
7435         do jj=1,num_conti
7436           j=jcont_hb(jj,i)
7437 #ifdef MOMENT
7438           call dipole(i,j,jj)
7439 #endif
7440         enddo
7441       enddo
7442       endif
7443 C Calculate the local-electrostatic correlation terms
7444 c                write (iout,*) "gradcorr5 in eello5 before loop"
7445 c                do iii=1,nres
7446 c                  write (iout,'(i5,3f10.5)')
7447 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7448 c                enddo
7449       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7450 c        write (iout,*) "corr loop i",i
7451         i1=i+1
7452         num_conti=num_cont_hb(i)
7453         num_conti1=num_cont_hb(i+1)
7454         do jj=1,num_conti
7455           j=jcont_hb(jj,i)
7456           jp=iabs(j)
7457           do kk=1,num_conti1
7458             j1=jcont_hb(kk,i1)
7459             jp1=iabs(j1)
7460 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7461 c     &         ' jj=',jj,' kk=',kk
7462 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7463             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7464      &          .or. j.lt.0 .and. j1.gt.0) .and.
7465      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7466 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7467 C The system gains extra energy.
7468               n_corr=n_corr+1
7469               sqd1=dsqrt(d_cont(jj,i))
7470               sqd2=dsqrt(d_cont(kk,i1))
7471               sred_geom = sqd1*sqd2
7472               IF (sred_geom.lt.cutoff_corr) THEN
7473                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7474      &            ekont,fprimcont)
7475 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7476 cd     &         ' jj=',jj,' kk=',kk
7477                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7478                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7479                 do l=1,3
7480                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7481                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7482                 enddo
7483                 n_corr1=n_corr1+1
7484 cd               write (iout,*) 'sred_geom=',sred_geom,
7485 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7486 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7487 cd               write (iout,*) "g_contij",g_contij
7488 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7489 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7490                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7491                 if (wcorr4.gt.0.0d0)
7492      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7493                   if (energy_dec.and.wcorr4.gt.0.0d0)
7494      1                 write (iout,'(a6,4i5,0pf7.3)')
7495      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7496 c                write (iout,*) "gradcorr5 before eello5"
7497 c                do iii=1,nres
7498 c                  write (iout,'(i5,3f10.5)')
7499 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7500 c                enddo
7501                 if (wcorr5.gt.0.0d0)
7502      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7503 c                write (iout,*) "gradcorr5 after eello5"
7504 c                do iii=1,nres
7505 c                  write (iout,'(i5,3f10.5)')
7506 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7507 c                enddo
7508                   if (energy_dec.and.wcorr5.gt.0.0d0)
7509      1                 write (iout,'(a6,4i5,0pf7.3)')
7510      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7511 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7512 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7513                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7514      &               .or. wturn6.eq.0.0d0))then
7515 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7516                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7517                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7518      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7519 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7520 cd     &            'ecorr6=',ecorr6
7521 cd                write (iout,'(4e15.5)') sred_geom,
7522 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7523 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7524 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7525                 else if (wturn6.gt.0.0d0
7526      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7527 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7528                   eturn6=eturn6+eello_turn6(i,jj,kk)
7529                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7530      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7531 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7532                 endif
7533               ENDIF
7534 1111          continue
7535             endif
7536           enddo ! kk
7537         enddo ! jj
7538       enddo ! i
7539       do i=1,nres
7540         num_cont_hb(i)=num_cont_hb_old(i)
7541       enddo
7542 c                write (iout,*) "gradcorr5 in eello5"
7543 c                do iii=1,nres
7544 c                  write (iout,'(i5,3f10.5)')
7545 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7546 c                enddo
7547       return
7548       end
7549 c------------------------------------------------------------------------------
7550       subroutine add_hb_contact_eello(ii,jj,itask)
7551       implicit real*8 (a-h,o-z)
7552       include "DIMENSIONS"
7553       include "COMMON.IOUNITS"
7554       integer max_cont
7555       integer max_dim
7556       parameter (max_cont=maxconts)
7557       parameter (max_dim=70)
7558       include "COMMON.CONTACTS"
7559       double precision zapas(max_dim,maxconts,max_fg_procs),
7560      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7561       common /przechowalnia/ zapas
7562       integer i,j,ii,jj,iproc,itask(4),nn
7563 c      write (iout,*) "itask",itask
7564       do i=1,2
7565         iproc=itask(i)
7566         if (iproc.gt.0) then
7567           do j=1,num_cont_hb(ii)
7568             jjc=jcont_hb(j,ii)
7569 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7570             if (jjc.eq.jj) then
7571               ncont_sent(iproc)=ncont_sent(iproc)+1
7572               nn=ncont_sent(iproc)
7573               zapas(1,nn,iproc)=ii
7574               zapas(2,nn,iproc)=jjc
7575               zapas(3,nn,iproc)=d_cont(j,ii)
7576               ind=3
7577               do kk=1,3
7578                 ind=ind+1
7579                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7580               enddo
7581               do kk=1,2
7582                 do ll=1,2
7583                   ind=ind+1
7584                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7585                 enddo
7586               enddo
7587               do jj=1,5
7588                 do kk=1,3
7589                   do ll=1,2
7590                     do mm=1,2
7591                       ind=ind+1
7592                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7593                     enddo
7594                   enddo
7595                 enddo
7596               enddo
7597               exit
7598             endif
7599           enddo
7600         endif
7601       enddo
7602       return
7603       end
7604 c------------------------------------------------------------------------------
7605       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7606       implicit real*8 (a-h,o-z)
7607       include 'DIMENSIONS'
7608       include 'COMMON.IOUNITS'
7609       include 'COMMON.DERIV'
7610       include 'COMMON.INTERACT'
7611       include 'COMMON.CONTACTS'
7612       double precision gx(3),gx1(3)
7613       logical lprn
7614       lprn=.false.
7615       eij=facont_hb(jj,i)
7616       ekl=facont_hb(kk,k)
7617       ees0pij=ees0p(jj,i)
7618       ees0pkl=ees0p(kk,k)
7619       ees0mij=ees0m(jj,i)
7620       ees0mkl=ees0m(kk,k)
7621       ekont=eij*ekl
7622       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7623 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7624 C Following 4 lines for diagnostics.
7625 cd    ees0pkl=0.0D0
7626 cd    ees0pij=1.0D0
7627 cd    ees0mkl=0.0D0
7628 cd    ees0mij=1.0D0
7629 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7630 c     & 'Contacts ',i,j,
7631 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7632 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7633 c     & 'gradcorr_long'
7634 C Calculate the multi-body contribution to energy.
7635 c      ecorr=ecorr+ekont*ees
7636 C Calculate multi-body contributions to the gradient.
7637       coeffpees0pij=coeffp*ees0pij
7638       coeffmees0mij=coeffm*ees0mij
7639       coeffpees0pkl=coeffp*ees0pkl
7640       coeffmees0mkl=coeffm*ees0mkl
7641       do ll=1,3
7642 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7643         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7644      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7645      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7646         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7647      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7648      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7649 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7650         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7651      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7652      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7653         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7654      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7655      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7656         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7657      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7658      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7659         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7660         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7661         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7662      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7663      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7664         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7665         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7666 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7667       enddo
7668 c      write (iout,*)
7669 cgrad      do m=i+1,j-1
7670 cgrad        do ll=1,3
7671 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7672 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7673 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7674 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7675 cgrad        enddo
7676 cgrad      enddo
7677 cgrad      do m=k+1,l-1
7678 cgrad        do ll=1,3
7679 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7680 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7681 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7682 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7683 cgrad        enddo
7684 cgrad      enddo
7685 c      write (iout,*) "ehbcorr",ekont*ees
7686       ehbcorr=ekont*ees
7687       return
7688       end
7689 #ifdef MOMENT
7690 C---------------------------------------------------------------------------
7691       subroutine dipole(i,j,jj)
7692       implicit real*8 (a-h,o-z)
7693       include 'DIMENSIONS'
7694       include 'COMMON.IOUNITS'
7695       include 'COMMON.CHAIN'
7696       include 'COMMON.FFIELD'
7697       include 'COMMON.DERIV'
7698       include 'COMMON.INTERACT'
7699       include 'COMMON.CONTACTS'
7700       include 'COMMON.TORSION'
7701       include 'COMMON.VAR'
7702       include 'COMMON.GEO'
7703       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7704      &  auxmat(2,2)
7705       iti1 = itortyp(itype(i+1))
7706       if (j.lt.nres-1) then
7707         itj1 = itortyp(itype(j+1))
7708       else
7709         itj1=ntortyp
7710       endif
7711       do iii=1,2
7712         dipi(iii,1)=Ub2(iii,i)
7713         dipderi(iii)=Ub2der(iii,i)
7714         dipi(iii,2)=b1(iii,i+1)
7715         dipj(iii,1)=Ub2(iii,j)
7716         dipderj(iii)=Ub2der(iii,j)
7717         dipj(iii,2)=b1(iii,j+1)
7718       enddo
7719       kkk=0
7720       do iii=1,2
7721         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7722         do jjj=1,2
7723           kkk=kkk+1
7724           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7725         enddo
7726       enddo
7727       do kkk=1,5
7728         do lll=1,3
7729           mmm=0
7730           do iii=1,2
7731             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7732      &        auxvec(1))
7733             do jjj=1,2
7734               mmm=mmm+1
7735               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7736             enddo
7737           enddo
7738         enddo
7739       enddo
7740       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7741       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7742       do iii=1,2
7743         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7744       enddo
7745       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7746       do iii=1,2
7747         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7748       enddo
7749       return
7750       end
7751 #endif
7752 C---------------------------------------------------------------------------
7753       subroutine calc_eello(i,j,k,l,jj,kk)
7754 C
7755 C This subroutine computes matrices and vectors needed to calculate
7756 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7757 C
7758       implicit real*8 (a-h,o-z)
7759       include 'DIMENSIONS'
7760       include 'COMMON.IOUNITS'
7761       include 'COMMON.CHAIN'
7762       include 'COMMON.DERIV'
7763       include 'COMMON.INTERACT'
7764       include 'COMMON.CONTACTS'
7765       include 'COMMON.TORSION'
7766       include 'COMMON.VAR'
7767       include 'COMMON.GEO'
7768       include 'COMMON.FFIELD'
7769       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7770      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7771       logical lprn
7772       common /kutas/ lprn
7773 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7774 cd     & ' jj=',jj,' kk=',kk
7775 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7776 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7777 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7778       do iii=1,2
7779         do jjj=1,2
7780           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7781           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7782         enddo
7783       enddo
7784       call transpose2(aa1(1,1),aa1t(1,1))
7785       call transpose2(aa2(1,1),aa2t(1,1))
7786       do kkk=1,5
7787         do lll=1,3
7788           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7789      &      aa1tder(1,1,lll,kkk))
7790           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7791      &      aa2tder(1,1,lll,kkk))
7792         enddo
7793       enddo
7794       if (l.eq.j+1) then
7795 C parallel orientation of the two CA-CA-CA frames.
7796         if (i.gt.1) then
7797           iti=itortyp(itype(i))
7798         else
7799           iti=ntortyp
7800         endif
7801         itk1=itortyp(itype(k+1))
7802         itj=itortyp(itype(j))
7803         if (l.lt.nres-1) then
7804           itl1=itortyp(itype(l+1))
7805         else
7806           itl1=ntortyp
7807         endif
7808 C A1 kernel(j+1) A2T
7809 cd        do iii=1,2
7810 cd          write (iout,'(3f10.5,5x,3f10.5)')
7811 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7812 cd        enddo
7813         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7814      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7815      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7816 C Following matrices are needed only for 6-th order cumulants
7817         IF (wcorr6.gt.0.0d0) THEN
7818         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7819      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7820      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7821         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7822      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7823      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7824      &   ADtEAderx(1,1,1,1,1,1))
7825         lprn=.false.
7826         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7827      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7828      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7829      &   ADtEA1derx(1,1,1,1,1,1))
7830         ENDIF
7831 C End 6-th order cumulants
7832 cd        lprn=.false.
7833 cd        if (lprn) then
7834 cd        write (2,*) 'In calc_eello6'
7835 cd        do iii=1,2
7836 cd          write (2,*) 'iii=',iii
7837 cd          do kkk=1,5
7838 cd            write (2,*) 'kkk=',kkk
7839 cd            do jjj=1,2
7840 cd              write (2,'(3(2f10.5),5x)')
7841 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7842 cd            enddo
7843 cd          enddo
7844 cd        enddo
7845 cd        endif
7846         call transpose2(EUgder(1,1,k),auxmat(1,1))
7847         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7848         call transpose2(EUg(1,1,k),auxmat(1,1))
7849         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7850         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7851         do iii=1,2
7852           do kkk=1,5
7853             do lll=1,3
7854               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7855      &          EAEAderx(1,1,lll,kkk,iii,1))
7856             enddo
7857           enddo
7858         enddo
7859 C A1T kernel(i+1) A2
7860         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7861      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7862      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7863 C Following matrices are needed only for 6-th order cumulants
7864         IF (wcorr6.gt.0.0d0) THEN
7865         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7866      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7867      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7868         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7869      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7870      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7871      &   ADtEAderx(1,1,1,1,1,2))
7872         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7873      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7874      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7875      &   ADtEA1derx(1,1,1,1,1,2))
7876         ENDIF
7877 C End 6-th order cumulants
7878         call transpose2(EUgder(1,1,l),auxmat(1,1))
7879         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7880         call transpose2(EUg(1,1,l),auxmat(1,1))
7881         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7882         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7883         do iii=1,2
7884           do kkk=1,5
7885             do lll=1,3
7886               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7887      &          EAEAderx(1,1,lll,kkk,iii,2))
7888             enddo
7889           enddo
7890         enddo
7891 C AEAb1 and AEAb2
7892 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7893 C They are needed only when the fifth- or the sixth-order cumulants are
7894 C indluded.
7895         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7896         call transpose2(AEA(1,1,1),auxmat(1,1))
7897         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7898         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7899         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7900         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7901         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7902         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7903         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7904         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7905         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7906         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7907         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7908         call transpose2(AEA(1,1,2),auxmat(1,1))
7909         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7910         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7911         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7912         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7913         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7914         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7915         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7916         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7917         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7918         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7919         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7920 C Calculate the Cartesian derivatives of the vectors.
7921         do iii=1,2
7922           do kkk=1,5
7923             do lll=1,3
7924               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7925               call matvec2(auxmat(1,1),b1(1,i),
7926      &          AEAb1derx(1,lll,kkk,iii,1,1))
7927               call matvec2(auxmat(1,1),Ub2(1,i),
7928      &          AEAb2derx(1,lll,kkk,iii,1,1))
7929               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7930      &          AEAb1derx(1,lll,kkk,iii,2,1))
7931               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7932      &          AEAb2derx(1,lll,kkk,iii,2,1))
7933               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7934               call matvec2(auxmat(1,1),b1(1,j),
7935      &          AEAb1derx(1,lll,kkk,iii,1,2))
7936               call matvec2(auxmat(1,1),Ub2(1,j),
7937      &          AEAb2derx(1,lll,kkk,iii,1,2))
7938               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7939      &          AEAb1derx(1,lll,kkk,iii,2,2))
7940               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7941      &          AEAb2derx(1,lll,kkk,iii,2,2))
7942             enddo
7943           enddo
7944         enddo
7945         ENDIF
7946 C End vectors
7947       else
7948 C Antiparallel orientation of the two CA-CA-CA frames.
7949         if (i.gt.1) then
7950           iti=itortyp(itype(i))
7951         else
7952           iti=ntortyp
7953         endif
7954         itk1=itortyp(itype(k+1))
7955         itl=itortyp(itype(l))
7956         itj=itortyp(itype(j))
7957         if (j.lt.nres-1) then
7958           itj1=itortyp(itype(j+1))
7959         else
7960           itj1=ntortyp
7961         endif
7962 C A2 kernel(j-1)T A1T
7963         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7964      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7965      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7966 C Following matrices are needed only for 6-th order cumulants
7967         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7968      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7969         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7970      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7971      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7972         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7973      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7974      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7975      &   ADtEAderx(1,1,1,1,1,1))
7976         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7977      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7978      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7979      &   ADtEA1derx(1,1,1,1,1,1))
7980         ENDIF
7981 C End 6-th order cumulants
7982         call transpose2(EUgder(1,1,k),auxmat(1,1))
7983         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7984         call transpose2(EUg(1,1,k),auxmat(1,1))
7985         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7986         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7987         do iii=1,2
7988           do kkk=1,5
7989             do lll=1,3
7990               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7991      &          EAEAderx(1,1,lll,kkk,iii,1))
7992             enddo
7993           enddo
7994         enddo
7995 C A2T kernel(i+1)T A1
7996         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7997      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7998      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7999 C Following matrices are needed only for 6-th order cumulants
8000         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8001      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8002         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8003      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8004      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8005         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8006      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8007      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8008      &   ADtEAderx(1,1,1,1,1,2))
8009         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8010      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8011      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8012      &   ADtEA1derx(1,1,1,1,1,2))
8013         ENDIF
8014 C End 6-th order cumulants
8015         call transpose2(EUgder(1,1,j),auxmat(1,1))
8016         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8017         call transpose2(EUg(1,1,j),auxmat(1,1))
8018         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8019         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8020         do iii=1,2
8021           do kkk=1,5
8022             do lll=1,3
8023               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8024      &          EAEAderx(1,1,lll,kkk,iii,2))
8025             enddo
8026           enddo
8027         enddo
8028 C AEAb1 and AEAb2
8029 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8030 C They are needed only when the fifth- or the sixth-order cumulants are
8031 C indluded.
8032         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8033      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8034         call transpose2(AEA(1,1,1),auxmat(1,1))
8035         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8036         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8037         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8038         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8039         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8040         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8041         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8042         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8043         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8044         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8045         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8046         call transpose2(AEA(1,1,2),auxmat(1,1))
8047         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8048         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8049         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8050         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8051         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8052         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8053         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8054         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8055         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8056         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8057         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8058 C Calculate the Cartesian derivatives of the vectors.
8059         do iii=1,2
8060           do kkk=1,5
8061             do lll=1,3
8062               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8063               call matvec2(auxmat(1,1),b1(1,i),
8064      &          AEAb1derx(1,lll,kkk,iii,1,1))
8065               call matvec2(auxmat(1,1),Ub2(1,i),
8066      &          AEAb2derx(1,lll,kkk,iii,1,1))
8067               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8068      &          AEAb1derx(1,lll,kkk,iii,2,1))
8069               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8070      &          AEAb2derx(1,lll,kkk,iii,2,1))
8071               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8072               call matvec2(auxmat(1,1),b1(1,l),
8073      &          AEAb1derx(1,lll,kkk,iii,1,2))
8074               call matvec2(auxmat(1,1),Ub2(1,l),
8075      &          AEAb2derx(1,lll,kkk,iii,1,2))
8076               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8077      &          AEAb1derx(1,lll,kkk,iii,2,2))
8078               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8079      &          AEAb2derx(1,lll,kkk,iii,2,2))
8080             enddo
8081           enddo
8082         enddo
8083         ENDIF
8084 C End vectors
8085       endif
8086       return
8087       end
8088 C---------------------------------------------------------------------------
8089       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8090      &  KK,KKderg,AKA,AKAderg,AKAderx)
8091       implicit none
8092       integer nderg
8093       logical transp
8094       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8095      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8096      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8097       integer iii,kkk,lll
8098       integer jjj,mmm
8099       logical lprn
8100       common /kutas/ lprn
8101       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8102       do iii=1,nderg
8103         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8104      &    AKAderg(1,1,iii))
8105       enddo
8106 cd      if (lprn) write (2,*) 'In kernel'
8107       do kkk=1,5
8108 cd        if (lprn) write (2,*) 'kkk=',kkk
8109         do lll=1,3
8110           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8111      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8112 cd          if (lprn) then
8113 cd            write (2,*) 'lll=',lll
8114 cd            write (2,*) 'iii=1'
8115 cd            do jjj=1,2
8116 cd              write (2,'(3(2f10.5),5x)')
8117 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8118 cd            enddo
8119 cd          endif
8120           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8121      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8122 cd          if (lprn) then
8123 cd            write (2,*) 'lll=',lll
8124 cd            write (2,*) 'iii=2'
8125 cd            do jjj=1,2
8126 cd              write (2,'(3(2f10.5),5x)')
8127 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8128 cd            enddo
8129 cd          endif
8130         enddo
8131       enddo
8132       return
8133       end
8134 C---------------------------------------------------------------------------
8135       double precision function eello4(i,j,k,l,jj,kk)
8136       implicit real*8 (a-h,o-z)
8137       include 'DIMENSIONS'
8138       include 'COMMON.IOUNITS'
8139       include 'COMMON.CHAIN'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.INTERACT'
8142       include 'COMMON.CONTACTS'
8143       include 'COMMON.TORSION'
8144       include 'COMMON.VAR'
8145       include 'COMMON.GEO'
8146       double precision pizda(2,2),ggg1(3),ggg2(3)
8147 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8148 cd        eello4=0.0d0
8149 cd        return
8150 cd      endif
8151 cd      print *,'eello4:',i,j,k,l,jj,kk
8152 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8153 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8154 cold      eij=facont_hb(jj,i)
8155 cold      ekl=facont_hb(kk,k)
8156 cold      ekont=eij*ekl
8157       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8158 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8159       gcorr_loc(k-1)=gcorr_loc(k-1)
8160      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8161       if (l.eq.j+1) then
8162         gcorr_loc(l-1)=gcorr_loc(l-1)
8163      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8164       else
8165         gcorr_loc(j-1)=gcorr_loc(j-1)
8166      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8167       endif
8168       do iii=1,2
8169         do kkk=1,5
8170           do lll=1,3
8171             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8172      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8173 cd            derx(lll,kkk,iii)=0.0d0
8174           enddo
8175         enddo
8176       enddo
8177 cd      gcorr_loc(l-1)=0.0d0
8178 cd      gcorr_loc(j-1)=0.0d0
8179 cd      gcorr_loc(k-1)=0.0d0
8180 cd      eel4=1.0d0
8181 cd      write (iout,*)'Contacts have occurred for peptide groups',
8182 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8183 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8184       if (j.lt.nres-1) then
8185         j1=j+1
8186         j2=j-1
8187       else
8188         j1=j-1
8189         j2=j-2
8190       endif
8191       if (l.lt.nres-1) then
8192         l1=l+1
8193         l2=l-1
8194       else
8195         l1=l-1
8196         l2=l-2
8197       endif
8198       do ll=1,3
8199 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8200 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8201         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8202         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8203 cgrad        ghalf=0.5d0*ggg1(ll)
8204         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8205         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8206         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8207         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8208         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8209         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8210 cgrad        ghalf=0.5d0*ggg2(ll)
8211         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8212         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8213         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8214         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8215         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8216         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8217       enddo
8218 cgrad      do m=i+1,j-1
8219 cgrad        do ll=1,3
8220 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8221 cgrad        enddo
8222 cgrad      enddo
8223 cgrad      do m=k+1,l-1
8224 cgrad        do ll=1,3
8225 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8226 cgrad        enddo
8227 cgrad      enddo
8228 cgrad      do m=i+2,j2
8229 cgrad        do ll=1,3
8230 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8231 cgrad        enddo
8232 cgrad      enddo
8233 cgrad      do m=k+2,l2
8234 cgrad        do ll=1,3
8235 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8236 cgrad        enddo
8237 cgrad      enddo
8238 cd      do iii=1,nres-3
8239 cd        write (2,*) iii,gcorr_loc(iii)
8240 cd      enddo
8241       eello4=ekont*eel4
8242 cd      write (2,*) 'ekont',ekont
8243 cd      write (iout,*) 'eello4',ekont*eel4
8244       return
8245       end
8246 C---------------------------------------------------------------------------
8247       double precision function eello5(i,j,k,l,jj,kk)
8248       implicit real*8 (a-h,o-z)
8249       include 'DIMENSIONS'
8250       include 'COMMON.IOUNITS'
8251       include 'COMMON.CHAIN'
8252       include 'COMMON.DERIV'
8253       include 'COMMON.INTERACT'
8254       include 'COMMON.CONTACTS'
8255       include 'COMMON.TORSION'
8256       include 'COMMON.VAR'
8257       include 'COMMON.GEO'
8258       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8259       double precision ggg1(3),ggg2(3)
8260 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8261 C                                                                              C
8262 C                            Parallel chains                                   C
8263 C                                                                              C
8264 C          o             o                   o             o                   C
8265 C         /l\           / \             \   / \           / \   /              C
8266 C        /   \         /   \             \ /   \         /   \ /               C
8267 C       j| o |l1       | o |              o| o |         | o |o                C
8268 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8269 C      \i/   \         /   \ /             /   \         /   \                 C
8270 C       o    k1             o                                                  C
8271 C         (I)          (II)                (III)          (IV)                 C
8272 C                                                                              C
8273 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8274 C                                                                              C
8275 C                            Antiparallel chains                               C
8276 C                                                                              C
8277 C          o             o                   o             o                   C
8278 C         /j\           / \             \   / \           / \   /              C
8279 C        /   \         /   \             \ /   \         /   \ /               C
8280 C      j1| o |l        | o |              o| o |         | o |o                C
8281 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8282 C      \i/   \         /   \ /             /   \         /   \                 C
8283 C       o     k1            o                                                  C
8284 C         (I)          (II)                (III)          (IV)                 C
8285 C                                                                              C
8286 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8287 C                                                                              C
8288 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8289 C                                                                              C
8290 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8291 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8292 cd        eello5=0.0d0
8293 cd        return
8294 cd      endif
8295 cd      write (iout,*)
8296 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8297 cd     &   ' and',k,l
8298       itk=itortyp(itype(k))
8299       itl=itortyp(itype(l))
8300       itj=itortyp(itype(j))
8301       eello5_1=0.0d0
8302       eello5_2=0.0d0
8303       eello5_3=0.0d0
8304       eello5_4=0.0d0
8305 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8306 cd     &   eel5_3_num,eel5_4_num)
8307       do iii=1,2
8308         do kkk=1,5
8309           do lll=1,3
8310             derx(lll,kkk,iii)=0.0d0
8311           enddo
8312         enddo
8313       enddo
8314 cd      eij=facont_hb(jj,i)
8315 cd      ekl=facont_hb(kk,k)
8316 cd      ekont=eij*ekl
8317 cd      write (iout,*)'Contacts have occurred for peptide groups',
8318 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8319 cd      goto 1111
8320 C Contribution from the graph I.
8321 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8322 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8323       call transpose2(EUg(1,1,k),auxmat(1,1))
8324       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8325       vv(1)=pizda(1,1)-pizda(2,2)
8326       vv(2)=pizda(1,2)+pizda(2,1)
8327       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8328      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8329 C Explicit gradient in virtual-dihedral angles.
8330       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8331      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8332      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8333       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8334       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8335       vv(1)=pizda(1,1)-pizda(2,2)
8336       vv(2)=pizda(1,2)+pizda(2,1)
8337       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8338      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8339      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8340       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8341       vv(1)=pizda(1,1)-pizda(2,2)
8342       vv(2)=pizda(1,2)+pizda(2,1)
8343       if (l.eq.j+1) then
8344         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8345      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8346      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8347       else
8348         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8349      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8350      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8351       endif
8352 C Cartesian gradient
8353       do iii=1,2
8354         do kkk=1,5
8355           do lll=1,3
8356             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8357      &        pizda(1,1))
8358             vv(1)=pizda(1,1)-pizda(2,2)
8359             vv(2)=pizda(1,2)+pizda(2,1)
8360             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8361      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8362      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8363           enddo
8364         enddo
8365       enddo
8366 c      goto 1112
8367 c1111  continue
8368 C Contribution from graph II
8369       call transpose2(EE(1,1,itk),auxmat(1,1))
8370       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8371       vv(1)=pizda(1,1)+pizda(2,2)
8372       vv(2)=pizda(2,1)-pizda(1,2)
8373       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8374      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8375 C Explicit gradient in virtual-dihedral angles.
8376       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8377      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8378       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8379       vv(1)=pizda(1,1)+pizda(2,2)
8380       vv(2)=pizda(2,1)-pizda(1,2)
8381       if (l.eq.j+1) then
8382         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8383      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8384      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8385       else
8386         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8387      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8388      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8389       endif
8390 C Cartesian gradient
8391       do iii=1,2
8392         do kkk=1,5
8393           do lll=1,3
8394             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8395      &        pizda(1,1))
8396             vv(1)=pizda(1,1)+pizda(2,2)
8397             vv(2)=pizda(2,1)-pizda(1,2)
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8399      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8400      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8401           enddo
8402         enddo
8403       enddo
8404 cd      goto 1112
8405 cd1111  continue
8406       if (l.eq.j+1) then
8407 cd        goto 1110
8408 C Parallel orientation
8409 C Contribution from graph III
8410         call transpose2(EUg(1,1,l),auxmat(1,1))
8411         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8412         vv(1)=pizda(1,1)-pizda(2,2)
8413         vv(2)=pizda(1,2)+pizda(2,1)
8414         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8415      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8416 C Explicit gradient in virtual-dihedral angles.
8417         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8418      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8419      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8420         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8421         vv(1)=pizda(1,1)-pizda(2,2)
8422         vv(2)=pizda(1,2)+pizda(2,1)
8423         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8424      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8425      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8426         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8427         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8428         vv(1)=pizda(1,1)-pizda(2,2)
8429         vv(2)=pizda(1,2)+pizda(2,1)
8430         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8431      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8432      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8433 C Cartesian gradient
8434         do iii=1,2
8435           do kkk=1,5
8436             do lll=1,3
8437               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8438      &          pizda(1,1))
8439               vv(1)=pizda(1,1)-pizda(2,2)
8440               vv(2)=pizda(1,2)+pizda(2,1)
8441               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8442      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8443      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8444             enddo
8445           enddo
8446         enddo
8447 cd        goto 1112
8448 C Contribution from graph IV
8449 cd1110    continue
8450         call transpose2(EE(1,1,itl),auxmat(1,1))
8451         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8452         vv(1)=pizda(1,1)+pizda(2,2)
8453         vv(2)=pizda(2,1)-pizda(1,2)
8454         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8455      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8456 C Explicit gradient in virtual-dihedral angles.
8457         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8458      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8459         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8460         vv(1)=pizda(1,1)+pizda(2,2)
8461         vv(2)=pizda(2,1)-pizda(1,2)
8462         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8463      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8464      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8465 C Cartesian gradient
8466         do iii=1,2
8467           do kkk=1,5
8468             do lll=1,3
8469               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8470      &          pizda(1,1))
8471               vv(1)=pizda(1,1)+pizda(2,2)
8472               vv(2)=pizda(2,1)-pizda(1,2)
8473               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8474      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8475      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8476             enddo
8477           enddo
8478         enddo
8479       else
8480 C Antiparallel orientation
8481 C Contribution from graph III
8482 c        goto 1110
8483         call transpose2(EUg(1,1,j),auxmat(1,1))
8484         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8485         vv(1)=pizda(1,1)-pizda(2,2)
8486         vv(2)=pizda(1,2)+pizda(2,1)
8487         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8488      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8489 C Explicit gradient in virtual-dihedral angles.
8490         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8491      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8492      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8493         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8494         vv(1)=pizda(1,1)-pizda(2,2)
8495         vv(2)=pizda(1,2)+pizda(2,1)
8496         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8497      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8498      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8499         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8500         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8501         vv(1)=pizda(1,1)-pizda(2,2)
8502         vv(2)=pizda(1,2)+pizda(2,1)
8503         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8504      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8505      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8506 C Cartesian gradient
8507         do iii=1,2
8508           do kkk=1,5
8509             do lll=1,3
8510               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8511      &          pizda(1,1))
8512               vv(1)=pizda(1,1)-pizda(2,2)
8513               vv(2)=pizda(1,2)+pizda(2,1)
8514               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8515      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8516      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8517             enddo
8518           enddo
8519         enddo
8520 cd        goto 1112
8521 C Contribution from graph IV
8522 1110    continue
8523         call transpose2(EE(1,1,itj),auxmat(1,1))
8524         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8525         vv(1)=pizda(1,1)+pizda(2,2)
8526         vv(2)=pizda(2,1)-pizda(1,2)
8527         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8528      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8529 C Explicit gradient in virtual-dihedral angles.
8530         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8531      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8532         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8533         vv(1)=pizda(1,1)+pizda(2,2)
8534         vv(2)=pizda(2,1)-pizda(1,2)
8535         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8536      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8537      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8538 C Cartesian gradient
8539         do iii=1,2
8540           do kkk=1,5
8541             do lll=1,3
8542               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8543      &          pizda(1,1))
8544               vv(1)=pizda(1,1)+pizda(2,2)
8545               vv(2)=pizda(2,1)-pizda(1,2)
8546               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8547      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8548      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8549             enddo
8550           enddo
8551         enddo
8552       endif
8553 1112  continue
8554       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8555 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8556 cd        write (2,*) 'ijkl',i,j,k,l
8557 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8558 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8559 cd      endif
8560 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8561 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8562 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8563 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8564       if (j.lt.nres-1) then
8565         j1=j+1
8566         j2=j-1
8567       else
8568         j1=j-1
8569         j2=j-2
8570       endif
8571       if (l.lt.nres-1) then
8572         l1=l+1
8573         l2=l-1
8574       else
8575         l1=l-1
8576         l2=l-2
8577       endif
8578 cd      eij=1.0d0
8579 cd      ekl=1.0d0
8580 cd      ekont=1.0d0
8581 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8582 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8583 C        summed up outside the subrouine as for the other subroutines
8584 C        handling long-range interactions. The old code is commented out
8585 C        with "cgrad" to keep track of changes.
8586       do ll=1,3
8587 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8588 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8589         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8590         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8591 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8592 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8593 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8594 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8595 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8596 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8597 c     &   gradcorr5ij,
8598 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8599 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8600 cgrad        ghalf=0.5d0*ggg1(ll)
8601 cd        ghalf=0.0d0
8602         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8603         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8604         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8605         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8606         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8607         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8608 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8609 cgrad        ghalf=0.5d0*ggg2(ll)
8610 cd        ghalf=0.0d0
8611         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8612         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8613         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8614         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8615         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8616         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8617       enddo
8618 cd      goto 1112
8619 cgrad      do m=i+1,j-1
8620 cgrad        do ll=1,3
8621 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8622 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8623 cgrad        enddo
8624 cgrad      enddo
8625 cgrad      do m=k+1,l-1
8626 cgrad        do ll=1,3
8627 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8628 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8629 cgrad        enddo
8630 cgrad      enddo
8631 c1112  continue
8632 cgrad      do m=i+2,j2
8633 cgrad        do ll=1,3
8634 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8635 cgrad        enddo
8636 cgrad      enddo
8637 cgrad      do m=k+2,l2
8638 cgrad        do ll=1,3
8639 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8640 cgrad        enddo
8641 cgrad      enddo
8642 cd      do iii=1,nres-3
8643 cd        write (2,*) iii,g_corr5_loc(iii)
8644 cd      enddo
8645       eello5=ekont*eel5
8646 cd      write (2,*) 'ekont',ekont
8647 cd      write (iout,*) 'eello5',ekont*eel5
8648       return
8649       end
8650 c--------------------------------------------------------------------------
8651       double precision function eello6(i,j,k,l,jj,kk)
8652       implicit real*8 (a-h,o-z)
8653       include 'DIMENSIONS'
8654       include 'COMMON.IOUNITS'
8655       include 'COMMON.CHAIN'
8656       include 'COMMON.DERIV'
8657       include 'COMMON.INTERACT'
8658       include 'COMMON.CONTACTS'
8659       include 'COMMON.TORSION'
8660       include 'COMMON.VAR'
8661       include 'COMMON.GEO'
8662       include 'COMMON.FFIELD'
8663       double precision ggg1(3),ggg2(3)
8664 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8665 cd        eello6=0.0d0
8666 cd        return
8667 cd      endif
8668 cd      write (iout,*)
8669 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8670 cd     &   ' and',k,l
8671       eello6_1=0.0d0
8672       eello6_2=0.0d0
8673       eello6_3=0.0d0
8674       eello6_4=0.0d0
8675       eello6_5=0.0d0
8676       eello6_6=0.0d0
8677 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8678 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8679       do iii=1,2
8680         do kkk=1,5
8681           do lll=1,3
8682             derx(lll,kkk,iii)=0.0d0
8683           enddo
8684         enddo
8685       enddo
8686 cd      eij=facont_hb(jj,i)
8687 cd      ekl=facont_hb(kk,k)
8688 cd      ekont=eij*ekl
8689 cd      eij=1.0d0
8690 cd      ekl=1.0d0
8691 cd      ekont=1.0d0
8692       if (l.eq.j+1) then
8693         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8694         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8695         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8696         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8697         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8698         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8699       else
8700         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8701         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8702         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8703         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8704         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8705           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8706         else
8707           eello6_5=0.0d0
8708         endif
8709         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8710       endif
8711 C If turn contributions are considered, they will be handled separately.
8712       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8713 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8714 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8715 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8716 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8717 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8718 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8719 cd      goto 1112
8720       if (j.lt.nres-1) then
8721         j1=j+1
8722         j2=j-1
8723       else
8724         j1=j-1
8725         j2=j-2
8726       endif
8727       if (l.lt.nres-1) then
8728         l1=l+1
8729         l2=l-1
8730       else
8731         l1=l-1
8732         l2=l-2
8733       endif
8734       do ll=1,3
8735 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8736 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8737 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8738 cgrad        ghalf=0.5d0*ggg1(ll)
8739 cd        ghalf=0.0d0
8740         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8741         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8742         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8743         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8744         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8745         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8746         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8747         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8748 cgrad        ghalf=0.5d0*ggg2(ll)
8749 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8750 cd        ghalf=0.0d0
8751         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8752         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8753         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8754         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8755         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8756         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8757       enddo
8758 cd      goto 1112
8759 cgrad      do m=i+1,j-1
8760 cgrad        do ll=1,3
8761 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8762 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8763 cgrad        enddo
8764 cgrad      enddo
8765 cgrad      do m=k+1,l-1
8766 cgrad        do ll=1,3
8767 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8768 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8769 cgrad        enddo
8770 cgrad      enddo
8771 cgrad1112  continue
8772 cgrad      do m=i+2,j2
8773 cgrad        do ll=1,3
8774 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8775 cgrad        enddo
8776 cgrad      enddo
8777 cgrad      do m=k+2,l2
8778 cgrad        do ll=1,3
8779 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8780 cgrad        enddo
8781 cgrad      enddo
8782 cd      do iii=1,nres-3
8783 cd        write (2,*) iii,g_corr6_loc(iii)
8784 cd      enddo
8785       eello6=ekont*eel6
8786 cd      write (2,*) 'ekont',ekont
8787 cd      write (iout,*) 'eello6',ekont*eel6
8788       return
8789       end
8790 c--------------------------------------------------------------------------
8791       double precision function eello6_graph1(i,j,k,l,imat,swap)
8792       implicit real*8 (a-h,o-z)
8793       include 'DIMENSIONS'
8794       include 'COMMON.IOUNITS'
8795       include 'COMMON.CHAIN'
8796       include 'COMMON.DERIV'
8797       include 'COMMON.INTERACT'
8798       include 'COMMON.CONTACTS'
8799       include 'COMMON.TORSION'
8800       include 'COMMON.VAR'
8801       include 'COMMON.GEO'
8802       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8803       logical swap
8804       logical lprn
8805       common /kutas/ lprn
8806 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8807 C                                                                              C
8808 C      Parallel       Antiparallel                                             C
8809 C                                                                              C
8810 C          o             o                                                     C
8811 C         /l\           /j\                                                    C
8812 C        /   \         /   \                                                   C
8813 C       /| o |         | o |\                                                  C
8814 C     \ j|/k\|  /   \  |/k\|l /                                                C
8815 C      \ /   \ /     \ /   \ /                                                 C
8816 C       o     o       o     o                                                  C
8817 C       i             i                                                        C
8818 C                                                                              C
8819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8820       itk=itortyp(itype(k))
8821       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8822       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8823       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8824       call transpose2(EUgC(1,1,k),auxmat(1,1))
8825       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8826       vv1(1)=pizda1(1,1)-pizda1(2,2)
8827       vv1(2)=pizda1(1,2)+pizda1(2,1)
8828       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8829       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8830       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8831       s5=scalar2(vv(1),Dtobr2(1,i))
8832 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8833       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8834       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8835      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8836      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8837      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8838      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8839      & +scalar2(vv(1),Dtobr2der(1,i)))
8840       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8841       vv1(1)=pizda1(1,1)-pizda1(2,2)
8842       vv1(2)=pizda1(1,2)+pizda1(2,1)
8843       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8844       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8845       if (l.eq.j+1) then
8846         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8847      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8848      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8849      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8850      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8851       else
8852         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8853      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8854      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8855      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8856      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8857       endif
8858       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8859       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8860       vv1(1)=pizda1(1,1)-pizda1(2,2)
8861       vv1(2)=pizda1(1,2)+pizda1(2,1)
8862       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8863      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8864      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8865      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8866       do iii=1,2
8867         if (swap) then
8868           ind=3-iii
8869         else
8870           ind=iii
8871         endif
8872         do kkk=1,5
8873           do lll=1,3
8874             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8875             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8876             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8877             call transpose2(EUgC(1,1,k),auxmat(1,1))
8878             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8879      &        pizda1(1,1))
8880             vv1(1)=pizda1(1,1)-pizda1(2,2)
8881             vv1(2)=pizda1(1,2)+pizda1(2,1)
8882             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8883             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8884      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8885             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8886      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8887             s5=scalar2(vv(1),Dtobr2(1,i))
8888             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8889           enddo
8890         enddo
8891       enddo
8892       return
8893       end
8894 c----------------------------------------------------------------------------
8895       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8896       implicit real*8 (a-h,o-z)
8897       include 'DIMENSIONS'
8898       include 'COMMON.IOUNITS'
8899       include 'COMMON.CHAIN'
8900       include 'COMMON.DERIV'
8901       include 'COMMON.INTERACT'
8902       include 'COMMON.CONTACTS'
8903       include 'COMMON.TORSION'
8904       include 'COMMON.VAR'
8905       include 'COMMON.GEO'
8906       logical swap
8907       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8908      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8909       logical lprn
8910       common /kutas/ lprn
8911 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8912 C                                                                              C
8913 C      Parallel       Antiparallel                                             C
8914 C                                                                              C
8915 C          o             o                                                     C
8916 C     \   /l\           /j\   /                                                C
8917 C      \ /   \         /   \ /                                                 C
8918 C       o| o |         | o |o                                                  C
8919 C     \ j|/k\|      \  |/k\|l                                                  C
8920 C      \ /   \       \ /   \                                                   C
8921 C       o             o                                                        C
8922 C       i             i                                                        C
8923 C                                                                              C
8924 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8925 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8926 C AL 7/4/01 s1 would occur in the sixth-order moment,
8927 C           but not in a cluster cumulant
8928 #ifdef MOMENT
8929       s1=dip(1,jj,i)*dip(1,kk,k)
8930 #endif
8931       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8932       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8933       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8934       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8935       call transpose2(EUg(1,1,k),auxmat(1,1))
8936       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8937       vv(1)=pizda(1,1)-pizda(2,2)
8938       vv(2)=pizda(1,2)+pizda(2,1)
8939       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8940 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8941 #ifdef MOMENT
8942       eello6_graph2=-(s1+s2+s3+s4)
8943 #else
8944       eello6_graph2=-(s2+s3+s4)
8945 #endif
8946 c      eello6_graph2=-s3
8947 C Derivatives in gamma(i-1)
8948       if (i.gt.1) then
8949 #ifdef MOMENT
8950         s1=dipderg(1,jj,i)*dip(1,kk,k)
8951 #endif
8952         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8953         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8954         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8955         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8956 #ifdef MOMENT
8957         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8958 #else
8959         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8960 #endif
8961 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8962       endif
8963 C Derivatives in gamma(k-1)
8964 #ifdef MOMENT
8965       s1=dip(1,jj,i)*dipderg(1,kk,k)
8966 #endif
8967       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8968       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8969       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8970       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8971       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8972       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8973       vv(1)=pizda(1,1)-pizda(2,2)
8974       vv(2)=pizda(1,2)+pizda(2,1)
8975       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8976 #ifdef MOMENT
8977       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8978 #else
8979       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8980 #endif
8981 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8982 C Derivatives in gamma(j-1) or gamma(l-1)
8983       if (j.gt.1) then
8984 #ifdef MOMENT
8985         s1=dipderg(3,jj,i)*dip(1,kk,k)
8986 #endif
8987         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8988         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8989         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8990         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8991         vv(1)=pizda(1,1)-pizda(2,2)
8992         vv(2)=pizda(1,2)+pizda(2,1)
8993         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8994 #ifdef MOMENT
8995         if (swap) then
8996           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8997         else
8998           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8999         endif
9000 #endif
9001         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9002 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9003       endif
9004 C Derivatives in gamma(l-1) or gamma(j-1)
9005       if (l.gt.1) then
9006 #ifdef MOMENT
9007         s1=dip(1,jj,i)*dipderg(3,kk,k)
9008 #endif
9009         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9010         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9011         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9012         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9013         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9014         vv(1)=pizda(1,1)-pizda(2,2)
9015         vv(2)=pizda(1,2)+pizda(2,1)
9016         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9017 #ifdef MOMENT
9018         if (swap) then
9019           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9020         else
9021           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9022         endif
9023 #endif
9024         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9025 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9026       endif
9027 C Cartesian derivatives.
9028       if (lprn) then
9029         write (2,*) 'In eello6_graph2'
9030         do iii=1,2
9031           write (2,*) 'iii=',iii
9032           do kkk=1,5
9033             write (2,*) 'kkk=',kkk
9034             do jjj=1,2
9035               write (2,'(3(2f10.5),5x)')
9036      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9037             enddo
9038           enddo
9039         enddo
9040       endif
9041       do iii=1,2
9042         do kkk=1,5
9043           do lll=1,3
9044 #ifdef MOMENT
9045             if (iii.eq.1) then
9046               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9047             else
9048               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9049             endif
9050 #endif
9051             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9052      &        auxvec(1))
9053             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9054             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9055      &        auxvec(1))
9056             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9057             call transpose2(EUg(1,1,k),auxmat(1,1))
9058             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9059      &        pizda(1,1))
9060             vv(1)=pizda(1,1)-pizda(2,2)
9061             vv(2)=pizda(1,2)+pizda(2,1)
9062             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9063 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9064 #ifdef MOMENT
9065             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9066 #else
9067             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9068 #endif
9069             if (swap) then
9070               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9071             else
9072               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9073             endif
9074           enddo
9075         enddo
9076       enddo
9077       return
9078       end
9079 c----------------------------------------------------------------------------
9080       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9081       implicit real*8 (a-h,o-z)
9082       include 'DIMENSIONS'
9083       include 'COMMON.IOUNITS'
9084       include 'COMMON.CHAIN'
9085       include 'COMMON.DERIV'
9086       include 'COMMON.INTERACT'
9087       include 'COMMON.CONTACTS'
9088       include 'COMMON.TORSION'
9089       include 'COMMON.VAR'
9090       include 'COMMON.GEO'
9091       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9092       logical swap
9093 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9094 C                                                                              C
9095 C      Parallel       Antiparallel                                             C
9096 C                                                                              C
9097 C          o             o                                                     C
9098 C         /l\   /   \   /j\                                                    C
9099 C        /   \ /     \ /   \                                                   C
9100 C       /| o |o       o| o |\                                                  C
9101 C       j|/k\|  /      |/k\|l /                                                C
9102 C        /   \ /       /   \ /                                                 C
9103 C       /     o       /     o                                                  C
9104 C       i             i                                                        C
9105 C                                                                              C
9106 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9107 C
9108 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9109 C           energy moment and not to the cluster cumulant.
9110       iti=itortyp(itype(i))
9111       if (j.lt.nres-1) then
9112         itj1=itortyp(itype(j+1))
9113       else
9114         itj1=ntortyp
9115       endif
9116       itk=itortyp(itype(k))
9117       itk1=itortyp(itype(k+1))
9118       if (l.lt.nres-1) then
9119         itl1=itortyp(itype(l+1))
9120       else
9121         itl1=ntortyp
9122       endif
9123 #ifdef MOMENT
9124       s1=dip(4,jj,i)*dip(4,kk,k)
9125 #endif
9126       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9127       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9128       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9129       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9130       call transpose2(EE(1,1,itk),auxmat(1,1))
9131       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9132       vv(1)=pizda(1,1)+pizda(2,2)
9133       vv(2)=pizda(2,1)-pizda(1,2)
9134       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9135 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9136 cd     & "sum",-(s2+s3+s4)
9137 #ifdef MOMENT
9138       eello6_graph3=-(s1+s2+s3+s4)
9139 #else
9140       eello6_graph3=-(s2+s3+s4)
9141 #endif
9142 c      eello6_graph3=-s4
9143 C Derivatives in gamma(k-1)
9144       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9145       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9146       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9147       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9148 C Derivatives in gamma(l-1)
9149       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9150       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9151       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9152       vv(1)=pizda(1,1)+pizda(2,2)
9153       vv(2)=pizda(2,1)-pizda(1,2)
9154       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9155       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9156 C Cartesian derivatives.
9157       do iii=1,2
9158         do kkk=1,5
9159           do lll=1,3
9160 #ifdef MOMENT
9161             if (iii.eq.1) then
9162               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9163             else
9164               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9165             endif
9166 #endif
9167             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9168      &        auxvec(1))
9169             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9170             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9171      &        auxvec(1))
9172             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9173             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9174      &        pizda(1,1))
9175             vv(1)=pizda(1,1)+pizda(2,2)
9176             vv(2)=pizda(2,1)-pizda(1,2)
9177             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9178 #ifdef MOMENT
9179             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9180 #else
9181             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9182 #endif
9183             if (swap) then
9184               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9185             else
9186               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9187             endif
9188 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9189           enddo
9190         enddo
9191       enddo
9192       return
9193       end
9194 c----------------------------------------------------------------------------
9195       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9196       implicit real*8 (a-h,o-z)
9197       include 'DIMENSIONS'
9198       include 'COMMON.IOUNITS'
9199       include 'COMMON.CHAIN'
9200       include 'COMMON.DERIV'
9201       include 'COMMON.INTERACT'
9202       include 'COMMON.CONTACTS'
9203       include 'COMMON.TORSION'
9204       include 'COMMON.VAR'
9205       include 'COMMON.GEO'
9206       include 'COMMON.FFIELD'
9207       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9208      & auxvec1(2),auxmat1(2,2)
9209       logical swap
9210 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9211 C                                                                              C
9212 C      Parallel       Antiparallel                                             C
9213 C                                                                              C
9214 C          o             o                                                     C
9215 C         /l\   /   \   /j\                                                    C
9216 C        /   \ /     \ /   \                                                   C
9217 C       /| o |o       o| o |\                                                  C
9218 C     \ j|/k\|      \  |/k\|l                                                  C
9219 C      \ /   \       \ /   \                                                   C
9220 C       o     \       o     \                                                  C
9221 C       i             i                                                        C
9222 C                                                                              C
9223 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9224 C
9225 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9226 C           energy moment and not to the cluster cumulant.
9227 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9228       iti=itortyp(itype(i))
9229       itj=itortyp(itype(j))
9230       if (j.lt.nres-1) then
9231         itj1=itortyp(itype(j+1))
9232       else
9233         itj1=ntortyp
9234       endif
9235       itk=itortyp(itype(k))
9236       if (k.lt.nres-1) then
9237         itk1=itortyp(itype(k+1))
9238       else
9239         itk1=ntortyp
9240       endif
9241       itl=itortyp(itype(l))
9242       if (l.lt.nres-1) then
9243         itl1=itortyp(itype(l+1))
9244       else
9245         itl1=ntortyp
9246       endif
9247 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9248 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9249 cd     & ' itl',itl,' itl1',itl1
9250 #ifdef MOMENT
9251       if (imat.eq.1) then
9252         s1=dip(3,jj,i)*dip(3,kk,k)
9253       else
9254         s1=dip(2,jj,j)*dip(2,kk,l)
9255       endif
9256 #endif
9257       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9258       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9259       if (j.eq.l+1) then
9260         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9261         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9262       else
9263         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9264         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9265       endif
9266       call transpose2(EUg(1,1,k),auxmat(1,1))
9267       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9268       vv(1)=pizda(1,1)-pizda(2,2)
9269       vv(2)=pizda(2,1)+pizda(1,2)
9270       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9271 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9272 #ifdef MOMENT
9273       eello6_graph4=-(s1+s2+s3+s4)
9274 #else
9275       eello6_graph4=-(s2+s3+s4)
9276 #endif
9277 C Derivatives in gamma(i-1)
9278       if (i.gt.1) then
9279 #ifdef MOMENT
9280         if (imat.eq.1) then
9281           s1=dipderg(2,jj,i)*dip(3,kk,k)
9282         else
9283           s1=dipderg(4,jj,j)*dip(2,kk,l)
9284         endif
9285 #endif
9286         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9287         if (j.eq.l+1) then
9288           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9289           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9290         else
9291           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9292           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9293         endif
9294         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9295         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9296 cd          write (2,*) 'turn6 derivatives'
9297 #ifdef MOMENT
9298           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9299 #else
9300           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9301 #endif
9302         else
9303 #ifdef MOMENT
9304           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9305 #else
9306           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9307 #endif
9308         endif
9309       endif
9310 C Derivatives in gamma(k-1)
9311 #ifdef MOMENT
9312       if (imat.eq.1) then
9313         s1=dip(3,jj,i)*dipderg(2,kk,k)
9314       else
9315         s1=dip(2,jj,j)*dipderg(4,kk,l)
9316       endif
9317 #endif
9318       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9319       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9320       if (j.eq.l+1) then
9321         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9322         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9323       else
9324         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9325         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9326       endif
9327       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9328       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9329       vv(1)=pizda(1,1)-pizda(2,2)
9330       vv(2)=pizda(2,1)+pizda(1,2)
9331       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9332       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9333 #ifdef MOMENT
9334         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9335 #else
9336         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9337 #endif
9338       else
9339 #ifdef MOMENT
9340         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9341 #else
9342         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9343 #endif
9344       endif
9345 C Derivatives in gamma(j-1) or gamma(l-1)
9346       if (l.eq.j+1 .and. l.gt.1) then
9347         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9348         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9349         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9350         vv(1)=pizda(1,1)-pizda(2,2)
9351         vv(2)=pizda(2,1)+pizda(1,2)
9352         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9353         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9354       else if (j.gt.1) then
9355         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9356         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9357         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9358         vv(1)=pizda(1,1)-pizda(2,2)
9359         vv(2)=pizda(2,1)+pizda(1,2)
9360         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9361         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9362           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9363         else
9364           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9365         endif
9366       endif
9367 C Cartesian derivatives.
9368       do iii=1,2
9369         do kkk=1,5
9370           do lll=1,3
9371 #ifdef MOMENT
9372             if (iii.eq.1) then
9373               if (imat.eq.1) then
9374                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9375               else
9376                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9377               endif
9378             else
9379               if (imat.eq.1) then
9380                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9381               else
9382                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9383               endif
9384             endif
9385 #endif
9386             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9387      &        auxvec(1))
9388             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9389             if (j.eq.l+1) then
9390               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9391      &          b1(1,j+1),auxvec(1))
9392               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9393             else
9394               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9395      &          b1(1,l+1),auxvec(1))
9396               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9397             endif
9398             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9399      &        pizda(1,1))
9400             vv(1)=pizda(1,1)-pizda(2,2)
9401             vv(2)=pizda(2,1)+pizda(1,2)
9402             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9403             if (swap) then
9404               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9405 #ifdef MOMENT
9406                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9407      &             -(s1+s2+s4)
9408 #else
9409                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9410      &             -(s2+s4)
9411 #endif
9412                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9413               else
9414 #ifdef MOMENT
9415                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9416 #else
9417                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9418 #endif
9419                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9420               endif
9421             else
9422 #ifdef MOMENT
9423               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9424 #else
9425               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9426 #endif
9427               if (l.eq.j+1) then
9428                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9429               else
9430                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9431               endif
9432             endif
9433           enddo
9434         enddo
9435       enddo
9436       return
9437       end
9438 c----------------------------------------------------------------------------
9439       double precision function eello_turn6(i,jj,kk)
9440       implicit real*8 (a-h,o-z)
9441       include 'DIMENSIONS'
9442       include 'COMMON.IOUNITS'
9443       include 'COMMON.CHAIN'
9444       include 'COMMON.DERIV'
9445       include 'COMMON.INTERACT'
9446       include 'COMMON.CONTACTS'
9447       include 'COMMON.TORSION'
9448       include 'COMMON.VAR'
9449       include 'COMMON.GEO'
9450       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9451      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9452      &  ggg1(3),ggg2(3)
9453       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9454      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9455 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9456 C           the respective energy moment and not to the cluster cumulant.
9457       s1=0.0d0
9458       s8=0.0d0
9459       s13=0.0d0
9460 c
9461       eello_turn6=0.0d0
9462       j=i+4
9463       k=i+1
9464       l=i+3
9465       iti=itortyp(itype(i))
9466       itk=itortyp(itype(k))
9467       itk1=itortyp(itype(k+1))
9468       itl=itortyp(itype(l))
9469       itj=itortyp(itype(j))
9470 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9471 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9472 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9473 cd        eello6=0.0d0
9474 cd        return
9475 cd      endif
9476 cd      write (iout,*)
9477 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9478 cd     &   ' and',k,l
9479 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9480       do iii=1,2
9481         do kkk=1,5
9482           do lll=1,3
9483             derx_turn(lll,kkk,iii)=0.0d0
9484           enddo
9485         enddo
9486       enddo
9487 cd      eij=1.0d0
9488 cd      ekl=1.0d0
9489 cd      ekont=1.0d0
9490       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9491 cd      eello6_5=0.0d0
9492 cd      write (2,*) 'eello6_5',eello6_5
9493 #ifdef MOMENT
9494       call transpose2(AEA(1,1,1),auxmat(1,1))
9495       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9496       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9497       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9498 #endif
9499       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9500       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9501       s2 = scalar2(b1(1,k),vtemp1(1))
9502 #ifdef MOMENT
9503       call transpose2(AEA(1,1,2),atemp(1,1))
9504       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9505       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9506       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9507 #endif
9508       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9509       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9510       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9511 #ifdef MOMENT
9512       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9513       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9514       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9515       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9516       ss13 = scalar2(b1(1,k),vtemp4(1))
9517       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9518 #endif
9519 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9520 c      s1=0.0d0
9521 c      s2=0.0d0
9522 c      s8=0.0d0
9523 c      s12=0.0d0
9524 c      s13=0.0d0
9525       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9526 C Derivatives in gamma(i+2)
9527       s1d =0.0d0
9528       s8d =0.0d0
9529 #ifdef MOMENT
9530       call transpose2(AEA(1,1,1),auxmatd(1,1))
9531       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9532       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9533       call transpose2(AEAderg(1,1,2),atempd(1,1))
9534       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9535       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9536 #endif
9537       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9538       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9539       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9540 c      s1d=0.0d0
9541 c      s2d=0.0d0
9542 c      s8d=0.0d0
9543 c      s12d=0.0d0
9544 c      s13d=0.0d0
9545       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9546 C Derivatives in gamma(i+3)
9547 #ifdef MOMENT
9548       call transpose2(AEA(1,1,1),auxmatd(1,1))
9549       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9550       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9551       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9552 #endif
9553       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9554       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9555       s2d = scalar2(b1(1,k),vtemp1d(1))
9556 #ifdef MOMENT
9557       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9558       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9559 #endif
9560       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9561 #ifdef MOMENT
9562       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9563       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9564       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9565 #endif
9566 c      s1d=0.0d0
9567 c      s2d=0.0d0
9568 c      s8d=0.0d0
9569 c      s12d=0.0d0
9570 c      s13d=0.0d0
9571 #ifdef MOMENT
9572       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9573      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9574 #else
9575       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9576      &               -0.5d0*ekont*(s2d+s12d)
9577 #endif
9578 C Derivatives in gamma(i+4)
9579       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9580       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9581       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9582 #ifdef MOMENT
9583       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9584       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9585       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9586 #endif
9587 c      s1d=0.0d0
9588 c      s2d=0.0d0
9589 c      s8d=0.0d0
9590 C      s12d=0.0d0
9591 c      s13d=0.0d0
9592 #ifdef MOMENT
9593       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9594 #else
9595       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9596 #endif
9597 C Derivatives in gamma(i+5)
9598 #ifdef MOMENT
9599       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9600       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9601       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9602 #endif
9603       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9604       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9605       s2d = scalar2(b1(1,k),vtemp1d(1))
9606 #ifdef MOMENT
9607       call transpose2(AEA(1,1,2),atempd(1,1))
9608       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9609       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9610 #endif
9611       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9612       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9613 #ifdef MOMENT
9614       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9615       ss13d = scalar2(b1(1,k),vtemp4d(1))
9616       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9617 #endif
9618 c      s1d=0.0d0
9619 c      s2d=0.0d0
9620 c      s8d=0.0d0
9621 c      s12d=0.0d0
9622 c      s13d=0.0d0
9623 #ifdef MOMENT
9624       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9625      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9626 #else
9627       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9628      &               -0.5d0*ekont*(s2d+s12d)
9629 #endif
9630 C Cartesian derivatives
9631       do iii=1,2
9632         do kkk=1,5
9633           do lll=1,3
9634 #ifdef MOMENT
9635             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9636             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9637             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9638 #endif
9639             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9640             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9641      &          vtemp1d(1))
9642             s2d = scalar2(b1(1,k),vtemp1d(1))
9643 #ifdef MOMENT
9644             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9645             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9646             s8d = -(atempd(1,1)+atempd(2,2))*
9647      &           scalar2(cc(1,1,itl),vtemp2(1))
9648 #endif
9649             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9650      &           auxmatd(1,1))
9651             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9652             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9653 c      s1d=0.0d0
9654 c      s2d=0.0d0
9655 c      s8d=0.0d0
9656 c      s12d=0.0d0
9657 c      s13d=0.0d0
9658 #ifdef MOMENT
9659             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9660      &        - 0.5d0*(s1d+s2d)
9661 #else
9662             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9663      &        - 0.5d0*s2d
9664 #endif
9665 #ifdef MOMENT
9666             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9667      &        - 0.5d0*(s8d+s12d)
9668 #else
9669             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9670      &        - 0.5d0*s12d
9671 #endif
9672           enddo
9673         enddo
9674       enddo
9675 #ifdef MOMENT
9676       do kkk=1,5
9677         do lll=1,3
9678           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9679      &      achuj_tempd(1,1))
9680           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9681           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9682           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9683           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9684           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9685      &      vtemp4d(1))
9686           ss13d = scalar2(b1(1,k),vtemp4d(1))
9687           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9688           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9689         enddo
9690       enddo
9691 #endif
9692 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9693 cd     &  16*eel_turn6_num
9694 cd      goto 1112
9695       if (j.lt.nres-1) then
9696         j1=j+1
9697         j2=j-1
9698       else
9699         j1=j-1
9700         j2=j-2
9701       endif
9702       if (l.lt.nres-1) then
9703         l1=l+1
9704         l2=l-1
9705       else
9706         l1=l-1
9707         l2=l-2
9708       endif
9709       do ll=1,3
9710 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9711 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9712 cgrad        ghalf=0.5d0*ggg1(ll)
9713 cd        ghalf=0.0d0
9714         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9715         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9716         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9717      &    +ekont*derx_turn(ll,2,1)
9718         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9719         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9720      &    +ekont*derx_turn(ll,4,1)
9721         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9722         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9723         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9724 cgrad        ghalf=0.5d0*ggg2(ll)
9725 cd        ghalf=0.0d0
9726         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9727      &    +ekont*derx_turn(ll,2,2)
9728         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9729         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9730      &    +ekont*derx_turn(ll,4,2)
9731         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9732         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9733         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9734       enddo
9735 cd      goto 1112
9736 cgrad      do m=i+1,j-1
9737 cgrad        do ll=1,3
9738 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9739 cgrad        enddo
9740 cgrad      enddo
9741 cgrad      do m=k+1,l-1
9742 cgrad        do ll=1,3
9743 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9744 cgrad        enddo
9745 cgrad      enddo
9746 cgrad1112  continue
9747 cgrad      do m=i+2,j2
9748 cgrad        do ll=1,3
9749 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9750 cgrad        enddo
9751 cgrad      enddo
9752 cgrad      do m=k+2,l2
9753 cgrad        do ll=1,3
9754 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9755 cgrad        enddo
9756 cgrad      enddo
9757 cd      do iii=1,nres-3
9758 cd        write (2,*) iii,g_corr6_loc(iii)
9759 cd      enddo
9760       eello_turn6=ekont*eel_turn6
9761 cd      write (2,*) 'ekont',ekont
9762 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9763       return
9764       end
9765
9766 C-----------------------------------------------------------------------------
9767       double precision function scalar(u,v)
9768 !DIR$ INLINEALWAYS scalar
9769 #ifndef OSF
9770 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9771 #endif
9772       implicit none
9773       double precision u(3),v(3)
9774 cd      double precision sc
9775 cd      integer i
9776 cd      sc=0.0d0
9777 cd      do i=1,3
9778 cd        sc=sc+u(i)*v(i)
9779 cd      enddo
9780 cd      scalar=sc
9781
9782       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9783       return
9784       end
9785 crc-------------------------------------------------
9786       SUBROUTINE MATVEC2(A1,V1,V2)
9787 !DIR$ INLINEALWAYS MATVEC2
9788 #ifndef OSF
9789 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9790 #endif
9791       implicit real*8 (a-h,o-z)
9792       include 'DIMENSIONS'
9793       DIMENSION A1(2,2),V1(2),V2(2)
9794 c      DO 1 I=1,2
9795 c        VI=0.0
9796 c        DO 3 K=1,2
9797 c    3     VI=VI+A1(I,K)*V1(K)
9798 c        Vaux(I)=VI
9799 c    1 CONTINUE
9800
9801       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9802       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9803
9804       v2(1)=vaux1
9805       v2(2)=vaux2
9806       END
9807 C---------------------------------------
9808       SUBROUTINE MATMAT2(A1,A2,A3)
9809 #ifndef OSF
9810 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9811 #endif
9812       implicit real*8 (a-h,o-z)
9813       include 'DIMENSIONS'
9814       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9815 c      DIMENSION AI3(2,2)
9816 c        DO  J=1,2
9817 c          A3IJ=0.0
9818 c          DO K=1,2
9819 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9820 c          enddo
9821 c          A3(I,J)=A3IJ
9822 c       enddo
9823 c      enddo
9824
9825       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9826       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9827       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9828       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9829
9830       A3(1,1)=AI3_11
9831       A3(2,1)=AI3_21
9832       A3(1,2)=AI3_12
9833       A3(2,2)=AI3_22
9834       END
9835
9836 c-------------------------------------------------------------------------
9837       double precision function scalar2(u,v)
9838 !DIR$ INLINEALWAYS scalar2
9839       implicit none
9840       double precision u(2),v(2)
9841       double precision sc
9842       integer i
9843       scalar2=u(1)*v(1)+u(2)*v(2)
9844       return
9845       end
9846
9847 C-----------------------------------------------------------------------------
9848
9849       subroutine transpose2(a,at)
9850 !DIR$ INLINEALWAYS transpose2
9851 #ifndef OSF
9852 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9853 #endif
9854       implicit none
9855       double precision a(2,2),at(2,2)
9856       at(1,1)=a(1,1)
9857       at(1,2)=a(2,1)
9858       at(2,1)=a(1,2)
9859       at(2,2)=a(2,2)
9860       return
9861       end
9862 c--------------------------------------------------------------------------
9863       subroutine transpose(n,a,at)
9864       implicit none
9865       integer n,i,j
9866       double precision a(n,n),at(n,n)
9867       do i=1,n
9868         do j=1,n
9869           at(j,i)=a(i,j)
9870         enddo
9871       enddo
9872       return
9873       end
9874 C---------------------------------------------------------------------------
9875       subroutine prodmat3(a1,a2,kk,transp,prod)
9876 !DIR$ INLINEALWAYS prodmat3
9877 #ifndef OSF
9878 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9879 #endif
9880       implicit none
9881       integer i,j
9882       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9883       logical transp
9884 crc      double precision auxmat(2,2),prod_(2,2)
9885
9886       if (transp) then
9887 crc        call transpose2(kk(1,1),auxmat(1,1))
9888 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9889 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9890
9891            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9892      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9893            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9894      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9895            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9896      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9897            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9898      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9899
9900       else
9901 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9902 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9903
9904            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9905      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9906            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9907      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9908            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9909      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9910            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9911      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9912
9913       endif
9914 c      call transpose2(a2(1,1),a2t(1,1))
9915
9916 crc      print *,transp
9917 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9918 crc      print *,((prod(i,j),i=1,2),j=1,2)
9919
9920       return
9921       end
9922