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 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.gt.0) then
 146        call set_shield_fac
 147       endif
 148 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 149       if (ipot.lt.6) then
 150 #ifdef SPLITELE
 151          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 152      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 153      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 154      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 155 #else
 156          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 157      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 158      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 159      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 160 #endif
 161             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 162          else
 163             ees=0.0d0
 164             evdw1=0.0d0
 165             eel_loc=0.0d0
 166             eello_turn3=0.0d0
 167             eello_turn4=0.0d0
 168          endif
 169       else
 170         write (iout,*) "Soft-spheer ELEC potential"
 171 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 172 c     &   eello_turn4)
 173       endif
 174 c      print *,"Processor",myrank," computed UELEC"
 175 C
 176 C Calculate excluded-volume interaction energy between peptide groups
 177 C and side chains.
 178 C
 179       if (ipot.lt.6) then
 180        if(wscp.gt.0d0) then
 181         call escp(evdw2,evdw2_14)
 182        else
 183         evdw2=0
 184         evdw2_14=0
 185        endif
 186       else
 187 c        write (iout,*) "Soft-sphere SCP potential"
 188         call escp_soft_sphere(evdw2,evdw2_14)
 189       endif
 190 c
 191 c Calculate the bond-stretching energy
 192 c
 193       call ebond(estr)
 194 C
 195 C Calculate the disulfide-bridge and other energy and the contributions
 196 C from other distance constraints.
 197 cd    print *,'Calling EHPB'
 198       call edis(ehpb)
 199 cd    print *,'EHPB exitted succesfully.'
 200 C
 201 C Calculate the virtual-bond-angle energy.
 202 C
 203       if (wang.gt.0d0) then
 204         call ebend(ebe,ethetacnstr)
 205       else
 206         ebe=0
 207         ethetacnstr=0
 208       endif
 209 c      print *,"Processor",myrank," computed UB"
 210 C
 211 C Calculate the SC local energy.
 212 C
 213 C      print *,"TU DOCHODZE?"
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 C      print *,"PRZED MULIt"
 245 c      print *,"Processor",myrank," computed Usccorr"
 246 C
 247 C 12/1/95 Multi-body terms
 248 C
 249       n_corr=0
 250       n_corr1=0
 251       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 252      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 253          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 254 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 255 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 256       else
 257          ecorr=0.0d0
 258          ecorr5=0.0d0
 259          ecorr6=0.0d0
 260          eturn6=0.0d0
 261       endif
 262       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 263          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 264 cd         write (iout,*) "multibody_hb ecorr",ecorr
 265       endif
 266 c      print *,"Processor",myrank," computed Ucorr"
 267 C
 268 C If performing constraint dynamics, call the constraint energy
 269 C  after the equilibration time
 270       if(usampl.and.totT.gt.eq_time) then
 271          call EconstrQ
 272          call Econstr_back
 273       else
 274          Uconst=0.0d0
 275          Uconst_back=0.0d0
 276       endif
 277 C 01/27/2015 added by adasko
 278 C the energy component below is energy transfer into lipid environment
 279 C based on partition function
 280 C      print *,"przed lipidami"
 281       if (wliptran.gt.0) then
 282         call Eliptransfer(eliptran)
 283       endif
 284 C      print *,"za lipidami"
 285       if (AFMlog.gt.0) then
 286         call AFMforce(Eafmforce)
 287       else if (selfguide.gt.0) then
 288         call AFMvel(Eafmforce)
 289       endif
 290 #ifdef TIMING
 291       time_enecalc=time_enecalc+MPI_Wtime()-time00
 292 #endif
 293 c      print *,"Processor",myrank," computed Uconstr"
 294 #ifdef TIMING
 295       time00=MPI_Wtime()
 296 #endif
 297 c
 298 C Sum the energies
 299 C
 300       energia(1)=evdw
 301 #ifdef SCP14
 302       energia(2)=evdw2-evdw2_14
 303       energia(18)=evdw2_14
 304 #else
 305       energia(2)=evdw2
 306       energia(18)=0.0d0
 307 #endif
 308 #ifdef SPLITELE
 309       energia(3)=ees
 310       energia(16)=evdw1
 311 #else
 312       energia(3)=ees+evdw1
 313       energia(16)=0.0d0
 314 #endif
 315       energia(4)=ecorr
 316       energia(5)=ecorr5
 317       energia(6)=ecorr6
 318       energia(7)=eel_loc
 319       energia(8)=eello_turn3
 320       energia(9)=eello_turn4
 321       energia(10)=eturn6
 322       energia(11)=ebe
 323       energia(12)=escloc
 324       energia(13)=etors
 325       energia(14)=etors_d
 326       energia(15)=ehpb
 327       energia(19)=edihcnstr
 328       energia(17)=estr
 329       energia(20)=Uconst+Uconst_back
 330       energia(21)=esccor
 331       energia(22)=eliptran
 332       energia(23)=Eafmforce
 333       energia(24)=ethetacnstr
 334 c    Here are the energies showed per procesor if the are more processors
 335 c    per molecule then we sum it up in sum_energy subroutine
 336 c      print *," Processor",myrank," calls SUM_ENERGY"
 337       call sum_energy(energia,.true.)
 338       if (dyn_ss) call dyn_set_nss
 339 c      print *," Processor",myrank," left SUM_ENERGY"
 340 #ifdef TIMING
 341       time_sumene=time_sumene+MPI_Wtime()-time00
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395       evdw=energia(1)
 396 #ifdef SCP14
 397       evdw2=energia(2)+energia(18)
 398       evdw2_14=energia(18)
 399 #else
 400       evdw2=energia(2)
 401 #endif
 402 #ifdef SPLITELE
 403       ees=energia(3)
 404       evdw1=energia(16)
 405 #else
 406       ees=energia(3)
 407       evdw1=0.0d0
 408 #endif
 409       ecorr=energia(4)
 410       ecorr5=energia(5)
 411       ecorr6=energia(6)
 412       eel_loc=energia(7)
 413       eello_turn3=energia(8)
 414       eello_turn4=energia(9)
 415       eturn6=energia(10)
 416       ebe=energia(11)
 417       escloc=energia(12)
 418       etors=energia(13)
 419       etors_d=energia(14)
 420       ehpb=energia(15)
 421       edihcnstr=energia(19)
 422       estr=energia(17)
 423       Uconst=energia(20)
 424       esccor=energia(21)
 425       eliptran=energia(22)
 426       Eafmforce=energia(23)
 427       ethetacnstr=energia(24)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 435      & +ethetacnstr
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 443      & +Eafmforce
 444      & +ethetacnstr
 445 #endif
 446       energia(0)=etot
 447 c detecting NaNQ
 448 #ifdef ISNAN
 449 #ifdef AIX
 450       if (isnan(etot).ne.0) energia(0)=1.0d+99
 451 #else
 452       if (isnan(etot)) energia(0)=1.0d+99
 453 #endif
 454 #else
 455       i=0
 456 #ifdef WINPGI
 457       idumm=proc_proc(etot,i)
 458 #else
 459       call proc_proc(etot,i)
 460 #endif
 461       if(i.eq.1)energia(0)=1.0d+99
 462 #endif
 463 #ifdef MPI
 464       endif
 465 #endif
 466       return
 467       end
 468 c-------------------------------------------------------------------------------
 469       subroutine sum_gradient
 470       implicit real*8 (a-h,o-z)
 471       include 'DIMENSIONS'
 472 #ifndef ISNAN
 473       external proc_proc
 474 #ifdef WINPGI
 475 cMS$ATTRIBUTES C ::  proc_proc
 476 #endif
 477 #endif
 478 #ifdef MPI
 479       include 'mpif.h'
 480 #endif
 481       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 482      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 483      & ,gloc_scbuf(3,-1:maxres)
 484       include 'COMMON.SETUP'
 485       include 'COMMON.IOUNITS'
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       include 'COMMON.MAXGRAD'
 495       include 'COMMON.SCCOR'
 496 #ifdef TIMING
 497       time01=MPI_Wtime()
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 504       enddo
 505       call flush(iout)
 506 #endif
 507 #ifdef MPI
 508 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 509         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 510      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 511 #endif
 512 C
 513 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 514 C            in virtual-bond-vector coordinates
 515 C
 516 #ifdef DEBUG
 517 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 520 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 521 c      enddo
 522 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 523 c      do i=1,nres-1
 524 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 525 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 526 c      enddo
 527       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 528       do i=1,nres
 529         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 530      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 531      &   g_corr5_loc(i)
 532       enddo
 533       call flush(iout)
 534 #endif
 535 #ifdef SPLITELE
 536       do i=0,nct
 537         do j=1,3
 538           gradbufc(j,i)=wsc*gvdwc(j,i)+
 539      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 540      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 541      &                wel_loc*gel_loc_long(j,i)+
 542      &                wcorr*gradcorr_long(j,i)+
 543      &                wcorr5*gradcorr5_long(j,i)+
 544      &                wcorr6*gradcorr6_long(j,i)+
 545      &                wturn6*gcorr6_turn_long(j,i)+
 546      &                wstrain*ghpbc(j,i)
 547      &                +wliptran*gliptranc(j,i)
 548      &                +gradafm(j,i)
 549      &                 +welec*gshieldc(j,i)
 550
 551         enddo
 552       enddo
 553 #else
 554       do i=0,nct
 555         do j=1,3
 556           gradbufc(j,i)=wsc*gvdwc(j,i)+
 557      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 558      &                welec*gelc_long(j,i)+
 559      &                wbond*gradb(j,i)+
 560      &                wel_loc*gel_loc_long(j,i)+
 561      &                wcorr*gradcorr_long(j,i)+
 562      &                wcorr5*gradcorr5_long(j,i)+
 563      &                wcorr6*gradcorr6_long(j,i)+
 564      &                wturn6*gcorr6_turn_long(j,i)+
 565      &                wstrain*ghpbc(j,i)
 566      &                +wliptran*gliptranc(j,i)
 567      &                +gradafm(j,i)
 568      &                 +welec*gshieldc(j,i)
 569
 570         enddo
 571       enddo
 572 #endif
 573 #ifdef MPI
 574       if (nfgtasks.gt.1) then
 575       time00=MPI_Wtime()
 576 #ifdef DEBUG
 577       write (iout,*) "gradbufc before allreduce"
 578       do i=1,nres
 579         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 580       enddo
 581       call flush(iout)
 582 #endif
 583       do i=0,nres
 584         do j=1,3
 585           gradbufc_sum(j,i)=gradbufc(j,i)
 586         enddo
 587       enddo
 588 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 589 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 590 c      time_reduce=time_reduce+MPI_Wtime()-time00
 591 #ifdef DEBUG
 592 c      write (iout,*) "gradbufc_sum after allreduce"
 593 c      do i=1,nres
 594 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 595 c      enddo
 596 c      call flush(iout)
 597 #endif
 598 #ifdef TIMING
 599 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 600 #endif
 601       do i=nnt,nres
 602         do k=1,3
 603           gradbufc(k,i)=0.0d0
 604         enddo
 605       enddo
 606 #ifdef DEBUG
 607       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 608       write (iout,*) (i," jgrad_start",jgrad_start(i),
 609      &                  " jgrad_end  ",jgrad_end(i),
 610      &                  i=igrad_start,igrad_end)
 611 #endif
 612 c
 613 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 614 c do not parallelize this part.
 615 c
 616 c      do i=igrad_start,igrad_end
 617 c        do j=jgrad_start(i),jgrad_end(i)
 618 c          do k=1,3
 619 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 620 c          enddo
 621 c        enddo
 622 c      enddo
 623       do j=1,3
 624         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 625       enddo
 626       do i=nres-2,-1,-1
 627         do j=1,3
 628           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 629         enddo
 630       enddo
 631 #ifdef DEBUG
 632       write (iout,*) "gradbufc after summing"
 633       do i=1,nres
 634         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 635       enddo
 636       call flush(iout)
 637 #endif
 638       else
 639 #endif
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       do i=-1,nres
 648         do j=1,3
 649           gradbufc_sum(j,i)=gradbufc(j,i)
 650           gradbufc(j,i)=0.0d0
 651         enddo
 652       enddo
 653       do j=1,3
 654         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 655       enddo
 656       do i=nres-2,-1,-1
 657         do j=1,3
 658           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 659         enddo
 660       enddo
 661 c      do i=nnt,nres-1
 662 c        do k=1,3
 663 c          gradbufc(k,i)=0.0d0
 664 c        enddo
 665 c        do j=i+1,nres
 666 c          do k=1,3
 667 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 668 c          enddo
 669 c        enddo
 670 c      enddo
 671 #ifdef DEBUG
 672       write (iout,*) "gradbufc after summing"
 673       do i=1,nres
 674         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 675       enddo
 676       call flush(iout)
 677 #endif
 678 #ifdef MPI
 679       endif
 680 #endif
 681       do k=1,3
 682         gradbufc(k,nres)=0.0d0
 683       enddo
 684       do i=-1,nct
 685         do j=1,3
 686 #ifdef SPLITELE
 687 C          print *,gradbufc(1,13)
 688 C          print *,welec*gelc(1,13)
 689 C          print *,wel_loc*gel_loc(1,13)
 690 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 691 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 692 C          print *,wel_loc*gel_loc_long(1,13)
 693 C          print *,gradafm(1,13),"AFM"
 694           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 695      &                wel_loc*gel_loc(j,i)+
 696      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 697      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 698      &                wel_loc*gel_loc_long(j,i)+
 699      &                wcorr*gradcorr_long(j,i)+
 700      &                wcorr5*gradcorr5_long(j,i)+
 701      &                wcorr6*gradcorr6_long(j,i)+
 702      &                wturn6*gcorr6_turn_long(j,i))+
 703      &                wbond*gradb(j,i)+
 704      &                wcorr*gradcorr(j,i)+
 705      &                wturn3*gcorr3_turn(j,i)+
 706      &                wturn4*gcorr4_turn(j,i)+
 707      &                wcorr5*gradcorr5(j,i)+
 708      &                wcorr6*gradcorr6(j,i)+
 709      &                wturn6*gcorr6_turn(j,i)+
 710      &                wsccor*gsccorc(j,i)
 711      &               +wscloc*gscloc(j,i)
 712      &               +wliptran*gliptranc(j,i)
 713      &                +gradafm(j,i)
 714      &                 +welec*gshieldc(j,i)
 715      &                 +welec*gshieldc_loc(j,i)
 716
 717
 718 #else
 719           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 720      &                wel_loc*gel_loc(j,i)+
 721      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 722      &                welec*gelc_long(j,i)
 723      &                wel_loc*gel_loc_long(j,i)+
 724      &                wcorr*gcorr_long(j,i)+
 725      &                wcorr5*gradcorr5_long(j,i)+
 726      &                wcorr6*gradcorr6_long(j,i)+
 727      &                wturn6*gcorr6_turn_long(j,i))+
 728      &                wbond*gradb(j,i)+
 729      &                wcorr*gradcorr(j,i)+
 730      &                wturn3*gcorr3_turn(j,i)+
 731      &                wturn4*gcorr4_turn(j,i)+
 732      &                wcorr5*gradcorr5(j,i)+
 733      &                wcorr6*gradcorr6(j,i)+
 734      &                wturn6*gcorr6_turn(j,i)+
 735      &                wsccor*gsccorc(j,i)
 736      &               +wscloc*gscloc(j,i)
 737      &               +wliptran*gliptranc(j,i)
 738      &                +gradafm(j,i)
 739      &                 +welec*gshieldc(j,i)
 740      &                 +welec*gshieldc_loc(j,i)
 741
 742
 743 #endif
 744           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 745      &                  wbond*gradbx(j,i)+
 746      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 747      &                  wsccor*gsccorx(j,i)
 748      &                 +wscloc*gsclocx(j,i)
 749      &                 +wliptran*gliptranx(j,i)
 750      &                 +welec*gshieldx(j,i)
 751         enddo
 752       enddo
 753 #ifdef DEBUG
 754       write (iout,*) "gloc before adding corr"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       do i=1,nres-3
 760         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 761      &   +wcorr5*g_corr5_loc(i)
 762      &   +wcorr6*g_corr6_loc(i)
 763      &   +wturn4*gel_loc_turn4(i)
 764      &   +wturn3*gel_loc_turn3(i)
 765      &   +wturn6*gel_loc_turn6(i)
 766      &   +wel_loc*gel_loc_loc(i)
 767       enddo
 768 #ifdef DEBUG
 769       write (iout,*) "gloc after adding corr"
 770       do i=1,4*nres
 771         write (iout,*) i,gloc(i,icg)
 772       enddo
 773 #endif
 774 #ifdef MPI
 775       if (nfgtasks.gt.1) then
 776         do j=1,3
 777           do i=1,nres
 778             gradbufc(j,i)=gradc(j,i,icg)
 779             gradbufx(j,i)=gradx(j,i,icg)
 780           enddo
 781         enddo
 782         do i=1,4*nres
 783           glocbuf(i)=gloc(i,icg)
 784         enddo
 785 c#define DEBUG
 786 #ifdef DEBUG
 787       write (iout,*) "gloc_sc before reduce"
 788       do i=1,nres
 789        do j=1,1
 790         write (iout,*) i,j,gloc_sc(j,i,icg)
 791        enddo
 792       enddo
 793 #endif
 794 c#undef DEBUG
 795         do i=1,nres
 796          do j=1,3
 797           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 798          enddo
 799         enddo
 800         time00=MPI_Wtime()
 801         call MPI_Barrier(FG_COMM,IERR)
 802         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 803         time00=MPI_Wtime()
 804         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 805      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 806         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 809      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 810         time_reduce=time_reduce+MPI_Wtime()-time00
 811         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 812      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 813         time_reduce=time_reduce+MPI_Wtime()-time00
 814 c#define DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc_sc after reduce"
 817       do i=1,nres
 818        do j=1,1
 819         write (iout,*) i,j,gloc_sc(j,i,icg)
 820        enddo
 821       enddo
 822 #endif
 823 c#undef DEBUG
 824 #ifdef DEBUG
 825       write (iout,*) "gloc after reduce"
 826       do i=1,4*nres
 827         write (iout,*) i,gloc(i,icg)
 828       enddo
 829 #endif
 830       endif
 831 #endif
 832       if (gnorm_check) then
 833 c
 834 c Compute the maximum elements of the gradient
 835 c
 836       gvdwc_max=0.0d0
 837       gvdwc_scp_max=0.0d0
 838       gelc_max=0.0d0
 839       gvdwpp_max=0.0d0
 840       gradb_max=0.0d0
 841       ghpbc_max=0.0d0
 842       gradcorr_max=0.0d0
 843       gel_loc_max=0.0d0
 844       gcorr3_turn_max=0.0d0
 845       gcorr4_turn_max=0.0d0
 846       gradcorr5_max=0.0d0
 847       gradcorr6_max=0.0d0
 848       gcorr6_turn_max=0.0d0
 849       gsccorc_max=0.0d0
 850       gscloc_max=0.0d0
 851       gvdwx_max=0.0d0
 852       gradx_scp_max=0.0d0
 853       ghpbx_max=0.0d0
 854       gradxorr_max=0.0d0
 855       gsccorx_max=0.0d0
 856       gsclocx_max=0.0d0
 857       do i=1,nct
 858         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 859         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 860         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 861         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 862      &   gvdwc_scp_max=gvdwc_scp_norm
 863         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 864         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 865         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 866         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 867         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 868         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 869         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 870         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 871         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 872         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 873         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 874         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 875         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 876      &    gcorr3_turn(1,i)))
 877         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 878      &    gcorr3_turn_max=gcorr3_turn_norm
 879         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 880      &    gcorr4_turn(1,i)))
 881         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 882      &    gcorr4_turn_max=gcorr4_turn_norm
 883         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 884         if (gradcorr5_norm.gt.gradcorr5_max)
 885      &    gradcorr5_max=gradcorr5_norm
 886         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 887         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 888         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 889      &    gcorr6_turn(1,i)))
 890         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 891      &    gcorr6_turn_max=gcorr6_turn_norm
 892         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 893         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 894         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 895         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 896         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #endif
 944       return
 945       end
 946 c-------------------------------------------------------------------------------
 947       subroutine rescale_weights(t_bath)
 948       implicit real*8 (a-h,o-z)
 949       include 'DIMENSIONS'
 950       include 'COMMON.IOUNITS'
 951       include 'COMMON.FFIELD'
 952       include 'COMMON.SBRIDGE'
 953       double precision kfac /2.4d0/
 954       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 955 c      facT=temp0/t_bath
 956 c      facT=2*temp0/(t_bath+temp0)
 957       if (rescale_mode.eq.0) then
 958         facT=1.0d0
 959         facT2=1.0d0
 960         facT3=1.0d0
 961         facT4=1.0d0
 962         facT5=1.0d0
 963       else if (rescale_mode.eq.1) then
 964         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 965         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 966         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 967         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 968         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 969       else if (rescale_mode.eq.2) then
 970         x=t_bath/temp0
 971         x2=x*x
 972         x3=x2*x
 973         x4=x3*x
 974         x5=x4*x
 975         facT=licznik/dlog(dexp(x)+dexp(-x))
 976         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 977         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 978         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 979         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 980       else
 981         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 982         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 983 #ifdef MPI
 984        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 985 #endif
 986        stop 555
 987       endif
 988       welec=weights(3)*fact
 989       wcorr=weights(4)*fact3
 990       wcorr5=weights(5)*fact4
 991       wcorr6=weights(6)*fact5
 992       wel_loc=weights(7)*fact2
 993       wturn3=weights(8)*fact2
 994       wturn4=weights(9)*fact3
 995       wturn6=weights(10)*fact5
 996       wtor=weights(13)*fact
 997       wtor_d=weights(14)*fact2
 998       wsccor=weights(21)*fact
 999
1000       return
1001       end
1002 C------------------------------------------------------------------------
1003       subroutine enerprint(energia)
1004       implicit real*8 (a-h,o-z)
1005       include 'DIMENSIONS'
1006       include 'COMMON.IOUNITS'
1007       include 'COMMON.FFIELD'
1008       include 'COMMON.SBRIDGE'
1009       include 'COMMON.MD'
1010       double precision energia(0:n_ene)
1011       etot=energia(0)
1012       evdw=energia(1)
1013       evdw2=energia(2)
1014 #ifdef SCP14
1015       evdw2=energia(2)+energia(18)
1016 #else
1017       evdw2=energia(2)
1018 #endif
1019       ees=energia(3)
1020 #ifdef SPLITELE
1021       evdw1=energia(16)
1022 #endif
1023       ecorr=energia(4)
1024       ecorr5=energia(5)
1025       ecorr6=energia(6)
1026       eel_loc=energia(7)
1027       eello_turn3=energia(8)
1028       eello_turn4=energia(9)
1029       eello_turn6=energia(10)
1030       ebe=energia(11)
1031       escloc=energia(12)
1032       etors=energia(13)
1033       etors_d=energia(14)
1034       ehpb=energia(15)
1035       edihcnstr=energia(19)
1036       estr=energia(17)
1037       Uconst=energia(20)
1038       esccor=energia(21)
1039       eliptran=energia(22)
1040       Eafmforce=energia(23)
1041       ethetacnstr=energia(24)
1042 #ifdef SPLITELE
1043       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1044      &  estr,wbond,ebe,wang,
1045      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1046      &  ecorr,wcorr,
1047      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1048      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1049      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1050      &  etot
1051    10 format (/'Virtual-chain energies:'//
1052      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1053      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1054      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1055      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1056      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1057      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1058      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1059      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1060      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1061      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1062      & ' (SS bridges & dist. cnstr.)'/
1063      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1064      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1065      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1066      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1067      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1068      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1069      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1070      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1071      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1072      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1073      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1074      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1075      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1076      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1077      & 'ETOT=  ',1pE16.6,' (total)')
1078
1079 #else
1080       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1081      &  estr,wbond,ebe,wang,
1082      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1083      &  ecorr,wcorr,
1084      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1085      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1086      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1087      &  etot
1088    10 format (/'Virtual-chain energies:'//
1089      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1090      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1091      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1092      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1093      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1094      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1095      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1096      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1097      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1098      & ' (SS bridges & dist. cnstr.)'/
1099      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1100      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1101      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1103      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1104      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1105      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1106      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1107      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1108      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1109      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1110      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1111      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1112      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=iabs(itype(i))
1142         if (itypi.eq.ntyp1) cycle
1143         itypi1=iabs(itype(i+1))
1144         xi=c(1,nres+i)
1145         yi=c(2,nres+i)
1146         zi=c(3,nres+i)
1147 C Change 12/1/95
1148         num_conti=0
1149 C
1150 C Calculate SC interaction energy.
1151 C
1152         do iint=1,nint_gr(i)
1153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1154 cd   &                  'iend=',iend(i,iint)
1155           do j=istart(i,iint),iend(i,iint)
1156             itypj=iabs(itype(j))
1157             if (itypj.eq.ntyp1) cycle
1158             xj=c(1,nres+j)-xi
1159             yj=c(2,nres+j)-yi
1160             zj=c(3,nres+j)-zi
1161 C Change 12/1/95 to calculate four-body interactions
1162             rij=xj*xj+yj*yj+zj*zj
1163             rrij=1.0D0/rij
1164 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1165             eps0ij=eps(itypi,itypj)
1166             fac=rrij**expon2
1167 C have you changed here?
1168             e1=fac*fac*aa
1169             e2=fac*bb
1170             evdwij=e1+e2
1171 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1172 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1173 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1174 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1175 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1176 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1177             evdw=evdw+evdwij
1178 C
1179 C Calculate the components of the gradient in DC and X
1180 C
1181             fac=-rrij*(e1+evdwij)
1182             gg(1)=xj*fac
1183             gg(2)=yj*fac
1184             gg(3)=zj*fac
1185             do k=1,3
1186               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1187               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1188               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1189               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1190             enddo
1191 cgrad            do k=i,j-1
1192 cgrad              do l=1,3
1193 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1194 cgrad              enddo
1195 cgrad            enddo
1196 C
1197 C 12/1/95, revised on 5/20/97
1198 C
1199 C Calculate the contact function. The ith column of the array JCONT will
1200 C contain the numbers of atoms that make contacts with the atom I (of numbers
1201 C greater than I). The arrays FACONT and GACONT will contain the values of
1202 C the contact function and its derivative.
1203 C
1204 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1205 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1206 C Uncomment next line, if the correlation interactions are contact function only
1207             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1208               rij=dsqrt(rij)
1209               sigij=sigma(itypi,itypj)
1210               r0ij=rs0(itypi,itypj)
1211 C
1212 C Check whether the SC's are not too far to make a contact.
1213 C
1214               rcut=1.5d0*r0ij
1215               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1216 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1217 C
1218               if (fcont.gt.0.0D0) then
1219 C If the SC-SC distance if close to sigma, apply spline.
1220 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1221 cAdam &             fcont1,fprimcont1)
1222 cAdam           fcont1=1.0d0-fcont1
1223 cAdam           if (fcont1.gt.0.0d0) then
1224 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1225 cAdam             fcont=fcont*fcont1
1226 cAdam           endif
1227 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1228 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1229 cga             do k=1,3
1230 cga               gg(k)=gg(k)*eps0ij
1231 cga             enddo
1232 cga             eps0ij=-evdwij*eps0ij
1233 C Uncomment for AL's type of SC correlation interactions.
1234 cadam           eps0ij=-evdwij
1235                 num_conti=num_conti+1
1236                 jcont(num_conti,i)=j
1237                 facont(num_conti,i)=fcont*eps0ij
1238                 fprimcont=eps0ij*fprimcont/rij
1239                 fcont=expon*fcont
1240 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1241 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1242 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1243 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1244                 gacont(1,num_conti,i)=-fprimcont*xj
1245                 gacont(2,num_conti,i)=-fprimcont*yj
1246                 gacont(3,num_conti,i)=-fprimcont*zj
1247 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1248 cd              write (iout,'(2i3,3f10.5)')
1249 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1250               endif
1251             endif
1252           enddo      ! j
1253         enddo        ! iint
1254 C Change 12/1/95
1255         num_cont(i)=num_conti
1256       enddo          ! i
1257       do i=1,nct
1258         do j=1,3
1259           gvdwc(j,i)=expon*gvdwc(j,i)
1260           gvdwx(j,i)=expon*gvdwx(j,i)
1261         enddo
1262       enddo
1263 C******************************************************************************
1264 C
1265 C                              N O T E !!!
1266 C
1267 C To save time, the factor of EXPON has been extracted from ALL components
1268 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1269 C use!
1270 C
1271 C******************************************************************************
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine eljk(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the LJK potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.INTERACT'
1288       include 'COMMON.IOUNITS'
1289       include 'COMMON.NAMES'
1290       dimension gg(3)
1291       logical scheck
1292 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1293       evdw=0.0D0
1294       do i=iatsc_s,iatsc_e
1295         itypi=iabs(itype(i))
1296         if (itypi.eq.ntyp1) cycle
1297         itypi1=iabs(itype(i+1))
1298         xi=c(1,nres+i)
1299         yi=c(2,nres+i)
1300         zi=c(3,nres+i)
1301 C
1302 C Calculate SC interaction energy.
1303 C
1304         do iint=1,nint_gr(i)
1305           do j=istart(i,iint),iend(i,iint)
1306             itypj=iabs(itype(j))
1307             if (itypj.eq.ntyp1) cycle
1308             xj=c(1,nres+j)-xi
1309             yj=c(2,nres+j)-yi
1310             zj=c(3,nres+j)-zi
1311             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1312             fac_augm=rrij**expon
1313             e_augm=augm(itypi,itypj)*fac_augm
1314             r_inv_ij=dsqrt(rrij)
1315             rij=1.0D0/r_inv_ij
1316             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1317             fac=r_shift_inv**expon
1318 C have you changed here?
1319             e1=fac*fac*aa
1320             e2=fac*bb
1321             evdwij=e_augm+e1+e2
1322 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1323 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1324 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1325 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1326 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1327 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1328 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1329             evdw=evdw+evdwij
1330 C
1331 C Calculate the components of the gradient in DC and X
1332 C
1333             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1334             gg(1)=xj*fac
1335             gg(2)=yj*fac
1336             gg(3)=zj*fac
1337             do k=1,3
1338               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1339               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1340               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1341               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1342             enddo
1343 cgrad            do k=i,j-1
1344 cgrad              do l=1,3
1345 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1346 cgrad              enddo
1347 cgrad            enddo
1348           enddo      ! j
1349         enddo        ! iint
1350       enddo          ! i
1351       do i=1,nct
1352         do j=1,3
1353           gvdwc(j,i)=expon*gvdwc(j,i)
1354           gvdwx(j,i)=expon*gvdwx(j,i)
1355         enddo
1356       enddo
1357       return
1358       end
1359 C-----------------------------------------------------------------------------
1360       subroutine ebp(evdw)
1361 C
1362 C This subroutine calculates the interaction energy of nonbonded side chains
1363 C assuming the Berne-Pechukas potential of interaction.
1364 C
1365       implicit real*8 (a-h,o-z)
1366       include 'DIMENSIONS'
1367       include 'COMMON.GEO'
1368       include 'COMMON.VAR'
1369       include 'COMMON.LOCAL'
1370       include 'COMMON.CHAIN'
1371       include 'COMMON.DERIV'
1372       include 'COMMON.NAMES'
1373       include 'COMMON.INTERACT'
1374       include 'COMMON.IOUNITS'
1375       include 'COMMON.CALC'
1376       common /srutu/ icall
1377 c     double precision rrsave(maxdim)
1378       logical lprn
1379       evdw=0.0D0
1380 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1381       evdw=0.0D0
1382 c     if (icall.eq.0) then
1383 c       lprn=.true.
1384 c     else
1385         lprn=.false.
1386 c     endif
1387       ind=0
1388       do i=iatsc_s,iatsc_e
1389         itypi=iabs(itype(i))
1390         if (itypi.eq.ntyp1) cycle
1391         itypi1=iabs(itype(i+1))
1392         xi=c(1,nres+i)
1393         yi=c(2,nres+i)
1394         zi=c(3,nres+i)
1395         dxi=dc_norm(1,nres+i)
1396         dyi=dc_norm(2,nres+i)
1397         dzi=dc_norm(3,nres+i)
1398 c        dsci_inv=dsc_inv(itypi)
1399         dsci_inv=vbld_inv(i+nres)
1400 C
1401 C Calculate SC interaction energy.
1402 C
1403         do iint=1,nint_gr(i)
1404           do j=istart(i,iint),iend(i,iint)
1405             ind=ind+1
1406             itypj=iabs(itype(j))
1407             if (itypj.eq.ntyp1) cycle
1408 c            dscj_inv=dsc_inv(itypj)
1409             dscj_inv=vbld_inv(j+nres)
1410             chi1=chi(itypi,itypj)
1411             chi2=chi(itypj,itypi)
1412             chi12=chi1*chi2
1413             chip1=chip(itypi)
1414             chip2=chip(itypj)
1415             chip12=chip1*chip2
1416             alf1=alp(itypi)
1417             alf2=alp(itypj)
1418             alf12=0.5D0*(alf1+alf2)
1419 C For diagnostics only!!!
1420 c           chi1=0.0D0
1421 c           chi2=0.0D0
1422 c           chi12=0.0D0
1423 c           chip1=0.0D0
1424 c           chip2=0.0D0
1425 c           chip12=0.0D0
1426 c           alf1=0.0D0
1427 c           alf2=0.0D0
1428 c           alf12=0.0D0
1429             xj=c(1,nres+j)-xi
1430             yj=c(2,nres+j)-yi
1431             zj=c(3,nres+j)-zi
1432             dxj=dc_norm(1,nres+j)
1433             dyj=dc_norm(2,nres+j)
1434             dzj=dc_norm(3,nres+j)
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436 cd          if (icall.eq.0) then
1437 cd            rrsave(ind)=rrij
1438 cd          else
1439 cd            rrij=rrsave(ind)
1440 cd          endif
1441             rij=dsqrt(rrij)
1442 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1443             call sc_angular
1444 C Calculate whole angle-dependent part of epsilon and contributions
1445 C to its derivatives
1446 C have you changed here?
1447             fac=(rrij*sigsq)**expon2
1448             e1=fac*fac*aa
1449             e2=fac*bb
1450             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1451             eps2der=evdwij*eps3rt
1452             eps3der=evdwij*eps2rt
1453             evdwij=evdwij*eps2rt*eps3rt
1454             evdw=evdw+evdwij
1455             if (lprn) then
1456             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1457             epsi=bb**2/aa
1458 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1459 cd     &        restyp(itypi),i,restyp(itypj),j,
1460 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1461 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1462 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1463 cd     &        evdwij
1464             endif
1465 C Calculate gradient components.
1466             e1=e1*eps1*eps2rt**2*eps3rt**2
1467             fac=-expon*(e1+evdwij)
1468             sigder=fac/sigsq
1469             fac=rrij*fac
1470 C Calculate radial part of the gradient
1471             gg(1)=xj*fac
1472             gg(2)=yj*fac
1473             gg(3)=zj*fac
1474 C Calculate the angular part of the gradient and sum add the contributions
1475 C to the appropriate components of the Cartesian gradient.
1476             call sc_grad
1477           enddo      ! j
1478         enddo        ! iint
1479       enddo          ! i
1480 c     stop
1481       return
1482       end
1483 C-----------------------------------------------------------------------------
1484       subroutine egb(evdw)
1485 C
1486 C This subroutine calculates the interaction energy of nonbonded side chains
1487 C assuming the Gay-Berne potential of interaction.
1488 C
1489       implicit real*8 (a-h,o-z)
1490       include 'DIMENSIONS'
1491       include 'COMMON.GEO'
1492       include 'COMMON.VAR'
1493       include 'COMMON.LOCAL'
1494       include 'COMMON.CHAIN'
1495       include 'COMMON.DERIV'
1496       include 'COMMON.NAMES'
1497       include 'COMMON.INTERACT'
1498       include 'COMMON.IOUNITS'
1499       include 'COMMON.CALC'
1500       include 'COMMON.CONTROL'
1501       include 'COMMON.SPLITELE'
1502       include 'COMMON.SBRIDGE'
1503       logical lprn
1504       integer xshift,yshift,zshift
1505
1506       evdw=0.0D0
1507 ccccc      energy_dec=.false.
1508 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1509       evdw=0.0D0
1510       lprn=.false.
1511 c     if (icall.eq.0) lprn=.false.
1512       ind=0
1513 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1514 C we have the original box)
1515 C      do xshift=-1,1
1516 C      do yshift=-1,1
1517 C      do zshift=-1,1
1518       do i=iatsc_s,iatsc_e
1519         itypi=iabs(itype(i))
1520         if (itypi.eq.ntyp1) cycle
1521         itypi1=iabs(itype(i+1))
1522         xi=c(1,nres+i)
1523         yi=c(2,nres+i)
1524         zi=c(3,nres+i)
1525 C Return atom into box, boxxsize is size of box in x dimension
1526 c  134   continue
1527 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1528 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1529 C Condition for being inside the proper box
1530 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1531 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1532 c        go to 134
1533 c        endif
1534 c  135   continue
1535 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1536 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1537 C Condition for being inside the proper box
1538 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1539 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1540 c        go to 135
1541 c        endif
1542 c  136   continue
1543 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1544 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1545 C Condition for being inside the proper box
1546 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1547 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1548 c        go to 136
1549 c        endif
1550           xi=mod(xi,boxxsize)
1551           if (xi.lt.0) xi=xi+boxxsize
1552           yi=mod(yi,boxysize)
1553           if (yi.lt.0) yi=yi+boxysize
1554           zi=mod(zi,boxzsize)
1555           if (zi.lt.0) zi=zi+boxzsize
1556 C define scaling factor for lipids
1557
1558 C        if (positi.le.0) positi=positi+boxzsize
1559 C        print *,i
1560 C first for peptide groups
1561 c for each residue check if it is in lipid or lipid water border area
1562        if ((zi.gt.bordlipbot)
1563      &.and.(zi.lt.bordliptop)) then
1564 C the energy transfer exist
1565         if (zi.lt.buflipbot) then
1566 C what fraction I am in
1567          fracinbuf=1.0d0-
1568      &        ((zi-bordlipbot)/lipbufthick)
1569 C lipbufthick is thickenes of lipid buffore
1570          sslipi=sscalelip(fracinbuf)
1571          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1572         elseif (zi.gt.bufliptop) then
1573          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1574          sslipi=sscalelip(fracinbuf)
1575          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1576         else
1577          sslipi=1.0d0
1578          ssgradlipi=0.0
1579         endif
1580        else
1581          sslipi=0.0d0
1582          ssgradlipi=0.0
1583        endif
1584
1585 C          xi=xi+xshift*boxxsize
1586 C          yi=yi+yshift*boxysize
1587 C          zi=zi+zshift*boxzsize
1588
1589         dxi=dc_norm(1,nres+i)
1590         dyi=dc_norm(2,nres+i)
1591         dzi=dc_norm(3,nres+i)
1592 c        dsci_inv=dsc_inv(itypi)
1593         dsci_inv=vbld_inv(i+nres)
1594 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1595 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1596 C
1597 C Calculate SC interaction energy.
1598 C
1599         do iint=1,nint_gr(i)
1600           do j=istart(i,iint),iend(i,iint)
1601             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1602
1603 c              write(iout,*) "PRZED ZWYKLE", evdwij
1604               call dyn_ssbond_ene(i,j,evdwij)
1605 c              write(iout,*) "PO ZWYKLE", evdwij
1606
1607               evdw=evdw+evdwij
1608               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1609      &                        'evdw',i,j,evdwij,' ss'
1610 C triple bond artifac removal
1611              do k=j+1,iend(i,iint)
1612 C search over all next residues
1613               if (dyn_ss_mask(k)) then
1614 C check if they are cysteins
1615 C              write(iout,*) 'k=',k
1616
1617 c              write(iout,*) "PRZED TRI", evdwij
1618                evdwij_przed_tri=evdwij
1619               call triple_ssbond_ene(i,j,k,evdwij)
1620 c               if(evdwij_przed_tri.ne.evdwij) then
1621 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1622 c               endif
1623
1624 c              write(iout,*) "PO TRI", evdwij
1625 C call the energy function that removes the artifical triple disulfide
1626 C bond the soubroutine is located in ssMD.F
1627               evdw=evdw+evdwij
1628               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1629      &                        'evdw',i,j,evdwij,'tss'
1630               endif!dyn_ss_mask(k)
1631              enddo! k
1632             ELSE
1633             ind=ind+1
1634             itypj=iabs(itype(j))
1635             if (itypj.eq.ntyp1) cycle
1636 c            dscj_inv=dsc_inv(itypj)
1637             dscj_inv=vbld_inv(j+nres)
1638 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1639 c     &       1.0d0/vbld(j+nres)
1640 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1641             sig0ij=sigma(itypi,itypj)
1642             chi1=chi(itypi,itypj)
1643             chi2=chi(itypj,itypi)
1644             chi12=chi1*chi2
1645             chip1=chip(itypi)
1646             chip2=chip(itypj)
1647             chip12=chip1*chip2
1648             alf1=alp(itypi)
1649             alf2=alp(itypj)
1650             alf12=0.5D0*(alf1+alf2)
1651 C For diagnostics only!!!
1652 c           chi1=0.0D0
1653 c           chi2=0.0D0
1654 c           chi12=0.0D0
1655 c           chip1=0.0D0
1656 c           chip2=0.0D0
1657 c           chip12=0.0D0
1658 c           alf1=0.0D0
1659 c           alf2=0.0D0
1660 c           alf12=0.0D0
1661             xj=c(1,nres+j)
1662             yj=c(2,nres+j)
1663             zj=c(3,nres+j)
1664 C Return atom J into box the original box
1665 c  137   continue
1666 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1667 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1668 C Condition for being inside the proper box
1669 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1670 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1671 c        go to 137
1672 c        endif
1673 c  138   continue
1674 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1675 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1676 C Condition for being inside the proper box
1677 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1678 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1679 c        go to 138
1680 c        endif
1681 c  139   continue
1682 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1683 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1684 C Condition for being inside the proper box
1685 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1686 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1687 c        go to 139
1688 c        endif
1689           xj=mod(xj,boxxsize)
1690           if (xj.lt.0) xj=xj+boxxsize
1691           yj=mod(yj,boxysize)
1692           if (yj.lt.0) yj=yj+boxysize
1693           zj=mod(zj,boxzsize)
1694           if (zj.lt.0) zj=zj+boxzsize
1695        if ((zj.gt.bordlipbot)
1696      &.and.(zj.lt.bordliptop)) then
1697 C the energy transfer exist
1698         if (zj.lt.buflipbot) then
1699 C what fraction I am in
1700          fracinbuf=1.0d0-
1701      &        ((zj-bordlipbot)/lipbufthick)
1702 C lipbufthick is thickenes of lipid buffore
1703          sslipj=sscalelip(fracinbuf)
1704          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1705         elseif (zj.gt.bufliptop) then
1706          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1707          sslipj=sscalelip(fracinbuf)
1708          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1709         else
1710          sslipj=1.0d0
1711          ssgradlipj=0.0
1712         endif
1713        else
1714          sslipj=0.0d0
1715          ssgradlipj=0.0
1716        endif
1717       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1718      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1719       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1720      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1721 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1722 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1723 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1724 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1725       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1726       xj_safe=xj
1727       yj_safe=yj
1728       zj_safe=zj
1729       subchap=0
1730       do xshift=-1,1
1731       do yshift=-1,1
1732       do zshift=-1,1
1733           xj=xj_safe+xshift*boxxsize
1734           yj=yj_safe+yshift*boxysize
1735           zj=zj_safe+zshift*boxzsize
1736           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1737           if(dist_temp.lt.dist_init) then
1738             dist_init=dist_temp
1739             xj_temp=xj
1740             yj_temp=yj
1741             zj_temp=zj
1742             subchap=1
1743           endif
1744        enddo
1745        enddo
1746        enddo
1747        if (subchap.eq.1) then
1748           xj=xj_temp-xi
1749           yj=yj_temp-yi
1750           zj=zj_temp-zi
1751        else
1752           xj=xj_safe-xi
1753           yj=yj_safe-yi
1754           zj=zj_safe-zi
1755        endif
1756             dxj=dc_norm(1,nres+j)
1757             dyj=dc_norm(2,nres+j)
1758             dzj=dc_norm(3,nres+j)
1759 C            xj=xj-xi
1760 C            yj=yj-yi
1761 C            zj=zj-zi
1762 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1763 c            write (iout,*) "j",j," dc_norm",
1764 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1765             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1766             rij=dsqrt(rrij)
1767             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1768             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1769
1770 c            write (iout,'(a7,4f8.3)')
1771 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1772             if (sss.gt.0.0d0) then
1773 C Calculate angle-dependent terms of energy and contributions to their
1774 C derivatives.
1775             call sc_angular
1776             sigsq=1.0D0/sigsq
1777             sig=sig0ij*dsqrt(sigsq)
1778             rij_shift=1.0D0/rij-sig+sig0ij
1779 c for diagnostics; uncomment
1780 c            rij_shift=1.2*sig0ij
1781 C I hate to put IF's in the loops, but here don't have another choice!!!!
1782             if (rij_shift.le.0.0D0) then
1783               evdw=1.0D20
1784 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1785 cd     &        restyp(itypi),i,restyp(itypj),j,
1786 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1787               return
1788             endif
1789             sigder=-sig*sigsq
1790 c---------------------------------------------------------------
1791             rij_shift=1.0D0/rij_shift
1792             fac=rij_shift**expon
1793 C here to start with
1794 C            if (c(i,3).gt.
1795             faclip=fac
1796             e1=fac*fac*aa
1797             e2=fac*bb
1798             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1799             eps2der=evdwij*eps3rt
1800             eps3der=evdwij*eps2rt
1801 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1802 C     &((sslipi+sslipj)/2.0d0+
1803 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1804 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1805 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1806             evdwij=evdwij*eps2rt*eps3rt
1807             evdw=evdw+evdwij*sss
1808             if (lprn) then
1809             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1810             epsi=bb**2/aa
1811             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1812      &        restyp(itypi),i,restyp(itypj),j,
1813      &        epsi,sigm,chi1,chi2,chip1,chip2,
1814      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1815      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1816      &        evdwij
1817             endif
1818
1819             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1820      &                        'evdw',i,j,evdwij
1821
1822 C Calculate gradient components.
1823             e1=e1*eps1*eps2rt**2*eps3rt**2
1824             fac=-expon*(e1+evdwij)*rij_shift
1825             sigder=fac*sigder
1826             fac=rij*fac
1827 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1828 c     &      evdwij,fac,sigma(itypi,itypj),expon
1829             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1830 c            fac=0.0d0
1831 C Calculate the radial part of the gradient
1832             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1833      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1834      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1835      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1836             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1837             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1838 C            gg_lipi(3)=0.0d0
1839 C            gg_lipj(3)=0.0d0
1840             gg(1)=xj*fac
1841             gg(2)=yj*fac
1842             gg(3)=zj*fac
1843 C Calculate angular part of the gradient.
1844             call sc_grad
1845             endif
1846             ENDIF    ! dyn_ss
1847           enddo      ! j
1848         enddo        ! iint
1849       enddo          ! i
1850 C      enddo          ! zshift
1851 C      enddo          ! yshift
1852 C      enddo          ! xshift
1853 c      write (iout,*) "Number of loop steps in EGB:",ind
1854 cccc      energy_dec=.false.
1855       return
1856       end
1857 C-----------------------------------------------------------------------------
1858       subroutine egbv(evdw)
1859 C
1860 C This subroutine calculates the interaction energy of nonbonded side chains
1861 C assuming the Gay-Berne-Vorobjev potential of interaction.
1862 C
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'COMMON.GEO'
1866       include 'COMMON.VAR'
1867       include 'COMMON.LOCAL'
1868       include 'COMMON.CHAIN'
1869       include 'COMMON.DERIV'
1870       include 'COMMON.NAMES'
1871       include 'COMMON.INTERACT'
1872       include 'COMMON.IOUNITS'
1873       include 'COMMON.CALC'
1874       common /srutu/ icall
1875       logical lprn
1876       evdw=0.0D0
1877 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1878       evdw=0.0D0
1879       lprn=.false.
1880 c     if (icall.eq.0) lprn=.true.
1881       ind=0
1882       do i=iatsc_s,iatsc_e
1883         itypi=iabs(itype(i))
1884         if (itypi.eq.ntyp1) cycle
1885         itypi1=iabs(itype(i+1))
1886         xi=c(1,nres+i)
1887         yi=c(2,nres+i)
1888         zi=c(3,nres+i)
1889           xi=mod(xi,boxxsize)
1890           if (xi.lt.0) xi=xi+boxxsize
1891           yi=mod(yi,boxysize)
1892           if (yi.lt.0) yi=yi+boxysize
1893           zi=mod(zi,boxzsize)
1894           if (zi.lt.0) zi=zi+boxzsize
1895 C define scaling factor for lipids
1896
1897 C        if (positi.le.0) positi=positi+boxzsize
1898 C        print *,i
1899 C first for peptide groups
1900 c for each residue check if it is in lipid or lipid water border area
1901        if ((zi.gt.bordlipbot)
1902      &.and.(zi.lt.bordliptop)) then
1903 C the energy transfer exist
1904         if (zi.lt.buflipbot) then
1905 C what fraction I am in
1906          fracinbuf=1.0d0-
1907      &        ((zi-bordlipbot)/lipbufthick)
1908 C lipbufthick is thickenes of lipid buffore
1909          sslipi=sscalelip(fracinbuf)
1910          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1911         elseif (zi.gt.bufliptop) then
1912          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1913          sslipi=sscalelip(fracinbuf)
1914          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1915         else
1916          sslipi=1.0d0
1917          ssgradlipi=0.0
1918         endif
1919        else
1920          sslipi=0.0d0
1921          ssgradlipi=0.0
1922        endif
1923
1924         dxi=dc_norm(1,nres+i)
1925         dyi=dc_norm(2,nres+i)
1926         dzi=dc_norm(3,nres+i)
1927 c        dsci_inv=dsc_inv(itypi)
1928         dsci_inv=vbld_inv(i+nres)
1929 C
1930 C Calculate SC interaction energy.
1931 C
1932         do iint=1,nint_gr(i)
1933           do j=istart(i,iint),iend(i,iint)
1934             ind=ind+1
1935             itypj=iabs(itype(j))
1936             if (itypj.eq.ntyp1) cycle
1937 c            dscj_inv=dsc_inv(itypj)
1938             dscj_inv=vbld_inv(j+nres)
1939             sig0ij=sigma(itypi,itypj)
1940             r0ij=r0(itypi,itypj)
1941             chi1=chi(itypi,itypj)
1942             chi2=chi(itypj,itypi)
1943             chi12=chi1*chi2
1944             chip1=chip(itypi)
1945             chip2=chip(itypj)
1946             chip12=chip1*chip2
1947             alf1=alp(itypi)
1948             alf2=alp(itypj)
1949             alf12=0.5D0*(alf1+alf2)
1950 C For diagnostics only!!!
1951 c           chi1=0.0D0
1952 c           chi2=0.0D0
1953 c           chi12=0.0D0
1954 c           chip1=0.0D0
1955 c           chip2=0.0D0
1956 c           chip12=0.0D0
1957 c           alf1=0.0D0
1958 c           alf2=0.0D0
1959 c           alf12=0.0D0
1960 C            xj=c(1,nres+j)-xi
1961 C            yj=c(2,nres+j)-yi
1962 C            zj=c(3,nres+j)-zi
1963           xj=mod(xj,boxxsize)
1964           if (xj.lt.0) xj=xj+boxxsize
1965           yj=mod(yj,boxysize)
1966           if (yj.lt.0) yj=yj+boxysize
1967           zj=mod(zj,boxzsize)
1968           if (zj.lt.0) zj=zj+boxzsize
1969        if ((zj.gt.bordlipbot)
1970      &.and.(zj.lt.bordliptop)) then
1971 C the energy transfer exist
1972         if (zj.lt.buflipbot) then
1973 C what fraction I am in
1974          fracinbuf=1.0d0-
1975      &        ((zj-bordlipbot)/lipbufthick)
1976 C lipbufthick is thickenes of lipid buffore
1977          sslipj=sscalelip(fracinbuf)
1978          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1979         elseif (zj.gt.bufliptop) then
1980          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1981          sslipj=sscalelip(fracinbuf)
1982          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1983         else
1984          sslipj=1.0d0
1985          ssgradlipj=0.0
1986         endif
1987        else
1988          sslipj=0.0d0
1989          ssgradlipj=0.0
1990        endif
1991       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1992      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1993       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1994      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1995 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1996 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1997       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1998       xj_safe=xj
1999       yj_safe=yj
2000       zj_safe=zj
2001       subchap=0
2002       do xshift=-1,1
2003       do yshift=-1,1
2004       do zshift=-1,1
2005           xj=xj_safe+xshift*boxxsize
2006           yj=yj_safe+yshift*boxysize
2007           zj=zj_safe+zshift*boxzsize
2008           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2009           if(dist_temp.lt.dist_init) then
2010             dist_init=dist_temp
2011             xj_temp=xj
2012             yj_temp=yj
2013             zj_temp=zj
2014             subchap=1
2015           endif
2016        enddo
2017        enddo
2018        enddo
2019        if (subchap.eq.1) then
2020           xj=xj_temp-xi
2021           yj=yj_temp-yi
2022           zj=zj_temp-zi
2023        else
2024           xj=xj_safe-xi
2025           yj=yj_safe-yi
2026           zj=zj_safe-zi
2027        endif
2028             dxj=dc_norm(1,nres+j)
2029             dyj=dc_norm(2,nres+j)
2030             dzj=dc_norm(3,nres+j)
2031             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2032             rij=dsqrt(rrij)
2033 C Calculate angle-dependent terms of energy and contributions to their
2034 C derivatives.
2035             call sc_angular
2036             sigsq=1.0D0/sigsq
2037             sig=sig0ij*dsqrt(sigsq)
2038             rij_shift=1.0D0/rij-sig+r0ij
2039 C I hate to put IF's in the loops, but here don't have another choice!!!!
2040             if (rij_shift.le.0.0D0) then
2041               evdw=1.0D20
2042               return
2043             endif
2044             sigder=-sig*sigsq
2045 c---------------------------------------------------------------
2046             rij_shift=1.0D0/rij_shift
2047             fac=rij_shift**expon
2048             e1=fac*fac*aa
2049             e2=fac*bb
2050             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2051             eps2der=evdwij*eps3rt
2052             eps3der=evdwij*eps2rt
2053             fac_augm=rrij**expon
2054             e_augm=augm(itypi,itypj)*fac_augm
2055             evdwij=evdwij*eps2rt*eps3rt
2056             evdw=evdw+evdwij+e_augm
2057             if (lprn) then
2058             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2059             epsi=bb**2/aa
2060             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2061      &        restyp(itypi),i,restyp(itypj),j,
2062      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2063      &        chi1,chi2,chip1,chip2,
2064      &        eps1,eps2rt**2,eps3rt**2,
2065      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2066      &        evdwij+e_augm
2067             endif
2068 C Calculate gradient components.
2069             e1=e1*eps1*eps2rt**2*eps3rt**2
2070             fac=-expon*(e1+evdwij)*rij_shift
2071             sigder=fac*sigder
2072             fac=rij*fac-2*expon*rrij*e_augm
2073             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2074 C Calculate the radial part of the gradient
2075             gg(1)=xj*fac
2076             gg(2)=yj*fac
2077             gg(3)=zj*fac
2078 C Calculate angular part of the gradient.
2079             call sc_grad
2080           enddo      ! j
2081         enddo        ! iint
2082       enddo          ! i
2083       end
2084 C-----------------------------------------------------------------------------
2085       subroutine sc_angular
2086 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2087 C om12. Called by ebp, egb, and egbv.
2088       implicit none
2089       include 'COMMON.CALC'
2090       include 'COMMON.IOUNITS'
2091       erij(1)=xj*rij
2092       erij(2)=yj*rij
2093       erij(3)=zj*rij
2094       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2095       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2096       om12=dxi*dxj+dyi*dyj+dzi*dzj
2097       chiom12=chi12*om12
2098 C Calculate eps1(om12) and its derivative in om12
2099       faceps1=1.0D0-om12*chiom12
2100       faceps1_inv=1.0D0/faceps1
2101       eps1=dsqrt(faceps1_inv)
2102 C Following variable is eps1*deps1/dom12
2103       eps1_om12=faceps1_inv*chiom12
2104 c diagnostics only
2105 c      faceps1_inv=om12
2106 c      eps1=om12
2107 c      eps1_om12=1.0d0
2108 c      write (iout,*) "om12",om12," eps1",eps1
2109 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2110 C and om12.
2111       om1om2=om1*om2
2112       chiom1=chi1*om1
2113       chiom2=chi2*om2
2114       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2115       sigsq=1.0D0-facsig*faceps1_inv
2116       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2117       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2118       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2119 c diagnostics only
2120 c      sigsq=1.0d0
2121 c      sigsq_om1=0.0d0
2122 c      sigsq_om2=0.0d0
2123 c      sigsq_om12=0.0d0
2124 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2125 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2126 c     &    " eps1",eps1
2127 C Calculate eps2 and its derivatives in om1, om2, and om12.
2128       chipom1=chip1*om1
2129       chipom2=chip2*om2
2130       chipom12=chip12*om12
2131       facp=1.0D0-om12*chipom12
2132       facp_inv=1.0D0/facp
2133       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2134 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2135 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2136 C Following variable is the square root of eps2
2137       eps2rt=1.0D0-facp1*facp_inv
2138 C Following three variables are the derivatives of the square root of eps
2139 C in om1, om2, and om12.
2140       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2141       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2142       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2143 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2144       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2145 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2146 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2147 c     &  " eps2rt_om12",eps2rt_om12
2148 C Calculate whole angle-dependent part of epsilon and contributions
2149 C to its derivatives
2150       return
2151       end
2152 C----------------------------------------------------------------------------
2153       subroutine sc_grad
2154       implicit real*8 (a-h,o-z)
2155       include 'DIMENSIONS'
2156       include 'COMMON.CHAIN'
2157       include 'COMMON.DERIV'
2158       include 'COMMON.CALC'
2159       include 'COMMON.IOUNITS'
2160       double precision dcosom1(3),dcosom2(3)
2161 cc      print *,'sss=',sss
2162       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2163       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2164       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2165      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2166 c diagnostics only
2167 c      eom1=0.0d0
2168 c      eom2=0.0d0
2169 c      eom12=evdwij*eps1_om12
2170 c end diagnostics
2171 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2172 c     &  " sigder",sigder
2173 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2174 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2175       do k=1,3
2176         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2177         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2178       enddo
2179       do k=1,3
2180         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2181       enddo
2182 c      write (iout,*) "gg",(gg(k),k=1,3)
2183       do k=1,3
2184         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2185      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2186      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2187         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2188      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2189      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2190 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2191 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2192 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2193 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2194       enddo
2195 C
2196 C Calculate the components of the gradient in DC and X
2197 C
2198 cgrad      do k=i,j-1
2199 cgrad        do l=1,3
2200 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2201 cgrad        enddo
2202 cgrad      enddo
2203       do l=1,3
2204         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2205         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2206       enddo
2207       return
2208       end
2209 C-----------------------------------------------------------------------
2210       subroutine e_softsphere(evdw)
2211 C
2212 C This subroutine calculates the interaction energy of nonbonded side chains
2213 C assuming the LJ potential of interaction.
2214 C
2215       implicit real*8 (a-h,o-z)
2216       include 'DIMENSIONS'
2217       parameter (accur=1.0d-10)
2218       include 'COMMON.GEO'
2219       include 'COMMON.VAR'
2220       include 'COMMON.LOCAL'
2221       include 'COMMON.CHAIN'
2222       include 'COMMON.DERIV'
2223       include 'COMMON.INTERACT'
2224       include 'COMMON.TORSION'
2225       include 'COMMON.SBRIDGE'
2226       include 'COMMON.NAMES'
2227       include 'COMMON.IOUNITS'
2228       include 'COMMON.CONTACTS'
2229       dimension gg(3)
2230 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2231       evdw=0.0D0
2232       do i=iatsc_s,iatsc_e
2233         itypi=iabs(itype(i))
2234         if (itypi.eq.ntyp1) cycle
2235         itypi1=iabs(itype(i+1))
2236         xi=c(1,nres+i)
2237         yi=c(2,nres+i)
2238         zi=c(3,nres+i)
2239 C
2240 C Calculate SC interaction energy.
2241 C
2242         do iint=1,nint_gr(i)
2243 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2244 cd   &                  'iend=',iend(i,iint)
2245           do j=istart(i,iint),iend(i,iint)
2246             itypj=iabs(itype(j))
2247             if (itypj.eq.ntyp1) cycle
2248             xj=c(1,nres+j)-xi
2249             yj=c(2,nres+j)-yi
2250             zj=c(3,nres+j)-zi
2251             rij=xj*xj+yj*yj+zj*zj
2252 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2253             r0ij=r0(itypi,itypj)
2254             r0ijsq=r0ij*r0ij
2255 c            print *,i,j,r0ij,dsqrt(rij)
2256             if (rij.lt.r0ijsq) then
2257               evdwij=0.25d0*(rij-r0ijsq)**2
2258               fac=rij-r0ijsq
2259             else
2260               evdwij=0.0d0
2261               fac=0.0d0
2262             endif
2263             evdw=evdw+evdwij
2264 C
2265 C Calculate the components of the gradient in DC and X
2266 C
2267             gg(1)=xj*fac
2268             gg(2)=yj*fac
2269             gg(3)=zj*fac
2270             do k=1,3
2271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2275             enddo
2276 cgrad            do k=i,j-1
2277 cgrad              do l=1,3
2278 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2279 cgrad              enddo
2280 cgrad            enddo
2281           enddo ! j
2282         enddo ! iint
2283       enddo ! i
2284       return
2285       end
2286 C--------------------------------------------------------------------------
2287       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2288      &              eello_turn4)
2289 C
2290 C Soft-sphere potential of p-p interaction
2291 C
2292       implicit real*8 (a-h,o-z)
2293       include 'DIMENSIONS'
2294       include 'COMMON.CONTROL'
2295       include 'COMMON.IOUNITS'
2296       include 'COMMON.GEO'
2297       include 'COMMON.VAR'
2298       include 'COMMON.LOCAL'
2299       include 'COMMON.CHAIN'
2300       include 'COMMON.DERIV'
2301       include 'COMMON.INTERACT'
2302       include 'COMMON.CONTACTS'
2303       include 'COMMON.TORSION'
2304       include 'COMMON.VECTORS'
2305       include 'COMMON.FFIELD'
2306       dimension ggg(3)
2307 C      write(iout,*) 'In EELEC_soft_sphere'
2308       ees=0.0D0
2309       evdw1=0.0D0
2310       eel_loc=0.0d0
2311       eello_turn3=0.0d0
2312       eello_turn4=0.0d0
2313       ind=0
2314       do i=iatel_s,iatel_e
2315         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2316         dxi=dc(1,i)
2317         dyi=dc(2,i)
2318         dzi=dc(3,i)
2319         xmedi=c(1,i)+0.5d0*dxi
2320         ymedi=c(2,i)+0.5d0*dyi
2321         zmedi=c(3,i)+0.5d0*dzi
2322           xmedi=mod(xmedi,boxxsize)
2323           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2324           ymedi=mod(ymedi,boxysize)
2325           if (ymedi.lt.0) ymedi=ymedi+boxysize
2326           zmedi=mod(zmedi,boxzsize)
2327           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2328         num_conti=0
2329 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2330         do j=ielstart(i),ielend(i)
2331           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2332           ind=ind+1
2333           iteli=itel(i)
2334           itelj=itel(j)
2335           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2336           r0ij=rpp(iteli,itelj)
2337           r0ijsq=r0ij*r0ij
2338           dxj=dc(1,j)
2339           dyj=dc(2,j)
2340           dzj=dc(3,j)
2341           xj=c(1,j)+0.5D0*dxj
2342           yj=c(2,j)+0.5D0*dyj
2343           zj=c(3,j)+0.5D0*dzj
2344           xj=mod(xj,boxxsize)
2345           if (xj.lt.0) xj=xj+boxxsize
2346           yj=mod(yj,boxysize)
2347           if (yj.lt.0) yj=yj+boxysize
2348           zj=mod(zj,boxzsize)
2349           if (zj.lt.0) zj=zj+boxzsize
2350       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2351       xj_safe=xj
2352       yj_safe=yj
2353       zj_safe=zj
2354       isubchap=0
2355       do xshift=-1,1
2356       do yshift=-1,1
2357       do zshift=-1,1
2358           xj=xj_safe+xshift*boxxsize
2359           yj=yj_safe+yshift*boxysize
2360           zj=zj_safe+zshift*boxzsize
2361           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2362           if(dist_temp.lt.dist_init) then
2363             dist_init=dist_temp
2364             xj_temp=xj
2365             yj_temp=yj
2366             zj_temp=zj
2367             isubchap=1
2368           endif
2369        enddo
2370        enddo
2371        enddo
2372        if (isubchap.eq.1) then
2373           xj=xj_temp-xmedi
2374           yj=yj_temp-ymedi
2375           zj=zj_temp-zmedi
2376        else
2377           xj=xj_safe-xmedi
2378           yj=yj_safe-ymedi
2379           zj=zj_safe-zmedi
2380        endif
2381           rij=xj*xj+yj*yj+zj*zj
2382             sss=sscale(sqrt(rij))
2383             sssgrad=sscagrad(sqrt(rij))
2384           if (rij.lt.r0ijsq) then
2385             evdw1ij=0.25d0*(rij-r0ijsq)**2
2386             fac=rij-r0ijsq
2387           else
2388             evdw1ij=0.0d0
2389             fac=0.0d0
2390           endif
2391           evdw1=evdw1+evdw1ij*sss
2392 C
2393 C Calculate contributions to the Cartesian gradient.
2394 C
2395           ggg(1)=fac*xj*sssgrad
2396           ggg(2)=fac*yj*sssgrad
2397           ggg(3)=fac*zj*sssgrad
2398           do k=1,3
2399             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2400             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2401           enddo
2402 *
2403 * Loop over residues i+1 thru j-1.
2404 *
2405 cgrad          do k=i+1,j-1
2406 cgrad            do l=1,3
2407 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2408 cgrad            enddo
2409 cgrad          enddo
2410         enddo ! j
2411       enddo   ! i
2412 cgrad      do i=nnt,nct-1
2413 cgrad        do k=1,3
2414 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2415 cgrad        enddo
2416 cgrad        do j=i+1,nct-1
2417 cgrad          do k=1,3
2418 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2419 cgrad          enddo
2420 cgrad        enddo
2421 cgrad      enddo
2422       return
2423       end
2424 c------------------------------------------------------------------------------
2425       subroutine vec_and_deriv
2426       implicit real*8 (a-h,o-z)
2427       include 'DIMENSIONS'
2428 #ifdef MPI
2429       include 'mpif.h'
2430 #endif
2431       include 'COMMON.IOUNITS'
2432       include 'COMMON.GEO'
2433       include 'COMMON.VAR'
2434       include 'COMMON.LOCAL'
2435       include 'COMMON.CHAIN'
2436       include 'COMMON.VECTORS'
2437       include 'COMMON.SETUP'
2438       include 'COMMON.TIME1'
2439       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2440 C Compute the local reference systems. For reference system (i), the
2441 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2442 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2443 #ifdef PARVEC
2444       do i=ivec_start,ivec_end
2445 #else
2446       do i=1,nres-1
2447 #endif
2448           if (i.eq.nres-1) then
2449 C Case of the last full residue
2450 C Compute the Z-axis
2451             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2452             costh=dcos(pi-theta(nres))
2453             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2454             do k=1,3
2455               uz(k,i)=fac*uz(k,i)
2456             enddo
2457 C Compute the derivatives of uz
2458             uzder(1,1,1)= 0.0d0
2459             uzder(2,1,1)=-dc_norm(3,i-1)
2460             uzder(3,1,1)= dc_norm(2,i-1)
2461             uzder(1,2,1)= dc_norm(3,i-1)
2462             uzder(2,2,1)= 0.0d0
2463             uzder(3,2,1)=-dc_norm(1,i-1)
2464             uzder(1,3,1)=-dc_norm(2,i-1)
2465             uzder(2,3,1)= dc_norm(1,i-1)
2466             uzder(3,3,1)= 0.0d0
2467             uzder(1,1,2)= 0.0d0
2468             uzder(2,1,2)= dc_norm(3,i)
2469             uzder(3,1,2)=-dc_norm(2,i)
2470             uzder(1,2,2)=-dc_norm(3,i)
2471             uzder(2,2,2)= 0.0d0
2472             uzder(3,2,2)= dc_norm(1,i)
2473             uzder(1,3,2)= dc_norm(2,i)
2474             uzder(2,3,2)=-dc_norm(1,i)
2475             uzder(3,3,2)= 0.0d0
2476 C Compute the Y-axis
2477             facy=fac
2478             do k=1,3
2479               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2480             enddo
2481 C Compute the derivatives of uy
2482             do j=1,3
2483               do k=1,3
2484                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2485      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2486                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2487               enddo
2488               uyder(j,j,1)=uyder(j,j,1)-costh
2489               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2490             enddo
2491             do j=1,2
2492               do k=1,3
2493                 do l=1,3
2494                   uygrad(l,k,j,i)=uyder(l,k,j)
2495                   uzgrad(l,k,j,i)=uzder(l,k,j)
2496                 enddo
2497               enddo
2498             enddo
2499             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2500             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2501             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2502             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2503           else
2504 C Other residues
2505 C Compute the Z-axis
2506             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2507             costh=dcos(pi-theta(i+2))
2508             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2509             do k=1,3
2510               uz(k,i)=fac*uz(k,i)
2511             enddo
2512 C Compute the derivatives of uz
2513             uzder(1,1,1)= 0.0d0
2514             uzder(2,1,1)=-dc_norm(3,i+1)
2515             uzder(3,1,1)= dc_norm(2,i+1)
2516             uzder(1,2,1)= dc_norm(3,i+1)
2517             uzder(2,2,1)= 0.0d0
2518             uzder(3,2,1)=-dc_norm(1,i+1)
2519             uzder(1,3,1)=-dc_norm(2,i+1)
2520             uzder(2,3,1)= dc_norm(1,i+1)
2521             uzder(3,3,1)= 0.0d0
2522             uzder(1,1,2)= 0.0d0
2523             uzder(2,1,2)= dc_norm(3,i)
2524             uzder(3,1,2)=-dc_norm(2,i)
2525             uzder(1,2,2)=-dc_norm(3,i)
2526             uzder(2,2,2)= 0.0d0
2527             uzder(3,2,2)= dc_norm(1,i)
2528             uzder(1,3,2)= dc_norm(2,i)
2529             uzder(2,3,2)=-dc_norm(1,i)
2530             uzder(3,3,2)= 0.0d0
2531 C Compute the Y-axis
2532             facy=fac
2533             do k=1,3
2534               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2535             enddo
2536 C Compute the derivatives of uy
2537             do j=1,3
2538               do k=1,3
2539                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2540      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2541                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2542               enddo
2543               uyder(j,j,1)=uyder(j,j,1)-costh
2544               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2545             enddo
2546             do j=1,2
2547               do k=1,3
2548                 do l=1,3
2549                   uygrad(l,k,j,i)=uyder(l,k,j)
2550                   uzgrad(l,k,j,i)=uzder(l,k,j)
2551                 enddo
2552               enddo
2553             enddo
2554             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2555             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2556             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2557             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2558           endif
2559       enddo
2560       do i=1,nres-1
2561         vbld_inv_temp(1)=vbld_inv(i+1)
2562         if (i.lt.nres-1) then
2563           vbld_inv_temp(2)=vbld_inv(i+2)
2564           else
2565           vbld_inv_temp(2)=vbld_inv(i)
2566           endif
2567         do j=1,2
2568           do k=1,3
2569             do l=1,3
2570               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2571               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2572             enddo
2573           enddo
2574         enddo
2575       enddo
2576 #if defined(PARVEC) && defined(MPI)
2577       if (nfgtasks1.gt.1) then
2578         time00=MPI_Wtime()
2579 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2580 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2581 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2582         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2586      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2589      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2590      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2591         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2592      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2593      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2594         time_gather=time_gather+MPI_Wtime()-time00
2595       endif
2596 c      if (fg_rank.eq.0) then
2597 c        write (iout,*) "Arrays UY and UZ"
2598 c        do i=1,nres-1
2599 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2600 c     &     (uz(k,i),k=1,3)
2601 c        enddo
2602 c      endif
2603 #endif
2604       return
2605       end
2606 C-----------------------------------------------------------------------------
2607       subroutine check_vecgrad
2608       implicit real*8 (a-h,o-z)
2609       include 'DIMENSIONS'
2610       include 'COMMON.IOUNITS'
2611       include 'COMMON.GEO'
2612       include 'COMMON.VAR'
2613       include 'COMMON.LOCAL'
2614       include 'COMMON.CHAIN'
2615       include 'COMMON.VECTORS'
2616       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2617       dimension uyt(3,maxres),uzt(3,maxres)
2618       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2619       double precision delta /1.0d-7/
2620       call vec_and_deriv
2621 cd      do i=1,nres
2622 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2623 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2624 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2625 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2626 cd     &     (dc_norm(if90,i),if90=1,3)
2627 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2628 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2629 cd          write(iout,'(a)')
2630 cd      enddo
2631       do i=1,nres
2632         do j=1,2
2633           do k=1,3
2634             do l=1,3
2635               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2636               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2637             enddo
2638           enddo
2639         enddo
2640       enddo
2641       call vec_and_deriv
2642       do i=1,nres
2643         do j=1,3
2644           uyt(j,i)=uy(j,i)
2645           uzt(j,i)=uz(j,i)
2646         enddo
2647       enddo
2648       do i=1,nres
2649 cd        write (iout,*) 'i=',i
2650         do k=1,3
2651           erij(k)=dc_norm(k,i)
2652         enddo
2653         do j=1,3
2654           do k=1,3
2655             dc_norm(k,i)=erij(k)
2656           enddo
2657           dc_norm(j,i)=dc_norm(j,i)+delta
2658 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2659 c          do k=1,3
2660 c            dc_norm(k,i)=dc_norm(k,i)/fac
2661 c          enddo
2662 c          write (iout,*) (dc_norm(k,i),k=1,3)
2663 c          write (iout,*) (erij(k),k=1,3)
2664           call vec_and_deriv
2665           do k=1,3
2666             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2667             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2668             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2669             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2670           enddo
2671 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2672 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2673 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2674         enddo
2675         do k=1,3
2676           dc_norm(k,i)=erij(k)
2677         enddo
2678 cd        do k=1,3
2679 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2680 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2681 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2682 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2683 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2684 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2685 cd          write (iout,'(a)')
2686 cd        enddo
2687       enddo
2688       return
2689       end
2690 C--------------------------------------------------------------------------
2691       subroutine set_matrices
2692       implicit real*8 (a-h,o-z)
2693       include 'DIMENSIONS'
2694 #ifdef MPI
2695       include "mpif.h"
2696       include "COMMON.SETUP"
2697       integer IERR
2698       integer status(MPI_STATUS_SIZE)
2699 #endif
2700       include 'COMMON.IOUNITS'
2701       include 'COMMON.GEO'
2702       include 'COMMON.VAR'
2703       include 'COMMON.LOCAL'
2704       include 'COMMON.CHAIN'
2705       include 'COMMON.DERIV'
2706       include 'COMMON.INTERACT'
2707       include 'COMMON.CONTACTS'
2708       include 'COMMON.TORSION'
2709       include 'COMMON.VECTORS'
2710       include 'COMMON.FFIELD'
2711       double precision auxvec(2),auxmat(2,2)
2712 C
2713 C Compute the virtual-bond-torsional-angle dependent quantities needed
2714 C to calculate the el-loc multibody terms of various order.
2715 C
2716 c      write(iout,*) 'nphi=',nphi,nres
2717 #ifdef PARMAT
2718       do i=ivec_start+2,ivec_end+2
2719 #else
2720       do i=3,nres+1
2721 #endif
2722 #ifdef NEWCORR
2723         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2724           iti = itortyp(itype(i-2))
2725         else
2726           iti=ntortyp+1
2727         endif
2728 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2729         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2730           iti1 = itortyp(itype(i-1))
2731         else
2732           iti1=ntortyp+1
2733         endif
2734 c        write(iout,*),i
2735         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2736      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2737      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2738         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2739      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2740      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2741 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2742 c     &*(cos(theta(i)/2.0)
2743         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2744      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2745      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2746 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2747 c     &*(cos(theta(i)/2.0)
2748         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2749      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2750      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2751 c        if (ggb1(1,i).eq.0.0d0) then
2752 c        write(iout,*) 'i=',i,ggb1(1,i),
2753 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2754 c     &bnew1(2,1,iti)*cos(theta(i)),
2755 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2756 c        endif
2757         b1(2,i-2)=bnew1(1,2,iti)
2758         gtb1(2,i-2)=0.0
2759         b2(2,i-2)=bnew2(1,2,iti)
2760         gtb2(2,i-2)=0.0
2761         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2762         EE(1,2,i-2)=eeold(1,2,iti)
2763         EE(2,1,i-2)=eeold(2,1,iti)
2764         EE(2,2,i-2)=eeold(2,2,iti)
2765         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2766         gtEE(1,2,i-2)=0.0d0
2767         gtEE(2,2,i-2)=0.0d0
2768         gtEE(2,1,i-2)=0.0d0
2769 c        EE(2,2,iti)=0.0d0
2770 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2771 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2772 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2773 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2774        b1tilde(1,i-2)=b1(1,i-2)
2775        b1tilde(2,i-2)=-b1(2,i-2)
2776        b2tilde(1,i-2)=b2(1,i-2)
2777        b2tilde(2,i-2)=-b2(2,i-2)
2778 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2779 c       write(iout,*)  'b1=',b1(1,i-2)
2780 c       write (iout,*) 'theta=', theta(i-1)
2781        enddo
2782 #else
2783         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2784           iti = itortyp(itype(i-2))
2785         else
2786           iti=ntortyp+1
2787         endif
2788 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2789         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2790           iti1 = itortyp(itype(i-1))
2791         else
2792           iti1=ntortyp+1
2793         endif
2794         b1(1,i-2)=b(3,iti)
2795         b1(2,i-2)=b(5,iti)
2796         b2(1,i-2)=b(2,iti)
2797         b2(2,i-2)=b(4,iti)
2798        b1tilde(1,i-2)=b1(1,i-2)
2799        b1tilde(2,i-2)=-b1(2,i-2)
2800        b2tilde(1,i-2)=b2(1,i-2)
2801        b2tilde(2,i-2)=-b2(2,i-2)
2802         EE(1,2,i-2)=eeold(1,2,iti)
2803         EE(2,1,i-2)=eeold(2,1,iti)
2804         EE(2,2,i-2)=eeold(2,2,iti)
2805         EE(1,1,i-2)=eeold(1,1,iti)
2806       enddo
2807 #endif
2808 #ifdef PARMAT
2809       do i=ivec_start+2,ivec_end+2
2810 #else
2811       do i=3,nres+1
2812 #endif
2813         if (i .lt. nres+1) then
2814           sin1=dsin(phi(i))
2815           cos1=dcos(phi(i))
2816           sintab(i-2)=sin1
2817           costab(i-2)=cos1
2818           obrot(1,i-2)=cos1
2819           obrot(2,i-2)=sin1
2820           sin2=dsin(2*phi(i))
2821           cos2=dcos(2*phi(i))
2822           sintab2(i-2)=sin2
2823           costab2(i-2)=cos2
2824           obrot2(1,i-2)=cos2
2825           obrot2(2,i-2)=sin2
2826           Ug(1,1,i-2)=-cos1
2827           Ug(1,2,i-2)=-sin1
2828           Ug(2,1,i-2)=-sin1
2829           Ug(2,2,i-2)= cos1
2830           Ug2(1,1,i-2)=-cos2
2831           Ug2(1,2,i-2)=-sin2
2832           Ug2(2,1,i-2)=-sin2
2833           Ug2(2,2,i-2)= cos2
2834         else
2835           costab(i-2)=1.0d0
2836           sintab(i-2)=0.0d0
2837           obrot(1,i-2)=1.0d0
2838           obrot(2,i-2)=0.0d0
2839           obrot2(1,i-2)=0.0d0
2840           obrot2(2,i-2)=0.0d0
2841           Ug(1,1,i-2)=1.0d0
2842           Ug(1,2,i-2)=0.0d0
2843           Ug(2,1,i-2)=0.0d0
2844           Ug(2,2,i-2)=1.0d0
2845           Ug2(1,1,i-2)=0.0d0
2846           Ug2(1,2,i-2)=0.0d0
2847           Ug2(2,1,i-2)=0.0d0
2848           Ug2(2,2,i-2)=0.0d0
2849         endif
2850         if (i .gt. 3 .and. i .lt. nres+1) then
2851           obrot_der(1,i-2)=-sin1
2852           obrot_der(2,i-2)= cos1
2853           Ugder(1,1,i-2)= sin1
2854           Ugder(1,2,i-2)=-cos1
2855           Ugder(2,1,i-2)=-cos1
2856           Ugder(2,2,i-2)=-sin1
2857           dwacos2=cos2+cos2
2858           dwasin2=sin2+sin2
2859           obrot2_der(1,i-2)=-dwasin2
2860           obrot2_der(2,i-2)= dwacos2
2861           Ug2der(1,1,i-2)= dwasin2
2862           Ug2der(1,2,i-2)=-dwacos2
2863           Ug2der(2,1,i-2)=-dwacos2
2864           Ug2der(2,2,i-2)=-dwasin2
2865         else
2866           obrot_der(1,i-2)=0.0d0
2867           obrot_der(2,i-2)=0.0d0
2868           Ugder(1,1,i-2)=0.0d0
2869           Ugder(1,2,i-2)=0.0d0
2870           Ugder(2,1,i-2)=0.0d0
2871           Ugder(2,2,i-2)=0.0d0
2872           obrot2_der(1,i-2)=0.0d0
2873           obrot2_der(2,i-2)=0.0d0
2874           Ug2der(1,1,i-2)=0.0d0
2875           Ug2der(1,2,i-2)=0.0d0
2876           Ug2der(2,1,i-2)=0.0d0
2877           Ug2der(2,2,i-2)=0.0d0
2878         endif
2879 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2880         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2881           iti = itortyp(itype(i-2))
2882         else
2883           iti=ntortyp
2884         endif
2885 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2886         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2887           iti1 = itortyp(itype(i-1))
2888         else
2889           iti1=ntortyp
2890         endif
2891 cd        write (iout,*) '*******i',i,' iti1',iti
2892 cd        write (iout,*) 'b1',b1(:,iti)
2893 cd        write (iout,*) 'b2',b2(:,iti)
2894 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2895 c        if (i .gt. iatel_s+2) then
2896         if (i .gt. nnt+2) then
2897           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2898 #ifdef NEWCORR
2899           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2900 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2901 #endif
2902 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2903 c     &    EE(1,2,iti),EE(2,2,iti)
2904           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2905           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2906 c          write(iout,*) "Macierz EUG",
2907 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2908 c     &    eug(2,2,i-2)
2909           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2910      &    then
2911           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2912           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2913           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2914           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2915           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2916           endif
2917         else
2918           do k=1,2
2919             Ub2(k,i-2)=0.0d0
2920             Ctobr(k,i-2)=0.0d0
2921             Dtobr2(k,i-2)=0.0d0
2922             do l=1,2
2923               EUg(l,k,i-2)=0.0d0
2924               CUg(l,k,i-2)=0.0d0
2925               DUg(l,k,i-2)=0.0d0
2926               DtUg2(l,k,i-2)=0.0d0
2927             enddo
2928           enddo
2929         endif
2930         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2931         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2932         do k=1,2
2933           muder(k,i-2)=Ub2der(k,i-2)
2934         enddo
2935 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2936         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2937           if (itype(i-1).le.ntyp) then
2938             iti1 = itortyp(itype(i-1))
2939           else
2940             iti1=ntortyp
2941           endif
2942         else
2943           iti1=ntortyp
2944         endif
2945         do k=1,2
2946           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2947         enddo
2948 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2949 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2950 cd        write (iout,*) 'mu1',mu1(:,i-2)
2951 cd        write (iout,*) 'mu2',mu2(:,i-2)
2952         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2953      &  then
2954         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2955         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2956         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2957         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2958         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2959 C Vectors and matrices dependent on a single virtual-bond dihedral.
2960         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2961         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2962         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2963         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2964         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2965         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2966         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2967         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2968         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2969         endif
2970       enddo
2971 C Matrices dependent on two consecutive virtual-bond dihedrals.
2972 C The order of matrices is from left to right.
2973       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2974      &then
2975 c      do i=max0(ivec_start,2),ivec_end
2976       do i=2,nres-1
2977         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2978         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2979         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2980         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2981         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2982         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2983         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2984         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2985       enddo
2986       endif
2987 #if defined(MPI) && defined(PARMAT)
2988 #ifdef DEBUG
2989 c      if (fg_rank.eq.0) then
2990         write (iout,*) "Arrays UG and UGDER before GATHER"
2991         do i=1,nres-1
2992           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993      &     ((ug(l,k,i),l=1,2),k=1,2),
2994      &     ((ugder(l,k,i),l=1,2),k=1,2)
2995         enddo
2996         write (iout,*) "Arrays UG2 and UG2DER"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     ((ug2(l,k,i),l=1,2),k=1,2),
3000      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3001         enddo
3002         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3003         do i=1,nres-1
3004           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3005      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3006      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3007         enddo
3008         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3009         do i=1,nres-1
3010           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3011      &     costab(i),sintab(i),costab2(i),sintab2(i)
3012         enddo
3013         write (iout,*) "Array MUDER"
3014         do i=1,nres-1
3015           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3016         enddo
3017 c      endif
3018 #endif
3019       if (nfgtasks.gt.1) then
3020         time00=MPI_Wtime()
3021 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3022 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3023 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3024 #ifdef MATGATHER
3025         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3026      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3027      &   FG_COMM1,IERR)
3028         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3030      &   FG_COMM1,IERR)
3031         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3044      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3045      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3046         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3047      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3048      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3049         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3050      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3051      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3052         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3053      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3054      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3055         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3056      &  then
3057         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3058      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3061      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3062      &   FG_COMM1,IERR)
3063         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3064      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3065      &   FG_COMM1,IERR)
3066        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3067      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3068      &   FG_COMM1,IERR)
3069         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3070      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3071      &   FG_COMM1,IERR)
3072         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3073      &   ivec_count(fg_rank1),
3074      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3075      &   FG_COMM1,IERR)
3076         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3077      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3078      &   FG_COMM1,IERR)
3079         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3080      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3083      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3086      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3089      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3098      &   ivec_count(fg_rank1),
3099      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3100      &   FG_COMM1,IERR)
3101         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3102      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3103      &   FG_COMM1,IERR)
3104        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3105      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3106      &   FG_COMM1,IERR)
3107         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3108      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3114      &   ivec_count(fg_rank1),
3115      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3116      &   FG_COMM1,IERR)
3117         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3118      &   ivec_count(fg_rank1),
3119      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3120      &   FG_COMM1,IERR)
3121         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3122      &   ivec_count(fg_rank1),
3123      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3124      &   MPI_MAT2,FG_COMM1,IERR)
3125         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3126      &   ivec_count(fg_rank1),
3127      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3128      &   MPI_MAT2,FG_COMM1,IERR)
3129         endif
3130 #else
3131 c Passes matrix info through the ring
3132       isend=fg_rank1
3133       irecv=fg_rank1-1
3134       if (irecv.lt.0) irecv=nfgtasks1-1
3135       iprev=irecv
3136       inext=fg_rank1+1
3137       if (inext.ge.nfgtasks1) inext=0
3138       do i=1,nfgtasks1-1
3139 c        write (iout,*) "isend",isend," irecv",irecv
3140 c        call flush(iout)
3141         lensend=lentyp(isend)
3142         lenrecv=lentyp(irecv)
3143 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3144 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3145 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3146 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3147 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3148 c        write (iout,*) "Gather ROTAT1"
3149 c        call flush(iout)
3150 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3151 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3152 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3153 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather ROTAT2"
3155 c        call flush(iout)
3156         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3157      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3158      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3159      &   iprev,4400+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather ROTAT_OLD"
3161 c        call flush(iout)
3162         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3163      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3164      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3165      &   iprev,5500+irecv,FG_COMM,status,IERR)
3166 c        write (iout,*) "Gather PRECOMP11"
3167 c        call flush(iout)
3168         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3169      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3170      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3171      &   iprev,6600+irecv,FG_COMM,status,IERR)
3172 c        write (iout,*) "Gather PRECOMP12"
3173 c        call flush(iout)
3174         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3175      &  then
3176         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3177      &   MPI_ROTAT2(lensend),inext,7700+isend,
3178      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3179      &   iprev,7700+irecv,FG_COMM,status,IERR)
3180 c        write (iout,*) "Gather PRECOMP21"
3181 c        call flush(iout)
3182         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3183      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3184      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3185      &   iprev,8800+irecv,FG_COMM,status,IERR)
3186 c        write (iout,*) "Gather PRECOMP22"
3187 c        call flush(iout)
3188         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3189      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3190      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3191      &   MPI_PRECOMP23(lenrecv),
3192      &   iprev,9900+irecv,FG_COMM,status,IERR)
3193 c        write (iout,*) "Gather PRECOMP23"
3194 c        call flush(iout)
3195         endif
3196         isend=irecv
3197         irecv=irecv-1
3198         if (irecv.lt.0) irecv=nfgtasks1-1
3199       enddo
3200 #endif
3201         time_gather=time_gather+MPI_Wtime()-time00
3202       endif
3203 #ifdef DEBUG
3204 c      if (fg_rank.eq.0) then
3205         write (iout,*) "Arrays UG and UGDER"
3206         do i=1,nres-1
3207           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3208      &     ((ug(l,k,i),l=1,2),k=1,2),
3209      &     ((ugder(l,k,i),l=1,2),k=1,2)
3210         enddo
3211         write (iout,*) "Arrays UG2 and UG2DER"
3212         do i=1,nres-1
3213           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3214      &     ((ug2(l,k,i),l=1,2),k=1,2),
3215      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3216         enddo
3217         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3218         do i=1,nres-1
3219           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3220      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3221      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3222         enddo
3223         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3224         do i=1,nres-1
3225           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3226      &     costab(i),sintab(i),costab2(i),sintab2(i)
3227         enddo
3228         write (iout,*) "Array MUDER"
3229         do i=1,nres-1
3230           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3231         enddo
3232 c      endif
3233 #endif
3234 #endif
3235 cd      do i=1,nres
3236 cd        iti = itortyp(itype(i))
3237 cd        write (iout,*) i
3238 cd        do j=1,2
3239 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3240 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3241 cd        enddo
3242 cd      enddo
3243       return
3244       end
3245 C--------------------------------------------------------------------------
3246       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3247 C
3248 C This subroutine calculates the average interaction energy and its gradient
3249 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3250 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3251 C The potential depends both on the distance of peptide-group centers and on
3252 C the orientation of the CA-CA virtual bonds.
3253 C
3254       implicit real*8 (a-h,o-z)
3255 #ifdef MPI
3256       include 'mpif.h'
3257 #endif
3258       include 'DIMENSIONS'
3259       include 'COMMON.CONTROL'
3260       include 'COMMON.SETUP'
3261       include 'COMMON.IOUNITS'
3262       include 'COMMON.GEO'
3263       include 'COMMON.VAR'
3264       include 'COMMON.LOCAL'
3265       include 'COMMON.CHAIN'
3266       include 'COMMON.DERIV'
3267       include 'COMMON.INTERACT'
3268       include 'COMMON.CONTACTS'
3269       include 'COMMON.TORSION'
3270       include 'COMMON.VECTORS'
3271       include 'COMMON.FFIELD'
3272       include 'COMMON.TIME1'
3273       include 'COMMON.SPLITELE'
3274       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3275      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3276       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3277      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3278       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3279      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3280      &    num_conti,j1,j2
3281 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3282 #ifdef MOMENT
3283       double precision scal_el /1.0d0/
3284 #else
3285       double precision scal_el /0.5d0/
3286 #endif
3287 C 12/13/98
3288 C 13-go grudnia roku pamietnego...
3289       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3290      &                   0.0d0,1.0d0,0.0d0,
3291      &                   0.0d0,0.0d0,1.0d0/
3292 cd      write(iout,*) 'In EELEC'
3293 cd      do i=1,nloctyp
3294 cd        write(iout,*) 'Type',i
3295 cd        write(iout,*) 'B1',B1(:,i)
3296 cd        write(iout,*) 'B2',B2(:,i)
3297 cd        write(iout,*) 'CC',CC(:,:,i)
3298 cd        write(iout,*) 'DD',DD(:,:,i)
3299 cd        write(iout,*) 'EE',EE(:,:,i)
3300 cd      enddo
3301 cd      call check_vecgrad
3302 cd      stop
3303       if (icheckgrad.eq.1) then
3304         do i=1,nres-1
3305           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3306           do k=1,3
3307             dc_norm(k,i)=dc(k,i)*fac
3308           enddo
3309 c          write (iout,*) 'i',i,' fac',fac
3310         enddo
3311       endif
3312       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3313      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3314      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3315 c        call vec_and_deriv
3316 #ifdef TIMING
3317         time01=MPI_Wtime()
3318 #endif
3319         call set_matrices
3320 #ifdef TIMING
3321         time_mat=time_mat+MPI_Wtime()-time01
3322 #endif
3323       endif
3324 cd      do i=1,nres-1
3325 cd        write (iout,*) 'i=',i
3326 cd        do k=1,3
3327 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3328 cd        enddo
3329 cd        do k=1,3
3330 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3331 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3332 cd        enddo
3333 cd      enddo
3334       t_eelecij=0.0d0
3335       ees=0.0D0
3336       evdw1=0.0D0
3337       eel_loc=0.0d0
3338       eello_turn3=0.0d0
3339       eello_turn4=0.0d0
3340       ind=0
3341       do i=1,nres
3342         num_cont_hb(i)=0
3343       enddo
3344 cd      print '(a)','Enter EELEC'
3345 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3346       do i=1,nres
3347         gel_loc_loc(i)=0.0d0
3348         gcorr_loc(i)=0.0d0
3349       enddo
3350 c
3351 c
3352 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3353 C
3354 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3355 C
3356 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3357       do i=iturn3_start,iturn3_end
3358         if (i.le.1) cycle
3359 C        write(iout,*) "tu jest i",i
3360         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3361 C changes suggested by Ana to avoid out of bounds
3362      & .or.((i+4).gt.nres)
3363      & .or.((i-1).le.0)
3364 C end of changes by Ana
3365      &  .or. itype(i+2).eq.ntyp1
3366      &  .or. itype(i+3).eq.ntyp1) cycle
3367         if(i.gt.1)then
3368           if(itype(i-1).eq.ntyp1)cycle
3369         end if
3370         if(i.LT.nres-3)then
3371           if (itype(i+4).eq.ntyp1) cycle
3372         end if
3373         dxi=dc(1,i)
3374         dyi=dc(2,i)
3375         dzi=dc(3,i)
3376         dx_normi=dc_norm(1,i)
3377         dy_normi=dc_norm(2,i)
3378         dz_normi=dc_norm(3,i)
3379         xmedi=c(1,i)+0.5d0*dxi
3380         ymedi=c(2,i)+0.5d0*dyi
3381         zmedi=c(3,i)+0.5d0*dzi
3382           xmedi=mod(xmedi,boxxsize)
3383           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3384           ymedi=mod(ymedi,boxysize)
3385           if (ymedi.lt.0) ymedi=ymedi+boxysize
3386           zmedi=mod(zmedi,boxzsize)
3387           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3388         num_conti=0
3389         call eelecij(i,i+2,ees,evdw1,eel_loc)
3390         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3391         num_cont_hb(i)=num_conti
3392       enddo
3393       do i=iturn4_start,iturn4_end
3394         if (i.le.1) cycle
3395         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3396 C changes suggested by Ana to avoid out of bounds
3397      & .or.((i+5).gt.nres)
3398      & .or.((i-1).le.0)
3399 C end of changes suggested by Ana
3400      &    .or. itype(i+3).eq.ntyp1
3401      &    .or. itype(i+4).eq.ntyp1
3402      &    .or. itype(i+5).eq.ntyp1
3403      &    .or. itype(i).eq.ntyp1
3404      &    .or. itype(i-1).eq.ntyp1
3405      &                             ) cycle
3406         dxi=dc(1,i)
3407         dyi=dc(2,i)
3408         dzi=dc(3,i)
3409         dx_normi=dc_norm(1,i)
3410         dy_normi=dc_norm(2,i)
3411         dz_normi=dc_norm(3,i)
3412         xmedi=c(1,i)+0.5d0*dxi
3413         ymedi=c(2,i)+0.5d0*dyi
3414         zmedi=c(3,i)+0.5d0*dzi
3415 C Return atom into box, boxxsize is size of box in x dimension
3416 c  194   continue
3417 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3418 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3419 C Condition for being inside the proper box
3420 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3421 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3422 c        go to 194
3423 c        endif
3424 c  195   continue
3425 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3426 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3427 C Condition for being inside the proper box
3428 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3429 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3430 c        go to 195
3431 c        endif
3432 c  196   continue
3433 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3434 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3435 C Condition for being inside the proper box
3436 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3437 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3438 c        go to 196
3439 c        endif
3440           xmedi=mod(xmedi,boxxsize)
3441           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3442           ymedi=mod(ymedi,boxysize)
3443           if (ymedi.lt.0) ymedi=ymedi+boxysize
3444           zmedi=mod(zmedi,boxzsize)
3445           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3446
3447         num_conti=num_cont_hb(i)
3448 c        write(iout,*) "JESTEM W PETLI"
3449         call eelecij(i,i+3,ees,evdw1,eel_loc)
3450         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3451      &   call eturn4(i,eello_turn4)
3452         num_cont_hb(i)=num_conti
3453       enddo   ! i
3454 C Loop over all neighbouring boxes
3455 C      do xshift=-1,1
3456 C      do yshift=-1,1
3457 C      do zshift=-1,1
3458 c
3459 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3460 c
3461 CTU KURWA
3462       do i=iatel_s,iatel_e
3463 C        do i=75,75
3464         if (i.le.1) cycle
3465         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3466 C changes suggested by Ana to avoid out of bounds
3467      & .or.((i+2).gt.nres)
3468      & .or.((i-1).le.0)
3469 C end of changes by Ana
3470      &  .or. itype(i+2).eq.ntyp1
3471      &  .or. itype(i-1).eq.ntyp1
3472      &                ) cycle
3473         dxi=dc(1,i)
3474         dyi=dc(2,i)
3475         dzi=dc(3,i)
3476         dx_normi=dc_norm(1,i)
3477         dy_normi=dc_norm(2,i)
3478         dz_normi=dc_norm(3,i)
3479         xmedi=c(1,i)+0.5d0*dxi
3480         ymedi=c(2,i)+0.5d0*dyi
3481         zmedi=c(3,i)+0.5d0*dzi
3482           xmedi=mod(xmedi,boxxsize)
3483           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3484           ymedi=mod(ymedi,boxysize)
3485           if (ymedi.lt.0) ymedi=ymedi+boxysize
3486           zmedi=mod(zmedi,boxzsize)
3487           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3488 C          xmedi=xmedi+xshift*boxxsize
3489 C          ymedi=ymedi+yshift*boxysize
3490 C          zmedi=zmedi+zshift*boxzsize
3491
3492 C Return tom into box, boxxsize is size of box in x dimension
3493 c  164   continue
3494 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3495 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3496 C Condition for being inside the proper box
3497 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3498 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3499 c        go to 164
3500 c        endif
3501 c  165   continue
3502 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3503 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3504 C Condition for being inside the proper box
3505 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3506 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3507 c        go to 165
3508 c        endif
3509 c  166   continue
3510 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3511 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3512 cC Condition for being inside the proper box
3513 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3514 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3515 c        go to 166
3516 c        endif
3517
3518 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3519         num_conti=num_cont_hb(i)
3520 C I TU KURWA
3521         do j=ielstart(i),ielend(i)
3522 C          do j=16,17
3523 C          write (iout,*) i,j
3524          if (j.le.1) cycle
3525           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3526 C changes suggested by Ana to avoid out of bounds
3527      & .or.((j+2).gt.nres)
3528      & .or.((j-1).le.0)
3529 C end of changes by Ana
3530      & .or.itype(j+2).eq.ntyp1
3531      & .or.itype(j-1).eq.ntyp1
3532      &) cycle
3533           call eelecij(i,j,ees,evdw1,eel_loc)
3534         enddo ! j
3535         num_cont_hb(i)=num_conti
3536       enddo   ! i
3537 C     enddo   ! zshift
3538 C      enddo   ! yshift
3539 C      enddo   ! xshift
3540
3541 c      write (iout,*) "Number of loop steps in EELEC:",ind
3542 cd      do i=1,nres
3543 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3544 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3545 cd      enddo
3546 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3547 ccc      eel_loc=eel_loc+eello_turn3
3548 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3549       return
3550       end
3551 C-------------------------------------------------------------------------------
3552       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3553       implicit real*8 (a-h,o-z)
3554       include 'DIMENSIONS'
3555 #ifdef MPI
3556       include "mpif.h"
3557 #endif
3558       include 'COMMON.CONTROL'
3559       include 'COMMON.IOUNITS'
3560       include 'COMMON.GEO'
3561       include 'COMMON.VAR'
3562       include 'COMMON.LOCAL'
3563       include 'COMMON.CHAIN'
3564       include 'COMMON.DERIV'
3565       include 'COMMON.INTERACT'
3566       include 'COMMON.CONTACTS'
3567       include 'COMMON.TORSION'
3568       include 'COMMON.VECTORS'
3569       include 'COMMON.FFIELD'
3570       include 'COMMON.TIME1'
3571       include 'COMMON.SPLITELE'
3572       include 'COMMON.SHIELD'
3573       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3574      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3575       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3576      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3577      &    gmuij2(4),gmuji2(4)
3578       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3579      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3580      &    num_conti,j1,j2
3581 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3582 #ifdef MOMENT
3583       double precision scal_el /1.0d0/
3584 #else
3585       double precision scal_el /0.5d0/
3586 #endif
3587 C 12/13/98
3588 C 13-go grudnia roku pamietnego...
3589       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3590      &                   0.0d0,1.0d0,0.0d0,
3591      &                   0.0d0,0.0d0,1.0d0/
3592 c          time00=MPI_Wtime()
3593 cd      write (iout,*) "eelecij",i,j
3594 c          ind=ind+1
3595           iteli=itel(i)
3596           itelj=itel(j)
3597           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3598           aaa=app(iteli,itelj)
3599           bbb=bpp(iteli,itelj)
3600           ael6i=ael6(iteli,itelj)
3601           ael3i=ael3(iteli,itelj)
3602           dxj=dc(1,j)
3603           dyj=dc(2,j)
3604           dzj=dc(3,j)
3605           dx_normj=dc_norm(1,j)
3606           dy_normj=dc_norm(2,j)
3607           dz_normj=dc_norm(3,j)
3608 C          xj=c(1,j)+0.5D0*dxj-xmedi
3609 C          yj=c(2,j)+0.5D0*dyj-ymedi
3610 C          zj=c(3,j)+0.5D0*dzj-zmedi
3611           xj=c(1,j)+0.5D0*dxj
3612           yj=c(2,j)+0.5D0*dyj
3613           zj=c(3,j)+0.5D0*dzj
3614           xj=mod(xj,boxxsize)
3615           if (xj.lt.0) xj=xj+boxxsize
3616           yj=mod(yj,boxysize)
3617           if (yj.lt.0) yj=yj+boxysize
3618           zj=mod(zj,boxzsize)
3619           if (zj.lt.0) zj=zj+boxzsize
3620           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3621       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3622       xj_safe=xj
3623       yj_safe=yj
3624       zj_safe=zj
3625       isubchap=0
3626       do xshift=-1,1
3627       do yshift=-1,1
3628       do zshift=-1,1
3629           xj=xj_safe+xshift*boxxsize
3630           yj=yj_safe+yshift*boxysize
3631           zj=zj_safe+zshift*boxzsize
3632           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3633           if(dist_temp.lt.dist_init) then
3634             dist_init=dist_temp
3635             xj_temp=xj
3636             yj_temp=yj
3637             zj_temp=zj
3638             isubchap=1
3639           endif
3640        enddo
3641        enddo
3642        enddo
3643        if (isubchap.eq.1) then
3644           xj=xj_temp-xmedi
3645           yj=yj_temp-ymedi
3646           zj=zj_temp-zmedi
3647        else
3648           xj=xj_safe-xmedi
3649           yj=yj_safe-ymedi
3650           zj=zj_safe-zmedi
3651        endif
3652 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3653 c  174   continue
3654 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3655 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3656 C Condition for being inside the proper box
3657 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3658 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3659 c        go to 174
3660 c        endif
3661 c  175   continue
3662 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3663 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3664 C Condition for being inside the proper box
3665 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3666 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3667 c        go to 175
3668 c        endif
3669 c  176   continue
3670 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3671 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3672 C Condition for being inside the proper box
3673 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3674 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3675 c        go to 176
3676 c        endif
3677 C        endif !endPBC condintion
3678 C        xj=xj-xmedi
3679 C        yj=yj-ymedi
3680 C        zj=zj-zmedi
3681           rij=xj*xj+yj*yj+zj*zj
3682
3683             sss=sscale(sqrt(rij))
3684             sssgrad=sscagrad(sqrt(rij))
3685 c            if (sss.gt.0.0d0) then
3686           rrmij=1.0D0/rij
3687           rij=dsqrt(rij)
3688           rmij=1.0D0/rij
3689           r3ij=rrmij*rmij
3690           r6ij=r3ij*r3ij
3691           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3692           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3693           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3694           fac=cosa-3.0D0*cosb*cosg
3695           ev1=aaa*r6ij*r6ij
3696 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3697           if (j.eq.i+2) ev1=scal_el*ev1
3698           ev2=bbb*r6ij
3699           fac3=ael6i*r6ij
3700           fac4=ael3i*r3ij
3701           evdwij=(ev1+ev2)
3702           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3703           el2=fac4*fac
3704 C MARYSIA
3705 C          eesij=(el1+el2)
3706 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3707           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3708           if (shield_mode.gt.0) then
3709 C          fac_shield(i)=0.4
3710 C          fac_shield(j)=0.6
3711           el1=el1*fac_shield(i)*fac_shield(j)
3712           el2=el2*fac_shield(i)*fac_shield(j)
3713           eesij=(el1+el2)
3714           ees=ees+eesij
3715           else
3716           fac_shield(i)=1.0
3717           fac_shield(j)=1.0
3718           eesij=(el1+el2)
3719           ees=ees+eesij
3720           endif
3721           evdw1=evdw1+evdwij*sss
3722 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3723 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3724 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3725 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3726
3727           if (energy_dec) then
3728               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3729      &'evdw1',i,j,evdwij
3730      &,iteli,itelj,aaa,evdw1
3731               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3732           endif
3733
3734 C
3735 C Calculate contributions to the Cartesian gradient.
3736 C
3737 #ifdef SPLITELE
3738           facvdw=-6*rrmij*(ev1+evdwij)*sss
3739           facel=-3*rrmij*(el1+eesij)
3740           fac1=fac
3741           erij(1)=xj*rmij
3742           erij(2)=yj*rmij
3743           erij(3)=zj*rmij
3744
3745 *
3746 * Radial derivatives. First process both termini of the fragment (i,j)
3747 *
3748           ggg(1)=facel*xj
3749           ggg(2)=facel*yj
3750           ggg(3)=facel*zj
3751           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3752      &  (shield_mode.gt.0)) then
3753 C          print *,i,j
3754           do ilist=1,ishield_list(i)
3755            iresshield=shield_list(ilist,i)
3756            do k=1,3
3757            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3758            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3759      &              rlocshield
3760      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3761             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3762 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3763 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3764 C             if (iresshield.gt.i) then
3765 C               do ishi=i+1,iresshield-1
3766 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3767 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3768 C
3769 C              enddo
3770 C             else
3771 C               do ishi=iresshield,i
3772 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3773 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3774 C
3775 C               enddo
3776 C              endif
3777            enddo
3778           enddo
3779           do ilist=1,ishield_list(j)
3780            iresshield=shield_list(ilist,j)
3781            do k=1,3
3782            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3783            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3784      &              rlocshield
3785      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3786            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3787
3788 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3789 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3790 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3791 C             if (iresshield.gt.j) then
3792 C               do ishi=j+1,iresshield-1
3793 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3794 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3795 C
3796 C               enddo
3797 C            else
3798 C               do ishi=iresshield,j
3799 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3800 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3801 C               enddo
3802 C              endif
3803            enddo
3804           enddo
3805
3806           do k=1,3
3807             gshieldc(k,i)=gshieldc(k,i)+
3808      &              grad_shield(k,i)*eesij/fac_shield(i)
3809             gshieldc(k,j)=gshieldc(k,j)+
3810      &              grad_shield(k,j)*eesij/fac_shield(j)
3811             gshieldc(k,i-1)=gshieldc(k,i-1)+
3812      &              grad_shield(k,i)*eesij/fac_shield(i)
3813             gshieldc(k,j-1)=gshieldc(k,j-1)+
3814      &              grad_shield(k,j)*eesij/fac_shield(j)
3815
3816            enddo
3817            endif
3818 c          do k=1,3
3819 c            ghalf=0.5D0*ggg(k)
3820 c            gelc(k,i)=gelc(k,i)+ghalf
3821 c            gelc(k,j)=gelc(k,j)+ghalf
3822 c          enddo
3823 c 9/28/08 AL Gradient compotents will be summed only at the end
3824 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3825           do k=1,3
3826             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3827 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3828             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3829 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3830 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3831 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3832 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3833 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3834           enddo
3835 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3836
3837 *
3838 * Loop over residues i+1 thru j-1.
3839 *
3840 cgrad          do k=i+1,j-1
3841 cgrad            do l=1,3
3842 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3843 cgrad            enddo
3844 cgrad          enddo
3845           if (sss.gt.0.0) then
3846           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3847           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3848           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3849           else
3850           ggg(1)=0.0
3851           ggg(2)=0.0
3852           ggg(3)=0.0
3853           endif
3854 c          do k=1,3
3855 c            ghalf=0.5D0*ggg(k)
3856 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3857 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3858 c          enddo
3859 c 9/28/08 AL Gradient compotents will be summed only at the end
3860           do k=1,3
3861             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3862             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3863           enddo
3864 *
3865 * Loop over residues i+1 thru j-1.
3866 *
3867 cgrad          do k=i+1,j-1
3868 cgrad            do l=1,3
3869 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3870 cgrad            enddo
3871 cgrad          enddo
3872 #else
3873 C MARYSIA
3874           facvdw=(ev1+evdwij)*sss
3875           facel=(el1+eesij)
3876           fac1=fac
3877           fac=-3*rrmij*(facvdw+facvdw+facel)
3878           erij(1)=xj*rmij
3879           erij(2)=yj*rmij
3880           erij(3)=zj*rmij
3881 *
3882 * Radial derivatives. First process both termini of the fragment (i,j)
3883 *
3884           ggg(1)=fac*xj
3885 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3886           ggg(2)=fac*yj
3887 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3888           ggg(3)=fac*zj
3889 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3890 c          do k=1,3
3891 c            ghalf=0.5D0*ggg(k)
3892 c            gelc(k,i)=gelc(k,i)+ghalf
3893 c            gelc(k,j)=gelc(k,j)+ghalf
3894 c          enddo
3895 c 9/28/08 AL Gradient compotents will be summed only at the end
3896           do k=1,3
3897             gelc_long(k,j)=gelc(k,j)+ggg(k)
3898             gelc_long(k,i)=gelc(k,i)-ggg(k)
3899           enddo
3900 *
3901 * Loop over residues i+1 thru j-1.
3902 *
3903 cgrad          do k=i+1,j-1
3904 cgrad            do l=1,3
3905 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3906 cgrad            enddo
3907 cgrad          enddo
3908 c 9/28/08 AL Gradient compotents will be summed only at the end
3909           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3910           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3911           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3912           do k=1,3
3913             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3914             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3915           enddo
3916 #endif
3917 *
3918 * Angular part
3919 *
3920           ecosa=2.0D0*fac3*fac1+fac4
3921           fac4=-3.0D0*fac4
3922           fac3=-6.0D0*fac3
3923           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3924           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3925           do k=1,3
3926             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3927             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3928           enddo
3929 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3930 cd   &          (dcosg(k),k=1,3)
3931           do k=1,3
3932             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3933      &      fac_shield(i)*fac_shield(j)
3934           enddo
3935 c          do k=1,3
3936 c            ghalf=0.5D0*ggg(k)
3937 c            gelc(k,i)=gelc(k,i)+ghalf
3938 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3939 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3940 c            gelc(k,j)=gelc(k,j)+ghalf
3941 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3942 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3943 c          enddo
3944 cgrad          do k=i+1,j-1
3945 cgrad            do l=1,3
3946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3947 cgrad            enddo
3948 cgrad          enddo
3949 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
3950           do k=1,3
3951             gelc(k,i)=gelc(k,i)
3952      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3953      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
3954      &           *fac_shield(i)*fac_shield(j)
3955             gelc(k,j)=gelc(k,j)
3956      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3957      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
3958      &           *fac_shield(i)*fac_shield(j)
3959             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3960             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3961           enddo
3962 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
3963
3964 C MARYSIA
3965 c          endif !sscale
3966           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3967      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3968      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3969 C
3970 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3971 C   energy of a peptide unit is assumed in the form of a second-order
3972 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3973 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3974 C   are computed for EVERY pair of non-contiguous peptide groups.
3975 C
3976
3977           if (j.lt.nres-1) then
3978             j1=j+1
3979             j2=j-1
3980           else
3981             j1=j-1
3982             j2=j-2
3983           endif
3984           kkk=0
3985           lll=0
3986           do k=1,2
3987             do l=1,2
3988               kkk=kkk+1
3989               muij(kkk)=mu(k,i)*mu(l,j)
3990 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3991 #ifdef NEWCORR
3992              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3993 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3994              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3995              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3996 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3997              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3998 #endif
3999             enddo
4000           enddo
4001 cd         write (iout,*) 'EELEC: i',i,' j',j
4002 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4003 cd          write(iout,*) 'muij',muij
4004           ury=scalar(uy(1,i),erij)
4005           urz=scalar(uz(1,i),erij)
4006           vry=scalar(uy(1,j),erij)
4007           vrz=scalar(uz(1,j),erij)
4008           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4009           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4010           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4011           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4012           fac=dsqrt(-ael6i)*r3ij
4013           a22=a22*fac
4014           a23=a23*fac
4015           a32=a32*fac
4016           a33=a33*fac
4017 cd          write (iout,'(4i5,4f10.5)')
4018 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4019 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4020 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4021 cd     &      uy(:,j),uz(:,j)
4022 cd          write (iout,'(4f10.5)')
4023 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4024 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4025 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4026 cd           write (iout,'(9f10.5/)')
4027 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4028 C Derivatives of the elements of A in virtual-bond vectors
4029           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4030           do k=1,3
4031             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4032             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4033             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4034             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4035             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4036             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4037             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4038             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4039             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4040             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4041             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4042             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4043           enddo
4044 C Compute radial contributions to the gradient
4045           facr=-3.0d0*rrmij
4046           a22der=a22*facr
4047           a23der=a23*facr
4048           a32der=a32*facr
4049           a33der=a33*facr
4050           agg(1,1)=a22der*xj
4051           agg(2,1)=a22der*yj
4052           agg(3,1)=a22der*zj
4053           agg(1,2)=a23der*xj
4054           agg(2,2)=a23der*yj
4055           agg(3,2)=a23der*zj
4056           agg(1,3)=a32der*xj
4057           agg(2,3)=a32der*yj
4058           agg(3,3)=a32der*zj
4059           agg(1,4)=a33der*xj
4060           agg(2,4)=a33der*yj
4061           agg(3,4)=a33der*zj
4062 C Add the contributions coming from er
4063           fac3=-3.0d0*fac
4064           do k=1,3
4065             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4066             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4067             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4068             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4069           enddo
4070           do k=1,3
4071 C Derivatives in DC(i)
4072 cgrad            ghalf1=0.5d0*agg(k,1)
4073 cgrad            ghalf2=0.5d0*agg(k,2)
4074 cgrad            ghalf3=0.5d0*agg(k,3)
4075 cgrad            ghalf4=0.5d0*agg(k,4)
4076             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4077      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4078             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4079      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4080             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4081      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4082             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4083      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4084 C Derivatives in DC(i+1)
4085             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4086      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4087             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4088      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4089             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4090      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4091             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4092      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4093 C Derivatives in DC(j)
4094             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4095      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4096             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4097      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4098             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4099      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4100             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4101      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4102 C Derivatives in DC(j+1) or DC(nres-1)
4103             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4104      &      -3.0d0*vryg(k,3)*ury)
4105             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4106      &      -3.0d0*vrzg(k,3)*ury)
4107             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4108      &      -3.0d0*vryg(k,3)*urz)
4109             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4110      &      -3.0d0*vrzg(k,3)*urz)
4111 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4112 cgrad              do l=1,4
4113 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4114 cgrad              enddo
4115 cgrad            endif
4116           enddo
4117           acipa(1,1)=a22
4118           acipa(1,2)=a23
4119           acipa(2,1)=a32
4120           acipa(2,2)=a33
4121           a22=-a22
4122           a23=-a23
4123           do l=1,2
4124             do k=1,3
4125               agg(k,l)=-agg(k,l)
4126               aggi(k,l)=-aggi(k,l)
4127               aggi1(k,l)=-aggi1(k,l)
4128               aggj(k,l)=-aggj(k,l)
4129               aggj1(k,l)=-aggj1(k,l)
4130             enddo
4131           enddo
4132           if (j.lt.nres-1) then
4133             a22=-a22
4134             a32=-a32
4135             do l=1,3,2
4136               do k=1,3
4137                 agg(k,l)=-agg(k,l)
4138                 aggi(k,l)=-aggi(k,l)
4139                 aggi1(k,l)=-aggi1(k,l)
4140                 aggj(k,l)=-aggj(k,l)
4141                 aggj1(k,l)=-aggj1(k,l)
4142               enddo
4143             enddo
4144           else
4145             a22=-a22
4146             a23=-a23
4147             a32=-a32
4148             a33=-a33
4149             do l=1,4
4150               do k=1,3
4151                 agg(k,l)=-agg(k,l)
4152                 aggi(k,l)=-aggi(k,l)
4153                 aggi1(k,l)=-aggi1(k,l)
4154                 aggj(k,l)=-aggj(k,l)
4155                 aggj1(k,l)=-aggj1(k,l)
4156               enddo
4157             enddo
4158           endif
4159           ENDIF ! WCORR
4160           IF (wel_loc.gt.0.0d0) THEN
4161 C Contribution to the local-electrostatic energy coming from the i-j pair
4162           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4163      &     +a33*muij(4)
4164 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4165 c     &                     ' eel_loc_ij',eel_loc_ij
4166 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4167 C Calculate patrial derivative for theta angle
4168 #ifdef NEWCORR
4169          geel_loc_ij=a22*gmuij1(1)
4170      &     +a23*gmuij1(2)
4171      &     +a32*gmuij1(3)
4172      &     +a33*gmuij1(4)
4173 c         write(iout,*) "derivative over thatai"
4174 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4175 c     &   a33*gmuij1(4)
4176          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4177      &      geel_loc_ij*wel_loc
4178 c         write(iout,*) "derivative over thatai-1"
4179 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4180 c     &   a33*gmuij2(4)
4181          geel_loc_ij=
4182      &     a22*gmuij2(1)
4183      &     +a23*gmuij2(2)
4184      &     +a32*gmuij2(3)
4185      &     +a33*gmuij2(4)
4186          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4187      &      geel_loc_ij*wel_loc
4188 c  Derivative over j residue
4189          geel_loc_ji=a22*gmuji1(1)
4190      &     +a23*gmuji1(2)
4191      &     +a32*gmuji1(3)
4192      &     +a33*gmuji1(4)
4193 c         write(iout,*) "derivative over thataj"
4194 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4195 c     &   a33*gmuji1(4)
4196
4197         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4198      &      geel_loc_ji*wel_loc
4199          geel_loc_ji=
4200      &     +a22*gmuji2(1)
4201      &     +a23*gmuji2(2)
4202      &     +a32*gmuji2(3)
4203      &     +a33*gmuji2(4)
4204 c         write(iout,*) "derivative over thataj-1"
4205 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4206 c     &   a33*gmuji2(4)
4207          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4208      &      geel_loc_ji*wel_loc
4209 #endif
4210 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4211
4212           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4213      &            'eelloc',i,j,eel_loc_ij
4214 c           if (eel_loc_ij.ne.0)
4215 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4216 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4217
4218           eel_loc=eel_loc+eel_loc_ij
4219 C Partial derivatives in virtual-bond dihedral angles gamma
4220           if (i.gt.1)
4221      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4222      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4223      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4224           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4225      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4226      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4227 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4228           do l=1,3
4229             ggg(l)=agg(l,1)*muij(1)+
4230      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4231             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4232             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4233 cgrad            ghalf=0.5d0*ggg(l)
4234 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4235 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4236           enddo
4237 cgrad          do k=i+1,j2
4238 cgrad            do l=1,3
4239 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4240 cgrad            enddo
4241 cgrad          enddo
4242 C Remaining derivatives of eello
4243           do l=1,3
4244             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4245      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4246             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4247      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4248             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4249      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4250             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4251      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4252           enddo
4253           ENDIF
4254 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4255 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4256           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4257      &       .and. num_conti.le.maxconts) then
4258 c            write (iout,*) i,j," entered corr"
4259 C
4260 C Calculate the contact function. The ith column of the array JCONT will
4261 C contain the numbers of atoms that make contacts with the atom I (of numbers
4262 C greater than I). The arrays FACONT and GACONT will contain the values of
4263 C the contact function and its derivative.
4264 c           r0ij=1.02D0*rpp(iteli,itelj)
4265 c           r0ij=1.11D0*rpp(iteli,itelj)
4266             r0ij=2.20D0*rpp(iteli,itelj)
4267 c           r0ij=1.55D0*rpp(iteli,itelj)
4268             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4269             if (fcont.gt.0.0D0) then
4270               num_conti=num_conti+1
4271               if (num_conti.gt.maxconts) then
4272                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4273      &                         ' will skip next contacts for this conf.'
4274               else
4275                 jcont_hb(num_conti,i)=j
4276 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4277 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4278                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4279      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4280 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4281 C  terms.
4282                 d_cont(num_conti,i)=rij
4283 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4284 C     --- Electrostatic-interaction matrix ---
4285                 a_chuj(1,1,num_conti,i)=a22
4286                 a_chuj(1,2,num_conti,i)=a23
4287                 a_chuj(2,1,num_conti,i)=a32
4288                 a_chuj(2,2,num_conti,i)=a33
4289 C     --- Gradient of rij
4290                 do kkk=1,3
4291                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4292                 enddo
4293                 kkll=0
4294                 do k=1,2
4295                   do l=1,2
4296                     kkll=kkll+1
4297                     do m=1,3
4298                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4299                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4300                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4301                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4302                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4303                     enddo
4304                   enddo
4305                 enddo
4306                 ENDIF
4307                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4308 C Calculate contact energies
4309                 cosa4=4.0D0*cosa
4310                 wij=cosa-3.0D0*cosb*cosg
4311                 cosbg1=cosb+cosg
4312                 cosbg2=cosb-cosg
4313 c               fac3=dsqrt(-ael6i)/r0ij**3
4314                 fac3=dsqrt(-ael6i)*r3ij
4315 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4316                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4317                 if (ees0tmp.gt.0) then
4318                   ees0pij=dsqrt(ees0tmp)
4319                 else
4320                   ees0pij=0
4321                 endif
4322 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4323                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4324                 if (ees0tmp.gt.0) then
4325                   ees0mij=dsqrt(ees0tmp)
4326                 else
4327                   ees0mij=0
4328                 endif
4329 c               ees0mij=0.0D0
4330                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4331                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4332 C Diagnostics. Comment out or remove after debugging!
4333 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4334 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4335 c               ees0m(num_conti,i)=0.0D0
4336 C End diagnostics.
4337 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4338 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4339 C Angular derivatives of the contact function
4340                 ees0pij1=fac3/ees0pij
4341                 ees0mij1=fac3/ees0mij
4342                 fac3p=-3.0D0*fac3*rrmij
4343                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4344                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4345 c               ees0mij1=0.0D0
4346                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4347                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4348                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4349                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4350                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4351                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4352                 ecosap=ecosa1+ecosa2
4353                 ecosbp=ecosb1+ecosb2
4354                 ecosgp=ecosg1+ecosg2
4355                 ecosam=ecosa1-ecosa2
4356                 ecosbm=ecosb1-ecosb2
4357                 ecosgm=ecosg1-ecosg2
4358 C Diagnostics
4359 c               ecosap=ecosa1
4360 c               ecosbp=ecosb1
4361 c               ecosgp=ecosg1
4362 c               ecosam=0.0D0
4363 c               ecosbm=0.0D0
4364 c               ecosgm=0.0D0
4365 C End diagnostics
4366                 facont_hb(num_conti,i)=fcont
4367                 fprimcont=fprimcont/rij
4368 cd              facont_hb(num_conti,i)=1.0D0
4369 C Following line is for diagnostics.
4370 cd              fprimcont=0.0D0
4371                 do k=1,3
4372                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4373                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4374                 enddo
4375                 do k=1,3
4376                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4377                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4378                 enddo
4379                 gggp(1)=gggp(1)+ees0pijp*xj
4380                 gggp(2)=gggp(2)+ees0pijp*yj
4381                 gggp(3)=gggp(3)+ees0pijp*zj
4382                 gggm(1)=gggm(1)+ees0mijp*xj
4383                 gggm(2)=gggm(2)+ees0mijp*yj
4384                 gggm(3)=gggm(3)+ees0mijp*zj
4385 C Derivatives due to the contact function
4386                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4387                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4388                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4389                 do k=1,3
4390 c
4391 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4392 c          following the change of gradient-summation algorithm.
4393 c
4394 cgrad                  ghalfp=0.5D0*gggp(k)
4395 cgrad                  ghalfm=0.5D0*gggm(k)
4396                   gacontp_hb1(k,num_conti,i)=!ghalfp
4397      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4398      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4399                   gacontp_hb2(k,num_conti,i)=!ghalfp
4400      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4401      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4402                   gacontp_hb3(k,num_conti,i)=gggp(k)
4403                   gacontm_hb1(k,num_conti,i)=!ghalfm
4404      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4405      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4406                   gacontm_hb2(k,num_conti,i)=!ghalfm
4407      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4408      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4409                   gacontm_hb3(k,num_conti,i)=gggm(k)
4410                 enddo
4411 C Diagnostics. Comment out or remove after debugging!
4412 cdiag           do k=1,3
4413 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4414 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4415 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4416 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4417 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4418 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4419 cdiag           enddo
4420               ENDIF ! wcorr
4421               endif  ! num_conti.le.maxconts
4422             endif  ! fcont.gt.0
4423           endif    ! j.gt.i+1
4424           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4425             do k=1,4
4426               do l=1,3
4427                 ghalf=0.5d0*agg(l,k)
4428                 aggi(l,k)=aggi(l,k)+ghalf
4429                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4430                 aggj(l,k)=aggj(l,k)+ghalf
4431               enddo
4432             enddo
4433             if (j.eq.nres-1 .and. i.lt.j-2) then
4434               do k=1,4
4435                 do l=1,3
4436                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4437                 enddo
4438               enddo
4439             endif
4440           endif
4441 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4442       return
4443       end
4444 C-----------------------------------------------------------------------------
4445       subroutine eturn3(i,eello_turn3)
4446 C Third- and fourth-order contributions from turns
4447       implicit real*8 (a-h,o-z)
4448       include 'DIMENSIONS'
4449       include 'COMMON.IOUNITS'
4450       include 'COMMON.GEO'
4451       include 'COMMON.VAR'
4452       include 'COMMON.LOCAL'
4453       include 'COMMON.CHAIN'
4454       include 'COMMON.DERIV'
4455       include 'COMMON.INTERACT'
4456       include 'COMMON.CONTACTS'
4457       include 'COMMON.TORSION'
4458       include 'COMMON.VECTORS'
4459       include 'COMMON.FFIELD'
4460       include 'COMMON.CONTROL'
4461       dimension ggg(3)
4462       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4463      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4464      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4465      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4466      &  auxgmat2(2,2),auxgmatt2(2,2)
4467       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4468      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4469       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4470      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4471      &    num_conti,j1,j2
4472       j=i+2
4473 c      write (iout,*) "eturn3",i,j,j1,j2
4474       a_temp(1,1)=a22
4475       a_temp(1,2)=a23
4476       a_temp(2,1)=a32
4477       a_temp(2,2)=a33
4478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4479 C
4480 C               Third-order contributions
4481 C
4482 C                 (i+2)o----(i+3)
4483 C                      | |
4484 C                      | |
4485 C                 (i+1)o----i
4486 C
4487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4488 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4489         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4490 c auxalary matices for theta gradient
4491 c auxalary matrix for i+1 and constant i+2
4492         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4493 c auxalary matrix for i+2 and constant i+1
4494         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4495         call transpose2(auxmat(1,1),auxmat1(1,1))
4496         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4497         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4498         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4499         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4500         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4501         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4502 C Derivatives in theta
4503         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4504      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4505         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4506      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4507
4508         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4509      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4510 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4511 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4512 cd     &    ' eello_turn3_num',4*eello_turn3_num
4513 C Derivatives in gamma(i)
4514         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4515         call transpose2(auxmat2(1,1),auxmat3(1,1))
4516         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4517         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4518 C Derivatives in gamma(i+1)
4519         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4520         call transpose2(auxmat2(1,1),auxmat3(1,1))
4521         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4522         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4523      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4524 C Cartesian derivatives
4525         do l=1,3
4526 c            ghalf1=0.5d0*agg(l,1)
4527 c            ghalf2=0.5d0*agg(l,2)
4528 c            ghalf3=0.5d0*agg(l,3)
4529 c            ghalf4=0.5d0*agg(l,4)
4530           a_temp(1,1)=aggi(l,1)!+ghalf1
4531           a_temp(1,2)=aggi(l,2)!+ghalf2
4532           a_temp(2,1)=aggi(l,3)!+ghalf3
4533           a_temp(2,2)=aggi(l,4)!+ghalf4
4534           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4535           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4536      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4537           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4538           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4539           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4540           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4541           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4542           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4543      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4544           a_temp(1,1)=aggj(l,1)!+ghalf1
4545           a_temp(1,2)=aggj(l,2)!+ghalf2
4546           a_temp(2,1)=aggj(l,3)!+ghalf3
4547           a_temp(2,2)=aggj(l,4)!+ghalf4
4548           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4549           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4550      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4551           a_temp(1,1)=aggj1(l,1)
4552           a_temp(1,2)=aggj1(l,2)
4553           a_temp(2,1)=aggj1(l,3)
4554           a_temp(2,2)=aggj1(l,4)
4555           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4556           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4557      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4558         enddo
4559       return
4560       end
4561 C-------------------------------------------------------------------------------
4562       subroutine eturn4(i,eello_turn4)
4563 C Third- and fourth-order contributions from turns
4564       implicit real*8 (a-h,o-z)
4565       include 'DIMENSIONS'
4566       include 'COMMON.IOUNITS'
4567       include 'COMMON.GEO'
4568       include 'COMMON.VAR'
4569       include 'COMMON.LOCAL'
4570       include 'COMMON.CHAIN'
4571       include 'COMMON.DERIV'
4572       include 'COMMON.INTERACT'
4573       include 'COMMON.CONTACTS'
4574       include 'COMMON.TORSION'
4575       include 'COMMON.VECTORS'
4576       include 'COMMON.FFIELD'
4577       include 'COMMON.CONTROL'
4578       dimension ggg(3)
4579       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4580      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4581      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4582      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4583      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4584      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4585      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4586       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4587      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4588       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4589      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4590      &    num_conti,j1,j2
4591       j=i+3
4592 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4593 C
4594 C               Fourth-order contributions
4595 C
4596 C                 (i+3)o----(i+4)
4597 C                     /  |
4598 C               (i+2)o   |
4599 C                     \  |
4600 C                 (i+1)o----i
4601 C
4602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4603 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4604 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4605 c        write(iout,*)"WCHODZE W PROGRAM"
4606         a_temp(1,1)=a22
4607         a_temp(1,2)=a23
4608         a_temp(2,1)=a32
4609         a_temp(2,2)=a33
4610         iti1=itortyp(itype(i+1))
4611         iti2=itortyp(itype(i+2))
4612         iti3=itortyp(itype(i+3))
4613 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4614         call transpose2(EUg(1,1,i+1),e1t(1,1))
4615         call transpose2(Eug(1,1,i+2),e2t(1,1))
4616         call transpose2(Eug(1,1,i+3),e3t(1,1))
4617 C Ematrix derivative in theta
4618         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4619         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4620         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4621         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4622 c       eta1 in derivative theta
4623         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4624         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4625 c       auxgvec is derivative of Ub2 so i+3 theta
4626         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4627 c       auxalary matrix of E i+1
4628         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4629 c        s1=0.0
4630 c        gs1=0.0
4631         s1=scalar2(b1(1,i+2),auxvec(1))
4632 c derivative of theta i+2 with constant i+3
4633         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4634 c derivative of theta i+2 with constant i+2
4635         gs32=scalar2(b1(1,i+2),auxgvec(1))
4636 c derivative of E matix in theta of i+1
4637         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4638
4639         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4640 c       ea31 in derivative theta
4641         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4642         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4643 c auxilary matrix auxgvec of Ub2 with constant E matirx
4644         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4645 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4646         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4647
4648 c        s2=0.0
4649 c        gs2=0.0
4650         s2=scalar2(b1(1,i+1),auxvec(1))
4651 c derivative of theta i+1 with constant i+3
4652         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4653 c derivative of theta i+2 with constant i+1
4654         gs21=scalar2(b1(1,i+1),auxgvec(1))
4655 c derivative of theta i+3 with constant i+1
4656         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4657 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4658 c     &  gtb1(1,i+1)
4659         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4660 c two derivatives over diffetent matrices
4661 c gtae3e2 is derivative over i+3
4662         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4663 c ae3gte2 is derivative over i+2
4664         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4665         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4666 c three possible derivative over theta E matices
4667 c i+1
4668         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4669 c i+2
4670         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4671 c i+3
4672         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4673         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4674
4675         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4676         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4677         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4678
4679         eello_turn4=eello_turn4-(s1+s2+s3)
4680 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4681         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4682      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4683 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4684 cd     &    ' eello_turn4_num',8*eello_turn4_num
4685 #ifdef NEWCORR
4686         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4687      &                  -(gs13+gsE13+gsEE1)*wturn4
4688         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4689      &                    -(gs23+gs21+gsEE2)*wturn4
4690         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4691      &                    -(gs32+gsE31+gsEE3)*wturn4
4692 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4693 c     &   gs2
4694 #endif
4695         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4696      &      'eturn4',i,j,-(s1+s2+s3)
4697 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4698 c     &    ' eello_turn4_num',8*eello_turn4_num
4699 C Derivatives in gamma(i)
4700         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4701         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4702         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4703         s1=scalar2(b1(1,i+2),auxvec(1))
4704         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4705         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4706         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4707 C Derivatives in gamma(i+1)
4708         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4709         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4710         s2=scalar2(b1(1,i+1),auxvec(1))
4711         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4712         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4713         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4714         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4715 C Derivatives in gamma(i+2)
4716         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4717         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4718         s1=scalar2(b1(1,i+2),auxvec(1))
4719         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4720         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4721         s2=scalar2(b1(1,i+1),auxvec(1))
4722         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4723         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4724         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4725         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4726 C Cartesian derivatives
4727 C Derivatives of this turn contributions in DC(i+2)
4728         if (j.lt.nres-1) then
4729           do l=1,3
4730             a_temp(1,1)=agg(l,1)
4731             a_temp(1,2)=agg(l,2)
4732             a_temp(2,1)=agg(l,3)
4733             a_temp(2,2)=agg(l,4)
4734             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4735             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4736             s1=scalar2(b1(1,i+2),auxvec(1))
4737             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4738             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4739             s2=scalar2(b1(1,i+1),auxvec(1))
4740             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4741             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4742             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4743             ggg(l)=-(s1+s2+s3)
4744             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4745           enddo
4746         endif
4747 C Remaining derivatives of this turn contribution
4748         do l=1,3
4749           a_temp(1,1)=aggi(l,1)
4750           a_temp(1,2)=aggi(l,2)
4751           a_temp(2,1)=aggi(l,3)
4752           a_temp(2,2)=aggi(l,4)
4753           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4754           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4755           s1=scalar2(b1(1,i+2),auxvec(1))
4756           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4757           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4758           s2=scalar2(b1(1,i+1),auxvec(1))
4759           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4760           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4761           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4762           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4763           a_temp(1,1)=aggi1(l,1)
4764           a_temp(1,2)=aggi1(l,2)
4765           a_temp(2,1)=aggi1(l,3)
4766           a_temp(2,2)=aggi1(l,4)
4767           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4768           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4769           s1=scalar2(b1(1,i+2),auxvec(1))
4770           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4771           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4772           s2=scalar2(b1(1,i+1),auxvec(1))
4773           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4774           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4775           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4776           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4777           a_temp(1,1)=aggj(l,1)
4778           a_temp(1,2)=aggj(l,2)
4779           a_temp(2,1)=aggj(l,3)
4780           a_temp(2,2)=aggj(l,4)
4781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4783           s1=scalar2(b1(1,i+2),auxvec(1))
4784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4786           s2=scalar2(b1(1,i+1),auxvec(1))
4787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4790           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4791           a_temp(1,1)=aggj1(l,1)
4792           a_temp(1,2)=aggj1(l,2)
4793           a_temp(2,1)=aggj1(l,3)
4794           a_temp(2,2)=aggj1(l,4)
4795           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4796           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4797           s1=scalar2(b1(1,i+2),auxvec(1))
4798           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4799           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4800           s2=scalar2(b1(1,i+1),auxvec(1))
4801           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4802           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4803           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4804 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4805           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4806         enddo
4807       return
4808       end
4809 C-----------------------------------------------------------------------------
4810       subroutine vecpr(u,v,w)
4811       implicit real*8(a-h,o-z)
4812       dimension u(3),v(3),w(3)
4813       w(1)=u(2)*v(3)-u(3)*v(2)
4814       w(2)=-u(1)*v(3)+u(3)*v(1)
4815       w(3)=u(1)*v(2)-u(2)*v(1)
4816       return
4817       end
4818 C-----------------------------------------------------------------------------
4819       subroutine unormderiv(u,ugrad,unorm,ungrad)
4820 C This subroutine computes the derivatives of a normalized vector u, given
4821 C the derivatives computed without normalization conditions, ugrad. Returns
4822 C ungrad.
4823       implicit none
4824       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4825       double precision vec(3)
4826       double precision scalar
4827       integer i,j
4828 c      write (2,*) 'ugrad',ugrad
4829 c      write (2,*) 'u',u
4830       do i=1,3
4831         vec(i)=scalar(ugrad(1,i),u(1))
4832       enddo
4833 c      write (2,*) 'vec',vec
4834       do i=1,3
4835         do j=1,3
4836           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4837         enddo
4838       enddo
4839 c      write (2,*) 'ungrad',ungrad
4840       return
4841       end
4842 C-----------------------------------------------------------------------------
4843       subroutine escp_soft_sphere(evdw2,evdw2_14)
4844 C
4845 C This subroutine calculates the excluded-volume interaction energy between
4846 C peptide-group centers and side chains and its gradient in virtual-bond and
4847 C side-chain vectors.
4848 C
4849       implicit real*8 (a-h,o-z)
4850       include 'DIMENSIONS'
4851       include 'COMMON.GEO'
4852       include 'COMMON.VAR'
4853       include 'COMMON.LOCAL'
4854       include 'COMMON.CHAIN'
4855       include 'COMMON.DERIV'
4856       include 'COMMON.INTERACT'
4857       include 'COMMON.FFIELD'
4858       include 'COMMON.IOUNITS'
4859       include 'COMMON.CONTROL'
4860       dimension ggg(3)
4861       evdw2=0.0D0
4862       evdw2_14=0.0d0
4863       r0_scp=4.5d0
4864 cd    print '(a)','Enter ESCP'
4865 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4866 C      do xshift=-1,1
4867 C      do yshift=-1,1
4868 C      do zshift=-1,1
4869       do i=iatscp_s,iatscp_e
4870         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4871         iteli=itel(i)
4872         xi=0.5D0*(c(1,i)+c(1,i+1))
4873         yi=0.5D0*(c(2,i)+c(2,i+1))
4874         zi=0.5D0*(c(3,i)+c(3,i+1))
4875 C Return atom into box, boxxsize is size of box in x dimension
4876 c  134   continue
4877 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4878 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4879 C Condition for being inside the proper box
4880 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4881 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4882 c        go to 134
4883 c        endif
4884 c  135   continue
4885 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4886 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4887 C Condition for being inside the proper box
4888 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4889 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4890 c        go to 135
4891 c c       endif
4892 c  136   continue
4893 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4894 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4895 cC Condition for being inside the proper box
4896 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4897 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4898 c        go to 136
4899 c        endif
4900           xi=mod(xi,boxxsize)
4901           if (xi.lt.0) xi=xi+boxxsize
4902           yi=mod(yi,boxysize)
4903           if (yi.lt.0) yi=yi+boxysize
4904           zi=mod(zi,boxzsize)
4905           if (zi.lt.0) zi=zi+boxzsize
4906 C          xi=xi+xshift*boxxsize
4907 C          yi=yi+yshift*boxysize
4908 C          zi=zi+zshift*boxzsize
4909         do iint=1,nscp_gr(i)
4910
4911         do j=iscpstart(i,iint),iscpend(i,iint)
4912           if (itype(j).eq.ntyp1) cycle
4913           itypj=iabs(itype(j))
4914 C Uncomment following three lines for SC-p interactions
4915 c         xj=c(1,nres+j)-xi
4916 c         yj=c(2,nres+j)-yi
4917 c         zj=c(3,nres+j)-zi
4918 C Uncomment following three lines for Ca-p interactions
4919           xj=c(1,j)
4920           yj=c(2,j)
4921           zj=c(3,j)
4922 c  174   continue
4923 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4924 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4925 C Condition for being inside the proper box
4926 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4927 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4928 c        go to 174
4929 c        endif
4930 c  175   continue
4931 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4932 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4933 cC Condition for being inside the proper box
4934 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4935 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4936 c        go to 175
4937 c        endif
4938 c  176   continue
4939 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4940 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4941 C Condition for being inside the proper box
4942 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4943 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4944 c        go to 176
4945           xj=mod(xj,boxxsize)
4946           if (xj.lt.0) xj=xj+boxxsize
4947           yj=mod(yj,boxysize)
4948           if (yj.lt.0) yj=yj+boxysize
4949           zj=mod(zj,boxzsize)
4950           if (zj.lt.0) zj=zj+boxzsize
4951       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4952       xj_safe=xj
4953       yj_safe=yj
4954       zj_safe=zj
4955       subchap=0
4956       do xshift=-1,1
4957       do yshift=-1,1
4958       do zshift=-1,1
4959           xj=xj_safe+xshift*boxxsize
4960           yj=yj_safe+yshift*boxysize
4961           zj=zj_safe+zshift*boxzsize
4962           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4963           if(dist_temp.lt.dist_init) then
4964             dist_init=dist_temp
4965             xj_temp=xj
4966             yj_temp=yj
4967             zj_temp=zj
4968             subchap=1
4969           endif
4970        enddo
4971        enddo
4972        enddo
4973        if (subchap.eq.1) then
4974           xj=xj_temp-xi
4975           yj=yj_temp-yi
4976           zj=zj_temp-zi
4977        else
4978           xj=xj_safe-xi
4979           yj=yj_safe-yi
4980           zj=zj_safe-zi
4981        endif
4982 c c       endif
4983 C          xj=xj-xi
4984 C          yj=yj-yi
4985 C          zj=zj-zi
4986           rij=xj*xj+yj*yj+zj*zj
4987
4988           r0ij=r0_scp
4989           r0ijsq=r0ij*r0ij
4990           if (rij.lt.r0ijsq) then
4991             evdwij=0.25d0*(rij-r0ijsq)**2
4992             fac=rij-r0ijsq
4993           else
4994             evdwij=0.0d0
4995             fac=0.0d0
4996           endif
4997           evdw2=evdw2+evdwij
4998 C
4999 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5000 C
5001           ggg(1)=xj*fac
5002           ggg(2)=yj*fac
5003           ggg(3)=zj*fac
5004 cgrad          if (j.lt.i) then
5005 cd          write (iout,*) 'j<i'
5006 C Uncomment following three lines for SC-p interactions
5007 c           do k=1,3
5008 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5009 c           enddo
5010 cgrad          else
5011 cd          write (iout,*) 'j>i'
5012 cgrad            do k=1,3
5013 cgrad              ggg(k)=-ggg(k)
5014 C Uncomment following line for SC-p interactions
5015 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5016 cgrad            enddo
5017 cgrad          endif
5018 cgrad          do k=1,3
5019 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5020 cgrad          enddo
5021 cgrad          kstart=min0(i+1,j)
5022 cgrad          kend=max0(i-1,j-1)
5023 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5024 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5025 cgrad          do k=kstart,kend
5026 cgrad            do l=1,3
5027 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5028 cgrad            enddo
5029 cgrad          enddo
5030           do k=1,3
5031             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5032             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5033           enddo
5034         enddo
5035
5036         enddo ! iint
5037       enddo ! i
5038 C      enddo !zshift
5039 C      enddo !yshift
5040 C      enddo !xshift
5041       return
5042       end
5043 C-----------------------------------------------------------------------------
5044       subroutine escp(evdw2,evdw2_14)
5045 C
5046 C This subroutine calculates the excluded-volume interaction energy between
5047 C peptide-group centers and side chains and its gradient in virtual-bond and
5048 C side-chain vectors.
5049 C
5050       implicit real*8 (a-h,o-z)
5051       include 'DIMENSIONS'
5052       include 'COMMON.GEO'
5053       include 'COMMON.VAR'
5054       include 'COMMON.LOCAL'
5055       include 'COMMON.CHAIN'
5056       include 'COMMON.DERIV'
5057       include 'COMMON.INTERACT'
5058       include 'COMMON.FFIELD'
5059       include 'COMMON.IOUNITS'
5060       include 'COMMON.CONTROL'
5061       include 'COMMON.SPLITELE'
5062       dimension ggg(3)
5063       evdw2=0.0D0
5064       evdw2_14=0.0d0
5065 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5066 cd    print '(a)','Enter ESCP'
5067 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5068 C      do xshift=-1,1
5069 C      do yshift=-1,1
5070 C      do zshift=-1,1
5071       do i=iatscp_s,iatscp_e
5072         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5073         iteli=itel(i)
5074         xi=0.5D0*(c(1,i)+c(1,i+1))
5075         yi=0.5D0*(c(2,i)+c(2,i+1))
5076         zi=0.5D0*(c(3,i)+c(3,i+1))
5077           xi=mod(xi,boxxsize)
5078           if (xi.lt.0) xi=xi+boxxsize
5079           yi=mod(yi,boxysize)
5080           if (yi.lt.0) yi=yi+boxysize
5081           zi=mod(zi,boxzsize)
5082           if (zi.lt.0) zi=zi+boxzsize
5083 c          xi=xi+xshift*boxxsize
5084 c          yi=yi+yshift*boxysize
5085 c          zi=zi+zshift*boxzsize
5086 c        print *,xi,yi,zi,'polozenie i'
5087 C Return atom into box, boxxsize is size of box in x dimension
5088 c  134   continue
5089 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5090 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5091 C Condition for being inside the proper box
5092 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5093 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5094 c        go to 134
5095 c        endif
5096 c  135   continue
5097 c          print *,xi,boxxsize,"pierwszy"
5098
5099 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5100 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5101 C Condition for being inside the proper box
5102 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5103 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5104 c        go to 135
5105 c        endif
5106 c  136   continue
5107 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5108 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5109 C Condition for being inside the proper box
5110 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5111 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5112 c        go to 136
5113 c        endif
5114         do iint=1,nscp_gr(i)
5115
5116         do j=iscpstart(i,iint),iscpend(i,iint)
5117           itypj=iabs(itype(j))
5118           if (itypj.eq.ntyp1) cycle
5119 C Uncomment following three lines for SC-p interactions
5120 c         xj=c(1,nres+j)-xi
5121 c         yj=c(2,nres+j)-yi
5122 c         zj=c(3,nres+j)-zi
5123 C Uncomment following three lines for Ca-p interactions
5124           xj=c(1,j)
5125           yj=c(2,j)
5126           zj=c(3,j)
5127           xj=mod(xj,boxxsize)
5128           if (xj.lt.0) xj=xj+boxxsize
5129           yj=mod(yj,boxysize)
5130           if (yj.lt.0) yj=yj+boxysize
5131           zj=mod(zj,boxzsize)
5132           if (zj.lt.0) zj=zj+boxzsize
5133 c  174   continue
5134 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5135 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5136 C Condition for being inside the proper box
5137 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5138 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5139 c        go to 174
5140 c        endif
5141 c  175   continue
5142 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5143 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5144 cC Condition for being inside the proper box
5145 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5146 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5147 c        go to 175
5148 c        endif
5149 c  176   continue
5150 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5151 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5152 C Condition for being inside the proper box
5153 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5154 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5155 c        go to 176
5156 c        endif
5157 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5158       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5159       xj_safe=xj
5160       yj_safe=yj
5161       zj_safe=zj
5162       subchap=0
5163       do xshift=-1,1
5164       do yshift=-1,1
5165       do zshift=-1,1
5166           xj=xj_safe+xshift*boxxsize
5167           yj=yj_safe+yshift*boxysize
5168           zj=zj_safe+zshift*boxzsize
5169           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5170           if(dist_temp.lt.dist_init) then
5171             dist_init=dist_temp
5172             xj_temp=xj
5173             yj_temp=yj
5174             zj_temp=zj
5175             subchap=1
5176           endif
5177        enddo
5178        enddo
5179        enddo
5180        if (subchap.eq.1) then
5181           xj=xj_temp-xi
5182           yj=yj_temp-yi
5183           zj=zj_temp-zi
5184        else
5185           xj=xj_safe-xi
5186           yj=yj_safe-yi
5187           zj=zj_safe-zi
5188        endif
5189 c          print *,xj,yj,zj,'polozenie j'
5190           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5191 c          print *,rrij
5192           sss=sscale(1.0d0/(dsqrt(rrij)))
5193 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5194 c          if (sss.eq.0) print *,'czasem jest OK'
5195           if (sss.le.0.0d0) cycle
5196           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5197           fac=rrij**expon2
5198           e1=fac*fac*aad(itypj,iteli)
5199           e2=fac*bad(itypj,iteli)
5200           if (iabs(j-i) .le. 2) then
5201             e1=scal14*e1
5202             e2=scal14*e2
5203             evdw2_14=evdw2_14+(e1+e2)*sss
5204           endif
5205           evdwij=e1+e2
5206           evdw2=evdw2+evdwij*sss
5207           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5208      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5209      &       bad(itypj,iteli)
5210 C
5211 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5212 C
5213           fac=-(evdwij+e1)*rrij*sss
5214           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5215           ggg(1)=xj*fac
5216           ggg(2)=yj*fac
5217           ggg(3)=zj*fac
5218 cgrad          if (j.lt.i) then
5219 cd          write (iout,*) 'j<i'
5220 C Uncomment following three lines for SC-p interactions
5221 c           do k=1,3
5222 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5223 c           enddo
5224 cgrad          else
5225 cd          write (iout,*) 'j>i'
5226 cgrad            do k=1,3
5227 cgrad              ggg(k)=-ggg(k)
5228 C Uncomment following line for SC-p interactions
5229 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5230 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5231 cgrad            enddo
5232 cgrad          endif
5233 cgrad          do k=1,3
5234 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5235 cgrad          enddo
5236 cgrad          kstart=min0(i+1,j)
5237 cgrad          kend=max0(i-1,j-1)
5238 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5239 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5240 cgrad          do k=kstart,kend
5241 cgrad            do l=1,3
5242 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5243 cgrad            enddo
5244 cgrad          enddo
5245           do k=1,3
5246             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5247             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5248           enddo
5249 c        endif !endif for sscale cutoff
5250         enddo ! j
5251
5252         enddo ! iint
5253       enddo ! i
5254 c      enddo !zshift
5255 c      enddo !yshift
5256 c      enddo !xshift
5257       do i=1,nct
5258         do j=1,3
5259           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5260           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5261           gradx_scp(j,i)=expon*gradx_scp(j,i)
5262         enddo
5263       enddo
5264 C******************************************************************************
5265 C
5266 C                              N O T E !!!
5267 C
5268 C To save time the factor EXPON has been extracted from ALL components
5269 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5270 C use!
5271 C
5272 C******************************************************************************
5273       return
5274       end
5275 C--------------------------------------------------------------------------
5276       subroutine edis(ehpb)
5277 C
5278 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5279 C
5280       implicit real*8 (a-h,o-z)
5281       include 'DIMENSIONS'
5282       include 'COMMON.SBRIDGE'
5283       include 'COMMON.CHAIN'
5284       include 'COMMON.DERIV'
5285       include 'COMMON.VAR'
5286       include 'COMMON.INTERACT'
5287       include 'COMMON.IOUNITS'
5288       include 'COMMON.CONTROL'
5289       dimension ggg(3)
5290       ehpb=0.0D0
5291       do i=1,3
5292        ggg(i)=0.0d0
5293       enddo
5294 C      write (iout,*) ,"link_end",link_end,constr_dist
5295 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5296 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5297       if (link_end.eq.0) return
5298       do i=link_start,link_end
5299 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5300 C CA-CA distance used in regularization of structure.
5301         ii=ihpb(i)
5302         jj=jhpb(i)
5303 C iii and jjj point to the residues for which the distance is assigned.
5304         if (ii.gt.nres) then
5305           iii=ii-nres
5306           jjj=jj-nres
5307         else
5308           iii=ii
5309           jjj=jj
5310         endif
5311 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5312 c     &    dhpb(i),dhpb1(i),forcon(i)
5313 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5314 C    distance and angle dependent SS bond potential.
5315 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5316 C     & iabs(itype(jjj)).eq.1) then
5317 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5318 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5319         if (.not.dyn_ss .and. i.le.nss) then
5320 C 15/02/13 CC dynamic SSbond - additional check
5321          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5322      & iabs(itype(jjj)).eq.1) then
5323           call ssbond_ene(iii,jjj,eij)
5324           ehpb=ehpb+2*eij
5325          endif
5326 cd          write (iout,*) "eij",eij
5327 cd   &   ' waga=',waga,' fac=',fac
5328         else if (ii.gt.nres .and. jj.gt.nres) then
5329 c Restraints from contact prediction
5330           dd=dist(ii,jj)
5331           if (constr_dist.eq.11) then
5332             ehpb=ehpb+fordepth(i)**4.0d0
5333      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5334             fac=fordepth(i)**4.0d0
5335      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5336           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5337      &    ehpb,fordepth(i),dd
5338            else
5339           if (dhpb1(i).gt.0.0d0) then
5340             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5341             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5342 c            write (iout,*) "beta nmr",
5343 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5344           else
5345             dd=dist(ii,jj)
5346             rdis=dd-dhpb(i)
5347 C Get the force constant corresponding to this distance.
5348             waga=forcon(i)
5349 C Calculate the contribution to energy.
5350             ehpb=ehpb+waga*rdis*rdis
5351 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5352 C
5353 C Evaluate gradient.
5354 C
5355             fac=waga*rdis/dd
5356           endif
5357           endif
5358           do j=1,3
5359             ggg(j)=fac*(c(j,jj)-c(j,ii))
5360           enddo
5361           do j=1,3
5362             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5363             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5364           enddo
5365           do k=1,3
5366             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5367             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5368           enddo
5369         else
5370 C Calculate the distance between the two points and its difference from the
5371 C target distance.
5372           dd=dist(ii,jj)
5373           if (constr_dist.eq.11) then
5374             ehpb=ehpb+fordepth(i)**4.0d0
5375      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5376             fac=fordepth(i)**4.0d0
5377      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5378           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5379      &    ehpb,fordepth(i),dd
5380            else
5381           if (dhpb1(i).gt.0.0d0) then
5382             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5383             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5384 c            write (iout,*) "alph nmr",
5385 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5386           else
5387             rdis=dd-dhpb(i)
5388 C Get the force constant corresponding to this distance.
5389             waga=forcon(i)
5390 C Calculate the contribution to energy.
5391             ehpb=ehpb+waga*rdis*rdis
5392 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5393 C
5394 C Evaluate gradient.
5395 C
5396             fac=waga*rdis/dd
5397           endif
5398           endif
5399             do j=1,3
5400               ggg(j)=fac*(c(j,jj)-c(j,ii))
5401             enddo
5402 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5403 C If this is a SC-SC distance, we need to calculate the contributions to the
5404 C Cartesian gradient in the SC vectors (ghpbx).
5405           if (iii.lt.ii) then
5406           do j=1,3
5407             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5408             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5409           enddo
5410           endif
5411 cgrad        do j=iii,jjj-1
5412 cgrad          do k=1,3
5413 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5414 cgrad          enddo
5415 cgrad        enddo
5416           do k=1,3
5417             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5418             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5419           enddo
5420         endif
5421       enddo
5422       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5423       return
5424       end
5425 C--------------------------------------------------------------------------
5426       subroutine ssbond_ene(i,j,eij)
5427 C
5428 C Calculate the distance and angle dependent SS-bond potential energy
5429 C using a free-energy function derived based on RHF/6-31G** ab initio
5430 C calculations of diethyl disulfide.
5431 C
5432 C A. Liwo and U. Kozlowska, 11/24/03
5433 C
5434       implicit real*8 (a-h,o-z)
5435       include 'DIMENSIONS'
5436       include 'COMMON.SBRIDGE'
5437       include 'COMMON.CHAIN'
5438       include 'COMMON.DERIV'
5439       include 'COMMON.LOCAL'
5440       include 'COMMON.INTERACT'
5441       include 'COMMON.VAR'
5442       include 'COMMON.IOUNITS'
5443       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5444       itypi=iabs(itype(i))
5445       xi=c(1,nres+i)
5446       yi=c(2,nres+i)
5447       zi=c(3,nres+i)
5448       dxi=dc_norm(1,nres+i)
5449       dyi=dc_norm(2,nres+i)
5450       dzi=dc_norm(3,nres+i)
5451 c      dsci_inv=dsc_inv(itypi)
5452       dsci_inv=vbld_inv(nres+i)
5453       itypj=iabs(itype(j))
5454 c      dscj_inv=dsc_inv(itypj)
5455       dscj_inv=vbld_inv(nres+j)
5456       xj=c(1,nres+j)-xi
5457       yj=c(2,nres+j)-yi
5458       zj=c(3,nres+j)-zi
5459       dxj=dc_norm(1,nres+j)
5460       dyj=dc_norm(2,nres+j)
5461       dzj=dc_norm(3,nres+j)
5462       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5463       rij=dsqrt(rrij)
5464       erij(1)=xj*rij
5465       erij(2)=yj*rij
5466       erij(3)=zj*rij
5467       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5468       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5469       om12=dxi*dxj+dyi*dyj+dzi*dzj
5470       do k=1,3
5471         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5472         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5473       enddo
5474       rij=1.0d0/rij
5475       deltad=rij-d0cm
5476       deltat1=1.0d0-om1
5477       deltat2=1.0d0+om2
5478       deltat12=om2-om1+2.0d0
5479       cosphi=om12-om1*om2
5480       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5481      &  +akct*deltad*deltat12
5482      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5483 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5484 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5485 c     &  " deltat12",deltat12," eij",eij
5486       ed=2*akcm*deltad+akct*deltat12
5487       pom1=akct*deltad
5488       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5489       eom1=-2*akth*deltat1-pom1-om2*pom2
5490       eom2= 2*akth*deltat2+pom1-om1*pom2
5491       eom12=pom2
5492       do k=1,3
5493         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5494         ghpbx(k,i)=ghpbx(k,i)-ggk
5495      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5496      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5497         ghpbx(k,j)=ghpbx(k,j)+ggk
5498      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5499      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5500         ghpbc(k,i)=ghpbc(k,i)-ggk
5501         ghpbc(k,j)=ghpbc(k,j)+ggk
5502       enddo
5503 C
5504 C Calculate the components of the gradient in DC and X
5505 C
5506 cgrad      do k=i,j-1
5507 cgrad        do l=1,3
5508 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5509 cgrad        enddo
5510 cgrad      enddo
5511       return
5512       end
5513 C--------------------------------------------------------------------------
5514       subroutine ebond(estr)
5515 c
5516 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5517 c
5518       implicit real*8 (a-h,o-z)
5519       include 'DIMENSIONS'
5520       include 'COMMON.LOCAL'
5521       include 'COMMON.GEO'
5522       include 'COMMON.INTERACT'
5523       include 'COMMON.DERIV'
5524       include 'COMMON.VAR'
5525       include 'COMMON.CHAIN'
5526       include 'COMMON.IOUNITS'
5527       include 'COMMON.NAMES'
5528       include 'COMMON.FFIELD'
5529       include 'COMMON.CONTROL'
5530       include 'COMMON.SETUP'
5531       double precision u(3),ud(3)
5532       estr=0.0d0
5533       estr1=0.0d0
5534       do i=ibondp_start,ibondp_end
5535         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5536 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5537 c          do j=1,3
5538 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5539 c     &      *dc(j,i-1)/vbld(i)
5540 c          enddo
5541 c          if (energy_dec) write(iout,*)
5542 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5543 c        else
5544 C       Checking if it involves dummy (NH3+ or COO-) group
5545          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5546 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5547         diff = vbld(i)-vbldpDUM
5548          else
5549 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5550         diff = vbld(i)-vbldp0
5551          endif
5552         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5553      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5554         estr=estr+diff*diff
5555         do j=1,3
5556           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5557         enddo
5558 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5559 c        endif
5560       enddo
5561       estr=0.5d0*AKP*estr+estr1
5562 c
5563 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5564 c
5565       do i=ibond_start,ibond_end
5566         iti=iabs(itype(i))
5567         if (iti.ne.10 .and. iti.ne.ntyp1) then
5568           nbi=nbondterm(iti)
5569           if (nbi.eq.1) then
5570             diff=vbld(i+nres)-vbldsc0(1,iti)
5571             if (energy_dec)  write (iout,*)
5572      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5573      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5574             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5575             do j=1,3
5576               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5577             enddo
5578           else
5579             do j=1,nbi
5580               diff=vbld(i+nres)-vbldsc0(j,iti)
5581               ud(j)=aksc(j,iti)*diff
5582               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5583             enddo
5584             uprod=u(1)
5585             do j=2,nbi
5586               uprod=uprod*u(j)
5587             enddo
5588             usum=0.0d0
5589             usumsqder=0.0d0
5590             do j=1,nbi
5591               uprod1=1.0d0
5592               uprod2=1.0d0
5593               do k=1,nbi
5594                 if (k.ne.j) then
5595                   uprod1=uprod1*u(k)
5596                   uprod2=uprod2*u(k)*u(k)
5597                 endif
5598               enddo
5599               usum=usum+uprod1
5600               usumsqder=usumsqder+ud(j)*uprod2
5601             enddo
5602             estr=estr+uprod/usum
5603             do j=1,3
5604              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5605             enddo
5606           endif
5607         endif
5608       enddo
5609       return
5610       end
5611 #ifdef CRYST_THETA
5612 C--------------------------------------------------------------------------
5613       subroutine ebend(etheta,ethetacnstr)
5614 C
5615 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5616 C angles gamma and its derivatives in consecutive thetas and gammas.
5617 C
5618       implicit real*8 (a-h,o-z)
5619       include 'DIMENSIONS'
5620       include 'COMMON.LOCAL'
5621       include 'COMMON.GEO'
5622       include 'COMMON.INTERACT'
5623       include 'COMMON.DERIV'
5624       include 'COMMON.VAR'
5625       include 'COMMON.CHAIN'
5626       include 'COMMON.IOUNITS'
5627       include 'COMMON.NAMES'
5628       include 'COMMON.FFIELD'
5629       include 'COMMON.CONTROL'
5630       include 'COMMON.TORCNSTR'
5631       common /calcthet/ term1,term2,termm,diffak,ratak,
5632      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5633      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5634       double precision y(2),z(2)
5635       delta=0.02d0*pi
5636 c      time11=dexp(-2*time)
5637 c      time12=1.0d0
5638       etheta=0.0D0
5639 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5640       do i=ithet_start,ithet_end
5641         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5642      &  .or.itype(i).eq.ntyp1) cycle
5643 C Zero the energy function and its derivative at 0 or pi.
5644         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5645         it=itype(i-1)
5646         ichir1=isign(1,itype(i-2))
5647         ichir2=isign(1,itype(i))
5648          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5649          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5650          if (itype(i-1).eq.10) then
5651           itype1=isign(10,itype(i-2))
5652           ichir11=isign(1,itype(i-2))
5653           ichir12=isign(1,itype(i-2))
5654           itype2=isign(10,itype(i))
5655           ichir21=isign(1,itype(i))
5656           ichir22=isign(1,itype(i))
5657          endif
5658
5659         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5660 #ifdef OSF
5661           phii=phi(i)
5662           if (phii.ne.phii) phii=150.0
5663 #else
5664           phii=phi(i)
5665 #endif
5666           y(1)=dcos(phii)
5667           y(2)=dsin(phii)
5668         else
5669           y(1)=0.0D0
5670           y(2)=0.0D0
5671         endif
5672         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5673 #ifdef OSF
5674           phii1=phi(i+1)
5675           if (phii1.ne.phii1) phii1=150.0
5676           phii1=pinorm(phii1)
5677           z(1)=cos(phii1)
5678 #else
5679           phii1=phi(i+1)
5680 #endif
5681           z(1)=dcos(phii1)
5682           z(2)=dsin(phii1)
5683         else
5684           z(1)=0.0D0
5685           z(2)=0.0D0
5686         endif
5687 C Calculate the "mean" value of theta from the part of the distribution
5688 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5689 C In following comments this theta will be referred to as t_c.
5690         thet_pred_mean=0.0d0
5691         do k=1,2
5692             athetk=athet(k,it,ichir1,ichir2)
5693             bthetk=bthet(k,it,ichir1,ichir2)
5694           if (it.eq.10) then
5695              athetk=athet(k,itype1,ichir11,ichir12)
5696              bthetk=bthet(k,itype2,ichir21,ichir22)
5697           endif
5698          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5699 c         write(iout,*) 'chuj tu', y(k),z(k)
5700         enddo
5701         dthett=thet_pred_mean*ssd
5702         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5703 C Derivatives of the "mean" values in gamma1 and gamma2.
5704         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5705      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5706          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5707      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5708          if (it.eq.10) then
5709       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5710      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5711         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5712      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5713          endif
5714         if (theta(i).gt.pi-delta) then
5715           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5716      &         E_tc0)
5717           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5718           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5719           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5720      &        E_theta)
5721           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5722      &        E_tc)
5723         else if (theta(i).lt.delta) then
5724           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5725           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5726           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5727      &        E_theta)
5728           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5729           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5730      &        E_tc)
5731         else
5732           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5733      &        E_theta,E_tc)
5734         endif
5735         etheta=etheta+ethetai
5736         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5737      &      'ebend',i,ethetai,theta(i),itype(i)
5738         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5739         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5740         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5741       enddo
5742       ethetacnstr=0.0d0
5743 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5744       do i=ithetaconstr_start,ithetaconstr_end
5745         itheta=itheta_constr(i)
5746         thetiii=theta(itheta)
5747         difi=pinorm(thetiii-theta_constr0(i))
5748         if (difi.gt.theta_drange(i)) then
5749           difi=difi-theta_drange(i)
5750           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5751           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5752      &    +for_thet_constr(i)*difi**3
5753         else if (difi.lt.-drange(i)) then
5754           difi=difi+drange(i)
5755           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5756           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5757      &    +for_thet_constr(i)*difi**3
5758         else
5759           difi=0.0
5760         endif
5761        if (energy_dec) then
5762         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5763      &    i,itheta,rad2deg*thetiii,
5764      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5765      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5766      &    gloc(itheta+nphi-2,icg)
5767         endif
5768       enddo
5769
5770 C Ufff.... We've done all this!!!
5771       return
5772       end
5773 C---------------------------------------------------------------------------
5774       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5775      &     E_tc)
5776       implicit real*8 (a-h,o-z)
5777       include 'DIMENSIONS'
5778       include 'COMMON.LOCAL'
5779       include 'COMMON.IOUNITS'
5780       common /calcthet/ term1,term2,termm,diffak,ratak,
5781      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5782      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5783 C Calculate the contributions to both Gaussian lobes.
5784 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5785 C The "polynomial part" of the "standard deviation" of this part of
5786 C the distributioni.
5787 ccc        write (iout,*) thetai,thet_pred_mean
5788         sig=polthet(3,it)
5789         do j=2,0,-1
5790           sig=sig*thet_pred_mean+polthet(j,it)
5791         enddo
5792 C Derivative of the "interior part" of the "standard deviation of the"
5793 C gamma-dependent Gaussian lobe in t_c.
5794         sigtc=3*polthet(3,it)
5795         do j=2,1,-1
5796           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5797         enddo
5798         sigtc=sig*sigtc
5799 C Set the parameters of both Gaussian lobes of the distribution.
5800 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5801         fac=sig*sig+sigc0(it)
5802         sigcsq=fac+fac
5803         sigc=1.0D0/sigcsq
5804 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5805         sigsqtc=-4.0D0*sigcsq*sigtc
5806 c       print *,i,sig,sigtc,sigsqtc
5807 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5808         sigtc=-sigtc/(fac*fac)
5809 C Following variable is sigma(t_c)**(-2)
5810         sigcsq=sigcsq*sigcsq
5811         sig0i=sig0(it)
5812         sig0inv=1.0D0/sig0i**2
5813         delthec=thetai-thet_pred_mean
5814         delthe0=thetai-theta0i
5815         term1=-0.5D0*sigcsq*delthec*delthec
5816         term2=-0.5D0*sig0inv*delthe0*delthe0
5817 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5818 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5819 C NaNs in taking the logarithm. We extract the largest exponent which is added
5820 C to the energy (this being the log of the distribution) at the end of energy
5821 C term evaluation for this virtual-bond angle.
5822         if (term1.gt.term2) then
5823           termm=term1
5824           term2=dexp(term2-termm)
5825           term1=1.0d0
5826         else
5827           termm=term2
5828           term1=dexp(term1-termm)
5829           term2=1.0d0
5830         endif
5831 C The ratio between the gamma-independent and gamma-dependent lobes of
5832 C the distribution is a Gaussian function of thet_pred_mean too.
5833         diffak=gthet(2,it)-thet_pred_mean
5834         ratak=diffak/gthet(3,it)**2
5835         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5836 C Let's differentiate it in thet_pred_mean NOW.
5837         aktc=ak*ratak
5838 C Now put together the distribution terms to make complete distribution.
5839         termexp=term1+ak*term2
5840         termpre=sigc+ak*sig0i
5841 C Contribution of the bending energy from this theta is just the -log of
5842 C the sum of the contributions from the two lobes and the pre-exponential
5843 C factor. Simple enough, isn't it?
5844         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5845 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5846 C NOW the derivatives!!!
5847 C 6/6/97 Take into account the deformation.
5848         E_theta=(delthec*sigcsq*term1
5849      &       +ak*delthe0*sig0inv*term2)/termexp
5850         E_tc=((sigtc+aktc*sig0i)/termpre
5851      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5852      &       aktc*term2)/termexp)
5853       return
5854       end
5855 c-----------------------------------------------------------------------------
5856       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5857       implicit real*8 (a-h,o-z)
5858       include 'DIMENSIONS'
5859       include 'COMMON.LOCAL'
5860       include 'COMMON.IOUNITS'
5861       common /calcthet/ term1,term2,termm,diffak,ratak,
5862      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5863      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5864       delthec=thetai-thet_pred_mean
5865       delthe0=thetai-theta0i
5866 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5867       t3 = thetai-thet_pred_mean
5868       t6 = t3**2
5869       t9 = term1
5870       t12 = t3*sigcsq
5871       t14 = t12+t6*sigsqtc
5872       t16 = 1.0d0
5873       t21 = thetai-theta0i
5874       t23 = t21**2
5875       t26 = term2
5876       t27 = t21*t26
5877       t32 = termexp
5878       t40 = t32**2
5879       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5880      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5881      & *(-t12*t9-ak*sig0inv*t27)
5882       return
5883       end
5884 #else
5885 C--------------------------------------------------------------------------
5886       subroutine ebend(etheta,ethetacnstr)
5887 C
5888 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5889 C angles gamma and its derivatives in consecutive thetas and gammas.
5890 C ab initio-derived potentials from
5891 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5892 C
5893       implicit real*8 (a-h,o-z)
5894       include 'DIMENSIONS'
5895       include 'COMMON.LOCAL'
5896       include 'COMMON.GEO'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.DERIV'
5899       include 'COMMON.VAR'
5900       include 'COMMON.CHAIN'
5901       include 'COMMON.IOUNITS'
5902       include 'COMMON.NAMES'
5903       include 'COMMON.FFIELD'
5904       include 'COMMON.CONTROL'
5905       include 'COMMON.TORCNSTR'
5906       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5907      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5908      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5909      & sinph1ph2(maxdouble,maxdouble)
5910       logical lprn /.false./, lprn1 /.false./
5911       etheta=0.0D0
5912       do i=ithet_start,ithet_end
5913         if (i.le.2) cycle
5914 c        print *,i,itype(i-1),itype(i),itype(i-2)
5915         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5916      &  .or.itype(i).eq.ntyp1) cycle
5917 C        print *,i,theta(i)
5918         if (iabs(itype(i+1)).eq.20) iblock=2
5919         if (iabs(itype(i+1)).ne.20) iblock=1
5920         dethetai=0.0d0
5921         dephii=0.0d0
5922         dephii1=0.0d0
5923         theti2=0.5d0*theta(i)
5924         ityp2=ithetyp((itype(i-1)))
5925         do k=1,nntheterm
5926           coskt(k)=dcos(k*theti2)
5927           sinkt(k)=dsin(k*theti2)
5928         enddo
5929 C        print *,ethetai
5930         if (i.eq.3) then
5931           phii=0.0d0
5932           ityp1=nthetyp+1
5933           do k=1,nsingle
5934             cosph1(k)=0.0d0
5935             sinph1(k)=0.0d0
5936           enddo
5937         else
5938
5939         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5940 #ifdef OSF
5941           phii=phi(i)
5942           if (phii.ne.phii) phii=150.0
5943 #else
5944           phii=phi(i)
5945 #endif
5946           ityp1=ithetyp((itype(i-2)))
5947 C propagation of chirality for glycine type
5948           do k=1,nsingle
5949             cosph1(k)=dcos(k*phii)
5950             sinph1(k)=dsin(k*phii)
5951           enddo
5952         else
5953           phii=0.0d0
5954           do k=1,nsingle
5955           ityp1=ithetyp((itype(i-2)))
5956             cosph1(k)=0.0d0
5957             sinph1(k)=0.0d0
5958           enddo
5959         endif
5960         endif
5961         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5962 #ifdef OSF
5963           phii1=phi(i+1)
5964           if (phii1.ne.phii1) phii1=150.0
5965           phii1=pinorm(phii1)
5966 #else
5967           phii1=phi(i+1)
5968 #endif
5969           ityp3=ithetyp((itype(i)))
5970           do k=1,nsingle
5971             cosph2(k)=dcos(k*phii1)
5972             sinph2(k)=dsin(k*phii1)
5973           enddo
5974         else
5975           phii1=0.0d0
5976           ityp3=ithetyp((itype(i)))
5977           do k=1,nsingle
5978             cosph2(k)=0.0d0
5979             sinph2(k)=0.0d0
5980           enddo
5981         endif
5982         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5983         do k=1,ndouble
5984           do l=1,k-1
5985             ccl=cosph1(l)*cosph2(k-l)
5986             ssl=sinph1(l)*sinph2(k-l)
5987             scl=sinph1(l)*cosph2(k-l)
5988             csl=cosph1(l)*sinph2(k-l)
5989             cosph1ph2(l,k)=ccl-ssl
5990             cosph1ph2(k,l)=ccl+ssl
5991             sinph1ph2(l,k)=scl+csl
5992             sinph1ph2(k,l)=scl-csl
5993           enddo
5994         enddo
5995         if (lprn) then
5996         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5997      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5998         write (iout,*) "coskt and sinkt"
5999         do k=1,nntheterm
6000           write (iout,*) k,coskt(k),sinkt(k)
6001         enddo
6002         endif
6003         do k=1,ntheterm
6004           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6005           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6006      &      *coskt(k)
6007           if (lprn)
6008      &    write (iout,*) "k",k,"
6009      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6010      &     " ethetai",ethetai
6011         enddo
6012         if (lprn) then
6013         write (iout,*) "cosph and sinph"
6014         do k=1,nsingle
6015           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6016         enddo
6017         write (iout,*) "cosph1ph2 and sinph2ph2"
6018         do k=2,ndouble
6019           do l=1,k-1
6020             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6021      &         sinph1ph2(l,k),sinph1ph2(k,l)
6022           enddo
6023         enddo
6024         write(iout,*) "ethetai",ethetai
6025         endif
6026 C       print *,ethetai
6027         do m=1,ntheterm2
6028           do k=1,nsingle
6029             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6030      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6031      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6032      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6033             ethetai=ethetai+sinkt(m)*aux
6034             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6035             dephii=dephii+k*sinkt(m)*(
6036      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6037      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6038             dephii1=dephii1+k*sinkt(m)*(
6039      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6040      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6041             if (lprn)
6042      &      write (iout,*) "m",m," k",k," bbthet",
6043      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6044      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6045      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6046      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6047 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6048           enddo
6049         enddo
6050 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6051 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6052 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6053 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6054         if (lprn)
6055      &  write(iout,*) "ethetai",ethetai
6056 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6057         do m=1,ntheterm3
6058           do k=2,ndouble
6059             do l=1,k-1
6060               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6061      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6062      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6063      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6064               ethetai=ethetai+sinkt(m)*aux
6065               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6066               dephii=dephii+l*sinkt(m)*(
6067      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6068      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6069      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6070      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6071               dephii1=dephii1+(k-l)*sinkt(m)*(
6072      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6073      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6074      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6075      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6076               if (lprn) then
6077               write (iout,*) "m",m," k",k," l",l," ffthet",
6078      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6079      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6080      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6081      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6082      &            " ethetai",ethetai
6083               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6084      &            cosph1ph2(k,l)*sinkt(m),
6085      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6086               endif
6087             enddo
6088           enddo
6089         enddo
6090 10      continue
6091 c        lprn1=.true.
6092 C        print *,ethetai
6093         if (lprn1)
6094      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6095      &   i,theta(i)*rad2deg,phii*rad2deg,
6096      &   phii1*rad2deg,ethetai
6097 c        lprn1=.false.
6098         etheta=etheta+ethetai
6099         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6100         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6101         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6102       enddo
6103 C now constrains
6104       ethetacnstr=0.0d0
6105 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6106       do i=ithetaconstr_start,ithetaconstr_end
6107         itheta=itheta_constr(i)
6108         thetiii=theta(itheta)
6109         difi=pinorm(thetiii-theta_constr0(i))
6110         if (difi.gt.theta_drange(i)) then
6111           difi=difi-theta_drange(i)
6112           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6113           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6114      &    +for_thet_constr(i)*difi**3
6115         else if (difi.lt.-drange(i)) then
6116           difi=difi+drange(i)
6117           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6118           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6119      &    +for_thet_constr(i)*difi**3
6120         else
6121           difi=0.0
6122         endif
6123        if (energy_dec) then
6124         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6125      &    i,itheta,rad2deg*thetiii,
6126      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6127      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6128      &    gloc(itheta+nphi-2,icg)
6129         endif
6130       enddo
6131
6132       return
6133       end
6134 #endif
6135 #ifdef CRYST_SC
6136 c-----------------------------------------------------------------------------
6137       subroutine esc(escloc)
6138 C Calculate the local energy of a side chain and its derivatives in the
6139 C corresponding virtual-bond valence angles THETA and the spherical angles
6140 C ALPHA and OMEGA.
6141       implicit real*8 (a-h,o-z)
6142       include 'DIMENSIONS'
6143       include 'COMMON.GEO'
6144       include 'COMMON.LOCAL'
6145       include 'COMMON.VAR'
6146       include 'COMMON.INTERACT'
6147       include 'COMMON.DERIV'
6148       include 'COMMON.CHAIN'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.NAMES'
6151       include 'COMMON.FFIELD'
6152       include 'COMMON.CONTROL'
6153       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6154      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6155       common /sccalc/ time11,time12,time112,theti,it,nlobit
6156       delta=0.02d0*pi
6157       escloc=0.0D0
6158 c     write (iout,'(a)') 'ESC'
6159       do i=loc_start,loc_end
6160         it=itype(i)
6161         if (it.eq.ntyp1) cycle
6162         if (it.eq.10) goto 1
6163         nlobit=nlob(iabs(it))
6164 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6165 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6166         theti=theta(i+1)-pipol
6167         x(1)=dtan(theti)
6168         x(2)=alph(i)
6169         x(3)=omeg(i)
6170
6171         if (x(2).gt.pi-delta) then
6172           xtemp(1)=x(1)
6173           xtemp(2)=pi-delta
6174           xtemp(3)=x(3)
6175           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6176           xtemp(2)=pi
6177           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6178           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6179      &        escloci,dersc(2))
6180           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6181      &        ddersc0(1),dersc(1))
6182           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6183      &        ddersc0(3),dersc(3))
6184           xtemp(2)=pi-delta
6185           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6186           xtemp(2)=pi
6187           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6188           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6189      &            dersc0(2),esclocbi,dersc02)
6190           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6191      &            dersc12,dersc01)
6192           call splinthet(x(2),0.5d0*delta,ss,ssd)
6193           dersc0(1)=dersc01
6194           dersc0(2)=dersc02
6195           dersc0(3)=0.0d0
6196           do k=1,3
6197             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6198           enddo
6199           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6200 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6201 c    &             esclocbi,ss,ssd
6202           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6203 c         escloci=esclocbi
6204 c         write (iout,*) escloci
6205         else if (x(2).lt.delta) then
6206           xtemp(1)=x(1)
6207           xtemp(2)=delta
6208           xtemp(3)=x(3)
6209           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6210           xtemp(2)=0.0d0
6211           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6212           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6213      &        escloci,dersc(2))
6214           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6215      &        ddersc0(1),dersc(1))
6216           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6217      &        ddersc0(3),dersc(3))
6218           xtemp(2)=delta
6219           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6220           xtemp(2)=0.0d0
6221           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6222           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6223      &            dersc0(2),esclocbi,dersc02)
6224           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6225      &            dersc12,dersc01)
6226           dersc0(1)=dersc01
6227           dersc0(2)=dersc02
6228           dersc0(3)=0.0d0
6229           call splinthet(x(2),0.5d0*delta,ss,ssd)
6230           do k=1,3
6231             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6232           enddo
6233           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6234 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6235 c    &             esclocbi,ss,ssd
6236           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6237 c         write (iout,*) escloci
6238         else
6239           call enesc(x,escloci,dersc,ddummy,.false.)
6240         endif
6241
6242         escloc=escloc+escloci
6243         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6244      &     'escloc',i,escloci
6245 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6246
6247         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6248      &   wscloc*dersc(1)
6249         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6250         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6251     1   continue
6252       enddo
6253       return
6254       end
6255 C---------------------------------------------------------------------------
6256       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6257       implicit real*8 (a-h,o-z)
6258       include 'DIMENSIONS'
6259       include 'COMMON.GEO'
6260       include 'COMMON.LOCAL'
6261       include 'COMMON.IOUNITS'
6262       common /sccalc/ time11,time12,time112,theti,it,nlobit
6263       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6264       double precision contr(maxlob,-1:1)
6265       logical mixed
6266 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6267         escloc_i=0.0D0
6268         do j=1,3
6269           dersc(j)=0.0D0
6270           if (mixed) ddersc(j)=0.0d0
6271         enddo
6272         x3=x(3)
6273
6274 C Because of periodicity of the dependence of the SC energy in omega we have
6275 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6276 C To avoid underflows, first compute & store the exponents.
6277
6278         do iii=-1,1
6279
6280           x(3)=x3+iii*dwapi
6281
6282           do j=1,nlobit
6283             do k=1,3
6284               z(k)=x(k)-censc(k,j,it)
6285             enddo
6286             do k=1,3
6287               Axk=0.0D0
6288               do l=1,3
6289                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6290               enddo
6291               Ax(k,j,iii)=Axk
6292             enddo
6293             expfac=0.0D0
6294             do k=1,3
6295               expfac=expfac+Ax(k,j,iii)*z(k)
6296             enddo
6297             contr(j,iii)=expfac
6298           enddo ! j
6299
6300         enddo ! iii
6301
6302         x(3)=x3
6303 C As in the case of ebend, we want to avoid underflows in exponentiation and
6304 C subsequent NaNs and INFs in energy calculation.
6305 C Find the largest exponent
6306         emin=contr(1,-1)
6307         do iii=-1,1
6308           do j=1,nlobit
6309             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6310           enddo
6311         enddo
6312         emin=0.5D0*emin
6313 cd      print *,'it=',it,' emin=',emin
6314
6315 C Compute the contribution to SC energy and derivatives
6316         do iii=-1,1
6317
6318           do j=1,nlobit
6319 #ifdef OSF
6320             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6321             if(adexp.ne.adexp) adexp=1.0
6322             expfac=dexp(adexp)
6323 #else
6324             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6325 #endif
6326 cd          print *,'j=',j,' expfac=',expfac
6327             escloc_i=escloc_i+expfac
6328             do k=1,3
6329               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6330             enddo
6331             if (mixed) then
6332               do k=1,3,2
6333                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6334      &            +gaussc(k,2,j,it))*expfac
6335               enddo
6336             endif
6337           enddo
6338
6339         enddo ! iii
6340
6341         dersc(1)=dersc(1)/cos(theti)**2
6342         ddersc(1)=ddersc(1)/cos(theti)**2
6343         ddersc(3)=ddersc(3)
6344
6345         escloci=-(dlog(escloc_i)-emin)
6346         do j=1,3
6347           dersc(j)=dersc(j)/escloc_i
6348         enddo
6349         if (mixed) then
6350           do j=1,3,2
6351             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6352           enddo
6353         endif
6354       return
6355       end
6356 C------------------------------------------------------------------------------
6357       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6358       implicit real*8 (a-h,o-z)
6359       include 'DIMENSIONS'
6360       include 'COMMON.GEO'
6361       include 'COMMON.LOCAL'
6362       include 'COMMON.IOUNITS'
6363       common /sccalc/ time11,time12,time112,theti,it,nlobit
6364       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6365       double precision contr(maxlob)
6366       logical mixed
6367
6368       escloc_i=0.0D0
6369
6370       do j=1,3
6371         dersc(j)=0.0D0
6372       enddo
6373
6374       do j=1,nlobit
6375         do k=1,2
6376           z(k)=x(k)-censc(k,j,it)
6377         enddo
6378         z(3)=dwapi
6379         do k=1,3
6380           Axk=0.0D0
6381           do l=1,3
6382             Axk=Axk+gaussc(l,k,j,it)*z(l)
6383           enddo
6384           Ax(k,j)=Axk
6385         enddo
6386         expfac=0.0D0
6387         do k=1,3
6388           expfac=expfac+Ax(k,j)*z(k)
6389         enddo
6390         contr(j)=expfac
6391       enddo ! j
6392
6393 C As in the case of ebend, we want to avoid underflows in exponentiation and
6394 C subsequent NaNs and INFs in energy calculation.
6395 C Find the largest exponent
6396       emin=contr(1)
6397       do j=1,nlobit
6398         if (emin.gt.contr(j)) emin=contr(j)
6399       enddo
6400       emin=0.5D0*emin
6401
6402 C Compute the contribution to SC energy and derivatives
6403
6404       dersc12=0.0d0
6405       do j=1,nlobit
6406         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6407         escloc_i=escloc_i+expfac
6408         do k=1,2
6409           dersc(k)=dersc(k)+Ax(k,j)*expfac
6410         enddo
6411         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6412      &            +gaussc(1,2,j,it))*expfac
6413         dersc(3)=0.0d0
6414       enddo
6415
6416       dersc(1)=dersc(1)/cos(theti)**2
6417       dersc12=dersc12/cos(theti)**2
6418       escloci=-(dlog(escloc_i)-emin)
6419       do j=1,2
6420         dersc(j)=dersc(j)/escloc_i
6421       enddo
6422       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6423       return
6424       end
6425 #else
6426 c----------------------------------------------------------------------------------
6427       subroutine esc(escloc)
6428 C Calculate the local energy of a side chain and its derivatives in the
6429 C corresponding virtual-bond valence angles THETA and the spherical angles
6430 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6431 C added by Urszula Kozlowska. 07/11/2007
6432 C
6433       implicit real*8 (a-h,o-z)
6434       include 'DIMENSIONS'
6435       include 'COMMON.GEO'
6436       include 'COMMON.LOCAL'
6437       include 'COMMON.VAR'
6438       include 'COMMON.SCROT'
6439       include 'COMMON.INTERACT'
6440       include 'COMMON.DERIV'
6441       include 'COMMON.CHAIN'
6442       include 'COMMON.IOUNITS'
6443       include 'COMMON.NAMES'
6444       include 'COMMON.FFIELD'
6445       include 'COMMON.CONTROL'
6446       include 'COMMON.VECTORS'
6447       double precision x_prime(3),y_prime(3),z_prime(3)
6448      &    , sumene,dsc_i,dp2_i,x(65),
6449      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6450      &    de_dxx,de_dyy,de_dzz,de_dt
6451       double precision s1_t,s1_6_t,s2_t,s2_6_t
6452       double precision
6453      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6454      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6455      & dt_dCi(3),dt_dCi1(3)
6456       common /sccalc/ time11,time12,time112,theti,it,nlobit
6457       delta=0.02d0*pi
6458       escloc=0.0D0
6459       do i=loc_start,loc_end
6460         if (itype(i).eq.ntyp1) cycle
6461         costtab(i+1) =dcos(theta(i+1))
6462         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6463         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6464         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6465         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6466         cosfac=dsqrt(cosfac2)
6467         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6468         sinfac=dsqrt(sinfac2)
6469         it=iabs(itype(i))
6470         if (it.eq.10) goto 1
6471 c
6472 C  Compute the axes of tghe local cartesian coordinates system; store in
6473 c   x_prime, y_prime and z_prime
6474 c
6475         do j=1,3
6476           x_prime(j) = 0.00
6477           y_prime(j) = 0.00
6478           z_prime(j) = 0.00
6479         enddo
6480 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6481 C     &   dc_norm(3,i+nres)
6482         do j = 1,3
6483           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6484           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6485         enddo
6486         do j = 1,3
6487           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6488         enddo
6489 c       write (2,*) "i",i
6490 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6491 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6492 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6493 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6494 c      & " xy",scalar(x_prime(1),y_prime(1)),
6495 c      & " xz",scalar(x_prime(1),z_prime(1)),
6496 c      & " yy",scalar(y_prime(1),y_prime(1)),
6497 c      & " yz",scalar(y_prime(1),z_prime(1)),
6498 c      & " zz",scalar(z_prime(1),z_prime(1))
6499 c
6500 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6501 C to local coordinate system. Store in xx, yy, zz.
6502 c
6503         xx=0.0d0
6504         yy=0.0d0
6505         zz=0.0d0
6506         do j = 1,3
6507           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6508           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6509           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6510         enddo
6511
6512         xxtab(i)=xx
6513         yytab(i)=yy
6514         zztab(i)=zz
6515 C
6516 C Compute the energy of the ith side cbain
6517 C
6518 c        write (2,*) "xx",xx," yy",yy," zz",zz
6519         it=iabs(itype(i))
6520         do j = 1,65
6521           x(j) = sc_parmin(j,it)
6522         enddo
6523 #ifdef CHECK_COORD
6524 Cc diagnostics - remove later
6525         xx1 = dcos(alph(2))
6526         yy1 = dsin(alph(2))*dcos(omeg(2))
6527         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6528         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6529      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6530      &    xx1,yy1,zz1
6531 C,"  --- ", xx_w,yy_w,zz_w
6532 c end diagnostics
6533 #endif
6534         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6535      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6536      &   + x(10)*yy*zz
6537         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6538      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6539      & + x(20)*yy*zz
6540         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6541      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6542      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6543      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6544      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6545      &  +x(40)*xx*yy*zz
6546         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6547      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6548      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6549      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6550      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6551      &  +x(60)*xx*yy*zz
6552         dsc_i   = 0.743d0+x(61)
6553         dp2_i   = 1.9d0+x(62)
6554         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6555      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6556         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6557      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6558         s1=(1+x(63))/(0.1d0 + dscp1)
6559         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6560         s2=(1+x(65))/(0.1d0 + dscp2)
6561         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6562         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6563      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6564 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6565 c     &   sumene4,
6566 c     &   dscp1,dscp2,sumene
6567 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6568         escloc = escloc + sumene
6569 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6570 c     & ,zz,xx,yy
6571 c#define DEBUG
6572 #ifdef DEBUG
6573 C
6574 C This section to check the numerical derivatives of the energy of ith side
6575 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6576 C #define DEBUG in the code to turn it on.
6577 C
6578         write (2,*) "sumene               =",sumene
6579         aincr=1.0d-7
6580         xxsave=xx
6581         xx=xx+aincr
6582         write (2,*) xx,yy,zz
6583         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6584         de_dxx_num=(sumenep-sumene)/aincr
6585         xx=xxsave
6586         write (2,*) "xx+ sumene from enesc=",sumenep
6587         yysave=yy
6588         yy=yy+aincr
6589         write (2,*) xx,yy,zz
6590         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6591         de_dyy_num=(sumenep-sumene)/aincr
6592         yy=yysave
6593         write (2,*) "yy+ sumene from enesc=",sumenep
6594         zzsave=zz
6595         zz=zz+aincr
6596         write (2,*) xx,yy,zz
6597         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6598         de_dzz_num=(sumenep-sumene)/aincr
6599         zz=zzsave
6600         write (2,*) "zz+ sumene from enesc=",sumenep
6601         costsave=cost2tab(i+1)
6602         sintsave=sint2tab(i+1)
6603         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6604         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6605         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6606         de_dt_num=(sumenep-sumene)/aincr
6607         write (2,*) " t+ sumene from enesc=",sumenep
6608         cost2tab(i+1)=costsave
6609         sint2tab(i+1)=sintsave
6610 C End of diagnostics section.
6611 #endif
6612 C
6613 C Compute the gradient of esc
6614 C
6615 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6616         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6617         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6618         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6619         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6620         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6621         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6622         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6623         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6624         pom1=(sumene3*sint2tab(i+1)+sumene1)
6625      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6626         pom2=(sumene4*cost2tab(i+1)+sumene2)
6627      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6628         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6629         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6630      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6631      &  +x(40)*yy*zz
6632         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6633         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6634      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6635      &  +x(60)*yy*zz
6636         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6637      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6638      &        +(pom1+pom2)*pom_dx
6639 #ifdef DEBUG
6640         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6641 #endif
6642 C
6643         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6644         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6645      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6646      &  +x(40)*xx*zz
6647         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6648         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6649      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6650      &  +x(59)*zz**2 +x(60)*xx*zz
6651         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6652      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6653      &        +(pom1-pom2)*pom_dy
6654 #ifdef DEBUG
6655         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6656 #endif
6657 C
6658         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6659      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6660      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6661      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6662      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6663      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6664      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6665      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6666 #ifdef DEBUG
6667         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6668 #endif
6669 C
6670         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6671      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6672      &  +pom1*pom_dt1+pom2*pom_dt2
6673 #ifdef DEBUG
6674         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6675 #endif
6676 c#undef DEBUG
6677 c
6678 C
6679        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6680        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6681        cosfac2xx=cosfac2*xx
6682        sinfac2yy=sinfac2*yy
6683        do k = 1,3
6684          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6685      &      vbld_inv(i+1)
6686          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6687      &      vbld_inv(i)
6688          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6689          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6690 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6691 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6692 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6693 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6694          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6695          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6696          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6697          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6698          dZZ_Ci1(k)=0.0d0
6699          dZZ_Ci(k)=0.0d0
6700          do j=1,3
6701            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6702      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6703            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6704      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6705          enddo
6706
6707          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6708          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6709          dZZ_XYZ(k)=vbld_inv(i+nres)*
6710      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6711 c
6712          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6713          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6714        enddo
6715
6716        do k=1,3
6717          dXX_Ctab(k,i)=dXX_Ci(k)
6718          dXX_C1tab(k,i)=dXX_Ci1(k)
6719          dYY_Ctab(k,i)=dYY_Ci(k)
6720          dYY_C1tab(k,i)=dYY_Ci1(k)
6721          dZZ_Ctab(k,i)=dZZ_Ci(k)
6722          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6723          dXX_XYZtab(k,i)=dXX_XYZ(k)
6724          dYY_XYZtab(k,i)=dYY_XYZ(k)
6725          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6726        enddo
6727
6728        do k = 1,3
6729 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6730 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6731 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6732 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6733 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6734 c     &    dt_dci(k)
6735 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6736 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6737          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6738      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6739          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6740      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6741          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6742      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6743        enddo
6744 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6745 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6746
6747 C to check gradient call subroutine check_grad
6748
6749     1 continue
6750       enddo
6751       return
6752       end
6753 c------------------------------------------------------------------------------
6754       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6755       implicit none
6756       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6757      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6758       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6759      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6760      &   + x(10)*yy*zz
6761       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6762      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6763      & + x(20)*yy*zz
6764       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6765      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6766      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6767      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6768      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6769      &  +x(40)*xx*yy*zz
6770       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6771      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6772      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6773      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6774      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6775      &  +x(60)*xx*yy*zz
6776       dsc_i   = 0.743d0+x(61)
6777       dp2_i   = 1.9d0+x(62)
6778       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6779      &          *(xx*cost2+yy*sint2))
6780       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6781      &          *(xx*cost2-yy*sint2))
6782       s1=(1+x(63))/(0.1d0 + dscp1)
6783       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6784       s2=(1+x(65))/(0.1d0 + dscp2)
6785       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6786       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6787      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6788       enesc=sumene
6789       return
6790       end
6791 #endif
6792 c------------------------------------------------------------------------------
6793       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6794 C
6795 C This procedure calculates two-body contact function g(rij) and its derivative:
6796 C
6797 C           eps0ij                                     !       x < -1
6798 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6799 C            0                                         !       x > 1
6800 C
6801 C where x=(rij-r0ij)/delta
6802 C
6803 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6804 C
6805       implicit none
6806       double precision rij,r0ij,eps0ij,fcont,fprimcont
6807       double precision x,x2,x4,delta
6808 c     delta=0.02D0*r0ij
6809 c      delta=0.2D0*r0ij
6810       x=(rij-r0ij)/delta
6811       if (x.lt.-1.0D0) then
6812         fcont=eps0ij
6813         fprimcont=0.0D0
6814       else if (x.le.1.0D0) then
6815         x2=x*x
6816         x4=x2*x2
6817         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6818         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6819       else
6820         fcont=0.0D0
6821         fprimcont=0.0D0
6822       endif
6823       return
6824       end
6825 c------------------------------------------------------------------------------
6826       subroutine splinthet(theti,delta,ss,ssder)
6827       implicit real*8 (a-h,o-z)
6828       include 'DIMENSIONS'
6829       include 'COMMON.VAR'
6830       include 'COMMON.GEO'
6831       thetup=pi-delta
6832       thetlow=delta
6833       if (theti.gt.pipol) then
6834         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6835       else
6836         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6837         ssder=-ssder
6838       endif
6839       return
6840       end
6841 c------------------------------------------------------------------------------
6842       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6843       implicit none
6844       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6845       double precision ksi,ksi2,ksi3,a1,a2,a3
6846       a1=fprim0*delta/(f1-f0)
6847       a2=3.0d0-2.0d0*a1
6848       a3=a1-2.0d0
6849       ksi=(x-x0)/delta
6850       ksi2=ksi*ksi
6851       ksi3=ksi2*ksi
6852       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6853       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6854       return
6855       end
6856 c------------------------------------------------------------------------------
6857       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6858       implicit none
6859       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6860       double precision ksi,ksi2,ksi3,a1,a2,a3
6861       ksi=(x-x0)/delta
6862       ksi2=ksi*ksi
6863       ksi3=ksi2*ksi
6864       a1=fprim0x*delta
6865       a2=3*(f1x-f0x)-2*fprim0x*delta
6866       a3=fprim0x*delta-2*(f1x-f0x)
6867       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6868       return
6869       end
6870 C-----------------------------------------------------------------------------
6871 #ifdef CRYST_TOR
6872 C-----------------------------------------------------------------------------
6873       subroutine etor(etors,edihcnstr)
6874       implicit real*8 (a-h,o-z)
6875       include 'DIMENSIONS'
6876       include 'COMMON.VAR'
6877       include 'COMMON.GEO'
6878       include 'COMMON.LOCAL'
6879       include 'COMMON.TORSION'
6880       include 'COMMON.INTERACT'
6881       include 'COMMON.DERIV'
6882       include 'COMMON.CHAIN'
6883       include 'COMMON.NAMES'
6884       include 'COMMON.IOUNITS'
6885       include 'COMMON.FFIELD'
6886       include 'COMMON.TORCNSTR'
6887       include 'COMMON.CONTROL'
6888       logical lprn
6889 C Set lprn=.true. for debugging
6890       lprn=.false.
6891 c      lprn=.true.
6892       etors=0.0D0
6893       do i=iphi_start,iphi_end
6894       etors_ii=0.0D0
6895         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6896      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6897         itori=itortyp(itype(i-2))
6898         itori1=itortyp(itype(i-1))
6899         phii=phi(i)
6900         gloci=0.0D0
6901 C Proline-Proline pair is a special case...
6902         if (itori.eq.3 .and. itori1.eq.3) then
6903           if (phii.gt.-dwapi3) then
6904             cosphi=dcos(3*phii)
6905             fac=1.0D0/(1.0D0-cosphi)
6906             etorsi=v1(1,3,3)*fac
6907             etorsi=etorsi+etorsi
6908             etors=etors+etorsi-v1(1,3,3)
6909             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6910             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6911           endif
6912           do j=1,3
6913             v1ij=v1(j+1,itori,itori1)
6914             v2ij=v2(j+1,itori,itori1)
6915             cosphi=dcos(j*phii)
6916             sinphi=dsin(j*phii)
6917             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6918             if (energy_dec) etors_ii=etors_ii+
6919      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6920             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6921           enddo
6922         else
6923           do j=1,nterm_old
6924             v1ij=v1(j,itori,itori1)
6925             v2ij=v2(j,itori,itori1)
6926             cosphi=dcos(j*phii)
6927             sinphi=dsin(j*phii)
6928             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6929             if (energy_dec) etors_ii=etors_ii+
6930      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6931             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6932           enddo
6933         endif
6934         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6935              'etor',i,etors_ii
6936         if (lprn)
6937      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6938      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6939      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6940         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6941 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6942       enddo
6943 ! 6/20/98 - dihedral angle constraints
6944       edihcnstr=0.0d0
6945       do i=1,ndih_constr
6946         itori=idih_constr(i)
6947         phii=phi(itori)
6948         difi=phii-phi0(i)
6949         if (difi.gt.drange(i)) then
6950           difi=difi-drange(i)
6951           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6952           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6953         else if (difi.lt.-drange(i)) then
6954           difi=difi+drange(i)
6955           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6956           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6957         endif
6958 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6959 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6960       enddo
6961 !      write (iout,*) 'edihcnstr',edihcnstr
6962       return
6963       end
6964 c------------------------------------------------------------------------------
6965       subroutine etor_d(etors_d)
6966       etors_d=0.0d0
6967       return
6968       end
6969 c----------------------------------------------------------------------------
6970 #else
6971       subroutine etor(etors,edihcnstr)
6972       implicit real*8 (a-h,o-z)
6973       include 'DIMENSIONS'
6974       include 'COMMON.VAR'
6975       include 'COMMON.GEO'
6976       include 'COMMON.LOCAL'
6977       include 'COMMON.TORSION'
6978       include 'COMMON.INTERACT'
6979       include 'COMMON.DERIV'
6980       include 'COMMON.CHAIN'
6981       include 'COMMON.NAMES'
6982       include 'COMMON.IOUNITS'
6983       include 'COMMON.FFIELD'
6984       include 'COMMON.TORCNSTR'
6985       include 'COMMON.CONTROL'
6986       logical lprn
6987 C Set lprn=.true. for debugging
6988       lprn=.false.
6989 c     lprn=.true.
6990       etors=0.0D0
6991       do i=iphi_start,iphi_end
6992 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6993 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6994 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6995 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6996         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6997      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6998 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6999 C For introducing the NH3+ and COO- group please check the etor_d for reference
7000 C and guidance
7001         etors_ii=0.0D0
7002          if (iabs(itype(i)).eq.20) then
7003          iblock=2
7004          else
7005          iblock=1
7006          endif
7007         itori=itortyp(itype(i-2))
7008         itori1=itortyp(itype(i-1))
7009         phii=phi(i)
7010         gloci=0.0D0
7011 C Regular cosine and sine terms
7012         do j=1,nterm(itori,itori1,iblock)
7013           v1ij=v1(j,itori,itori1,iblock)
7014           v2ij=v2(j,itori,itori1,iblock)
7015           cosphi=dcos(j*phii)
7016           sinphi=dsin(j*phii)
7017           etors=etors+v1ij*cosphi+v2ij*sinphi
7018           if (energy_dec) etors_ii=etors_ii+
7019      &                v1ij*cosphi+v2ij*sinphi
7020           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7021         enddo
7022 C Lorentz terms
7023 C                         v1
7024 C  E = SUM ----------------------------------- - v1
7025 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7026 C
7027         cosphi=dcos(0.5d0*phii)
7028         sinphi=dsin(0.5d0*phii)
7029         do j=1,nlor(itori,itori1,iblock)
7030           vl1ij=vlor1(j,itori,itori1)
7031           vl2ij=vlor2(j,itori,itori1)
7032           vl3ij=vlor3(j,itori,itori1)
7033           pom=vl2ij*cosphi+vl3ij*sinphi
7034           pom1=1.0d0/(pom*pom+1.0d0)
7035           etors=etors+vl1ij*pom1
7036           if (energy_dec) etors_ii=etors_ii+
7037      &                vl1ij*pom1
7038           pom=-pom*pom1*pom1
7039           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7040         enddo
7041 C Subtract the constant term
7042         etors=etors-v0(itori,itori1,iblock)
7043           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7044      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7045         if (lprn)
7046      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7047      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7048      &  (v1(j,itori,itori1,iblock),j=1,6),
7049      &  (v2(j,itori,itori1,iblock),j=1,6)
7050         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7051 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7052       enddo
7053 ! 6/20/98 - dihedral angle constraints
7054       edihcnstr=0.0d0
7055 c      do i=1,ndih_constr
7056       do i=idihconstr_start,idihconstr_end
7057         itori=idih_constr(i)
7058         phii=phi(itori)
7059         difi=pinorm(phii-phi0(i))
7060         if (difi.gt.drange(i)) then
7061           difi=difi-drange(i)
7062           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7063           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7064         else if (difi.lt.-drange(i)) then
7065           difi=difi+drange(i)
7066           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7067           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7068         else
7069           difi=0.0
7070         endif
7071        if (energy_dec) then
7072         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7073      &    i,itori,rad2deg*phii,
7074      &    rad2deg*phi0(i),  rad2deg*drange(i),
7075      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7076         endif
7077       enddo
7078 cd       write (iout,*) 'edihcnstr',edihcnstr
7079       return
7080       end
7081 c----------------------------------------------------------------------------
7082       subroutine etor_d(etors_d)
7083 C 6/23/01 Compute double torsional energy
7084       implicit real*8 (a-h,o-z)
7085       include 'DIMENSIONS'
7086       include 'COMMON.VAR'
7087       include 'COMMON.GEO'
7088       include 'COMMON.LOCAL'
7089       include 'COMMON.TORSION'
7090       include 'COMMON.INTERACT'
7091       include 'COMMON.DERIV'
7092       include 'COMMON.CHAIN'
7093       include 'COMMON.NAMES'
7094       include 'COMMON.IOUNITS'
7095       include 'COMMON.FFIELD'
7096       include 'COMMON.TORCNSTR'
7097       logical lprn
7098 C Set lprn=.true. for debugging
7099       lprn=.false.
7100 c     lprn=.true.
7101       etors_d=0.0D0
7102 c      write(iout,*) "a tu??"
7103       do i=iphid_start,iphid_end
7104 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7105 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7106 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7107 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7108 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7109          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7110      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7111      &  (itype(i+1).eq.ntyp1)) cycle
7112 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7113         itori=itortyp(itype(i-2))
7114         itori1=itortyp(itype(i-1))
7115         itori2=itortyp(itype(i))
7116         phii=phi(i)
7117         phii1=phi(i+1)
7118         gloci1=0.0D0
7119         gloci2=0.0D0
7120         iblock=1
7121         if (iabs(itype(i+1)).eq.20) iblock=2
7122 C Iblock=2 Proline type
7123 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7124 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7125 C        if (itype(i+1).eq.ntyp1) iblock=3
7126 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7127 C IS or IS NOT need for this
7128 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7129 C        is (itype(i-3).eq.ntyp1) ntblock=2
7130 C        ntblock is N-terminal blocking group
7131
7132 C Regular cosine and sine terms
7133         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7134 C Example of changes for NH3+ blocking group
7135 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7136 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7137           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7138           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7139           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7140           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7141           cosphi1=dcos(j*phii)
7142           sinphi1=dsin(j*phii)
7143           cosphi2=dcos(j*phii1)
7144           sinphi2=dsin(j*phii1)
7145           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7146      &     v2cij*cosphi2+v2sij*sinphi2
7147           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7148           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7149         enddo
7150         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7151           do l=1,k-1
7152             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7153             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7154             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7155             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7156             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7157             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7158             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7159             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7160             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7161      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7162             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7163      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7164             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7165      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7166           enddo
7167         enddo
7168         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7169         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7170       enddo
7171       return
7172       end
7173 #endif
7174 c------------------------------------------------------------------------------
7175       subroutine eback_sc_corr(esccor)
7176 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7177 c        conformational states; temporarily implemented as differences
7178 c        between UNRES torsional potentials (dependent on three types of
7179 c        residues) and the torsional potentials dependent on all 20 types
7180 c        of residues computed from AM1  energy surfaces of terminally-blocked
7181 c        amino-acid residues.
7182       implicit real*8 (a-h,o-z)
7183       include 'DIMENSIONS'
7184       include 'COMMON.VAR'
7185       include 'COMMON.GEO'
7186       include 'COMMON.LOCAL'
7187       include 'COMMON.TORSION'
7188       include 'COMMON.SCCOR'
7189       include 'COMMON.INTERACT'
7190       include 'COMMON.DERIV'
7191       include 'COMMON.CHAIN'
7192       include 'COMMON.NAMES'
7193       include 'COMMON.IOUNITS'
7194       include 'COMMON.FFIELD'
7195       include 'COMMON.CONTROL'
7196       logical lprn
7197 C Set lprn=.true. for debugging
7198       lprn=.false.
7199 c      lprn=.true.
7200 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7201       esccor=0.0D0
7202       do i=itau_start,itau_end
7203         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7204         esccor_ii=0.0D0
7205         isccori=isccortyp(itype(i-2))
7206         isccori1=isccortyp(itype(i-1))
7207 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7208         phii=phi(i)
7209         do intertyp=1,3 !intertyp
7210 cc Added 09 May 2012 (Adasko)
7211 cc  Intertyp means interaction type of backbone mainchain correlation:
7212 c   1 = SC...Ca...Ca...Ca
7213 c   2 = Ca...Ca...Ca...SC
7214 c   3 = SC...Ca...Ca...SCi
7215         gloci=0.0D0
7216         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7217      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7218      &      (itype(i-1).eq.ntyp1)))
7219      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7220      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7221      &     .or.(itype(i).eq.ntyp1)))
7222      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7223      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7224      &      (itype(i-3).eq.ntyp1)))) cycle
7225         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7226         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7227      & cycle
7228        do j=1,nterm_sccor(isccori,isccori1)
7229           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7230           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7231           cosphi=dcos(j*tauangle(intertyp,i))
7232           sinphi=dsin(j*tauangle(intertyp,i))
7233           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7234           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7235         enddo
7236 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7237         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7238         if (lprn)
7239      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7240      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7241      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7242      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7243         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7244        enddo !intertyp
7245       enddo
7246
7247       return
7248       end
7249 c----------------------------------------------------------------------------
7250       subroutine multibody(ecorr)
7251 C This subroutine calculates multi-body contributions to energy following
7252 C the idea of Skolnick et al. If side chains I and J make a contact and
7253 C at the same time side chains I+1 and J+1 make a contact, an extra
7254 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7255       implicit real*8 (a-h,o-z)
7256       include 'DIMENSIONS'
7257       include 'COMMON.IOUNITS'
7258       include 'COMMON.DERIV'
7259       include 'COMMON.INTERACT'
7260       include 'COMMON.CONTACTS'
7261       double precision gx(3),gx1(3)
7262       logical lprn
7263
7264 C Set lprn=.true. for debugging
7265       lprn=.false.
7266
7267       if (lprn) then
7268         write (iout,'(a)') 'Contact function values:'
7269         do i=nnt,nct-2
7270           write (iout,'(i2,20(1x,i2,f10.5))')
7271      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7272         enddo
7273       endif
7274       ecorr=0.0D0
7275       do i=nnt,nct
7276         do j=1,3
7277           gradcorr(j,i)=0.0D0
7278           gradxorr(j,i)=0.0D0
7279         enddo
7280       enddo
7281       do i=nnt,nct-2
7282
7283         DO ISHIFT = 3,4
7284
7285         i1=i+ishift
7286         num_conti=num_cont(i)
7287         num_conti1=num_cont(i1)
7288         do jj=1,num_conti
7289           j=jcont(jj,i)
7290           do kk=1,num_conti1
7291             j1=jcont(kk,i1)
7292             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7293 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7294 cd   &                   ' ishift=',ishift
7295 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7296 C The system gains extra energy.
7297               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7298             endif   ! j1==j+-ishift
7299           enddo     ! kk
7300         enddo       ! jj
7301
7302         ENDDO ! ISHIFT
7303
7304       enddo         ! i
7305       return
7306       end
7307 c------------------------------------------------------------------------------
7308       double precision function esccorr(i,j,k,l,jj,kk)
7309       implicit real*8 (a-h,o-z)
7310       include 'DIMENSIONS'
7311       include 'COMMON.IOUNITS'
7312       include 'COMMON.DERIV'
7313       include 'COMMON.INTERACT'
7314       include 'COMMON.CONTACTS'
7315       double precision gx(3),gx1(3)
7316       logical lprn
7317       lprn=.false.
7318       eij=facont(jj,i)
7319       ekl=facont(kk,k)
7320 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7321 C Calculate the multi-body contribution to energy.
7322 C Calculate multi-body contributions to the gradient.
7323 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7324 cd   & k,l,(gacont(m,kk,k),m=1,3)
7325       do m=1,3
7326         gx(m) =ekl*gacont(m,jj,i)
7327         gx1(m)=eij*gacont(m,kk,k)
7328         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7329         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7330         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7331         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7332       enddo
7333       do m=i,j-1
7334         do ll=1,3
7335           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7336         enddo
7337       enddo
7338       do m=k,l-1
7339         do ll=1,3
7340           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7341         enddo
7342       enddo
7343       esccorr=-eij*ekl
7344       return
7345       end
7346 c------------------------------------------------------------------------------
7347       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7348 C This subroutine calculates multi-body contributions to hydrogen-bonding
7349       implicit real*8 (a-h,o-z)
7350       include 'DIMENSIONS'
7351       include 'COMMON.IOUNITS'
7352 #ifdef MPI
7353       include "mpif.h"
7354       parameter (max_cont=maxconts)
7355       parameter (max_dim=26)
7356       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7357       double precision zapas(max_dim,maxconts,max_fg_procs),
7358      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7359       common /przechowalnia/ zapas
7360       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7361      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7362 #endif
7363       include 'COMMON.SETUP'
7364       include 'COMMON.FFIELD'
7365       include 'COMMON.DERIV'
7366       include 'COMMON.INTERACT'
7367       include 'COMMON.CONTACTS'
7368       include 'COMMON.CONTROL'
7369       include 'COMMON.LOCAL'
7370       double precision gx(3),gx1(3),time00
7371       logical lprn,ldone
7372
7373 C Set lprn=.true. for debugging
7374       lprn=.false.
7375 #ifdef MPI
7376       n_corr=0
7377       n_corr1=0
7378       if (nfgtasks.le.1) goto 30
7379       if (lprn) then
7380         write (iout,'(a)') 'Contact function values before RECEIVE:'
7381         do i=nnt,nct-2
7382           write (iout,'(2i3,50(1x,i2,f5.2))')
7383      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7384      &    j=1,num_cont_hb(i))
7385         enddo
7386       endif
7387       call flush(iout)
7388       do i=1,ntask_cont_from
7389         ncont_recv(i)=0
7390       enddo
7391       do i=1,ntask_cont_to
7392         ncont_sent(i)=0
7393       enddo
7394 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7395 c     & ntask_cont_to
7396 C Make the list of contacts to send to send to other procesors
7397 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7398 c      call flush(iout)
7399       do i=iturn3_start,iturn3_end
7400 c        write (iout,*) "make contact list turn3",i," num_cont",
7401 c     &    num_cont_hb(i)
7402         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7403       enddo
7404       do i=iturn4_start,iturn4_end
7405 c        write (iout,*) "make contact list turn4",i," num_cont",
7406 c     &   num_cont_hb(i)
7407         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7408       enddo
7409       do ii=1,nat_sent
7410         i=iat_sent(ii)
7411 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7412 c     &    num_cont_hb(i)
7413         do j=1,num_cont_hb(i)
7414         do k=1,4
7415           jjc=jcont_hb(j,i)
7416           iproc=iint_sent_local(k,jjc,ii)
7417 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7418           if (iproc.gt.0) then
7419             ncont_sent(iproc)=ncont_sent(iproc)+1
7420             nn=ncont_sent(iproc)
7421             zapas(1,nn,iproc)=i
7422             zapas(2,nn,iproc)=jjc
7423             zapas(3,nn,iproc)=facont_hb(j,i)
7424             zapas(4,nn,iproc)=ees0p(j,i)
7425             zapas(5,nn,iproc)=ees0m(j,i)
7426             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7427             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7428             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7429             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7430             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7431             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7432             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7433             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7434             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7435             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7436             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7437             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7438             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7439             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7440             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7441             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7442             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7443             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7444             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7445             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7446             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7447           endif
7448         enddo
7449         enddo
7450       enddo
7451       if (lprn) then
7452       write (iout,*)
7453      &  "Numbers of contacts to be sent to other processors",
7454      &  (ncont_sent(i),i=1,ntask_cont_to)
7455       write (iout,*) "Contacts sent"
7456       do ii=1,ntask_cont_to
7457         nn=ncont_sent(ii)
7458         iproc=itask_cont_to(ii)
7459         write (iout,*) nn," contacts to processor",iproc,
7460      &   " of CONT_TO_COMM group"
7461         do i=1,nn
7462           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7463         enddo
7464       enddo
7465       call flush(iout)
7466       endif
7467       CorrelType=477
7468       CorrelID=fg_rank+1
7469       CorrelType1=478
7470       CorrelID1=nfgtasks+fg_rank+1
7471       ireq=0
7472 C Receive the numbers of needed contacts from other processors
7473       do ii=1,ntask_cont_from
7474         iproc=itask_cont_from(ii)
7475         ireq=ireq+1
7476         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7477      &    FG_COMM,req(ireq),IERR)
7478       enddo
7479 c      write (iout,*) "IRECV ended"
7480 c      call flush(iout)
7481 C Send the number of contacts needed by other processors
7482       do ii=1,ntask_cont_to
7483         iproc=itask_cont_to(ii)
7484         ireq=ireq+1
7485         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7486      &    FG_COMM,req(ireq),IERR)
7487       enddo
7488 c      write (iout,*) "ISEND ended"
7489 c      write (iout,*) "number of requests (nn)",ireq
7490       call flush(iout)
7491       if (ireq.gt.0)
7492      &  call MPI_Waitall(ireq,req,status_array,ierr)
7493 c      write (iout,*)
7494 c     &  "Numbers of contacts to be received from other processors",
7495 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7496 c      call flush(iout)
7497 C Receive contacts
7498       ireq=0
7499       do ii=1,ntask_cont_from
7500         iproc=itask_cont_from(ii)
7501         nn=ncont_recv(ii)
7502 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7503 c     &   " of CONT_TO_COMM group"
7504         call flush(iout)
7505         if (nn.gt.0) then
7506           ireq=ireq+1
7507           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7508      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7509 c          write (iout,*) "ireq,req",ireq,req(ireq)
7510         endif
7511       enddo
7512 C Send the contacts to processors that need them
7513       do ii=1,ntask_cont_to
7514         iproc=itask_cont_to(ii)
7515         nn=ncont_sent(ii)
7516 c        write (iout,*) nn," contacts to processor",iproc,
7517 c     &   " of CONT_TO_COMM group"
7518         if (nn.gt.0) then
7519           ireq=ireq+1
7520           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7521      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7522 c          write (iout,*) "ireq,req",ireq,req(ireq)
7523 c          do i=1,nn
7524 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7525 c          enddo
7526         endif
7527       enddo
7528 c      write (iout,*) "number of requests (contacts)",ireq
7529 c      write (iout,*) "req",(req(i),i=1,4)
7530 c      call flush(iout)
7531       if (ireq.gt.0)
7532      & call MPI_Waitall(ireq,req,status_array,ierr)
7533       do iii=1,ntask_cont_from
7534         iproc=itask_cont_from(iii)
7535         nn=ncont_recv(iii)
7536         if (lprn) then
7537         write (iout,*) "Received",nn," contacts from processor",iproc,
7538      &   " of CONT_FROM_COMM group"
7539         call flush(iout)
7540         do i=1,nn
7541           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7542         enddo
7543         call flush(iout)
7544         endif
7545         do i=1,nn
7546           ii=zapas_recv(1,i,iii)
7547 c Flag the received contacts to prevent double-counting
7548           jj=-zapas_recv(2,i,iii)
7549 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7550 c          call flush(iout)
7551           nnn=num_cont_hb(ii)+1
7552           num_cont_hb(ii)=nnn
7553           jcont_hb(nnn,ii)=jj
7554           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7555           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7556           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7557           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7558           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7559           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7560           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7561           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7562           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7563           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7564           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7565           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7566           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7567           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7568           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7569           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7570           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7571           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7572           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7573           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7574           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7575           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7576           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7577           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7578         enddo
7579       enddo
7580       call flush(iout)
7581       if (lprn) then
7582         write (iout,'(a)') 'Contact function values after receive:'
7583         do i=nnt,nct-2
7584           write (iout,'(2i3,50(1x,i3,f5.2))')
7585      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7586      &    j=1,num_cont_hb(i))
7587         enddo
7588         call flush(iout)
7589       endif
7590    30 continue
7591 #endif
7592       if (lprn) then
7593         write (iout,'(a)') 'Contact function values:'
7594         do i=nnt,nct-2
7595           write (iout,'(2i3,50(1x,i3,f5.2))')
7596      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7597      &    j=1,num_cont_hb(i))
7598         enddo
7599       endif
7600       ecorr=0.0D0
7601 C Remove the loop below after debugging !!!
7602       do i=nnt,nct
7603         do j=1,3
7604           gradcorr(j,i)=0.0D0
7605           gradxorr(j,i)=0.0D0
7606         enddo
7607       enddo
7608 C Calculate the local-electrostatic correlation terms
7609       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7610         i1=i+1
7611         num_conti=num_cont_hb(i)
7612         num_conti1=num_cont_hb(i+1)
7613         do jj=1,num_conti
7614           j=jcont_hb(jj,i)
7615           jp=iabs(j)
7616           do kk=1,num_conti1
7617             j1=jcont_hb(kk,i1)
7618             jp1=iabs(j1)
7619 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7620 c     &         ' jj=',jj,' kk=',kk
7621             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7622      &          .or. j.lt.0 .and. j1.gt.0) .and.
7623      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7624 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7625 C The system gains extra energy.
7626               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7627               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7628      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7629               n_corr=n_corr+1
7630             else if (j1.eq.j) then
7631 C Contacts I-J and I-(J+1) occur simultaneously.
7632 C The system loses extra energy.
7633 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7634             endif
7635           enddo ! kk
7636           do kk=1,num_conti
7637             j1=jcont_hb(kk,i)
7638 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7639 c    &         ' jj=',jj,' kk=',kk
7640             if (j1.eq.j+1) then
7641 C Contacts I-J and (I+1)-J occur simultaneously.
7642 C The system loses extra energy.
7643 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7644             endif ! j1==j+1
7645           enddo ! kk
7646         enddo ! jj
7647       enddo ! i
7648       return
7649       end
7650 c------------------------------------------------------------------------------
7651       subroutine add_hb_contact(ii,jj,itask)
7652       implicit real*8 (a-h,o-z)
7653       include "DIMENSIONS"
7654       include "COMMON.IOUNITS"
7655       integer max_cont
7656       integer max_dim
7657       parameter (max_cont=maxconts)
7658       parameter (max_dim=26)
7659       include "COMMON.CONTACTS"
7660       double precision zapas(max_dim,maxconts,max_fg_procs),
7661      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7662       common /przechowalnia/ zapas
7663       integer i,j,ii,jj,iproc,itask(4),nn
7664 c      write (iout,*) "itask",itask
7665       do i=1,2
7666         iproc=itask(i)
7667         if (iproc.gt.0) then
7668           do j=1,num_cont_hb(ii)
7669             jjc=jcont_hb(j,ii)
7670 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7671             if (jjc.eq.jj) then
7672               ncont_sent(iproc)=ncont_sent(iproc)+1
7673               nn=ncont_sent(iproc)
7674               zapas(1,nn,iproc)=ii
7675               zapas(2,nn,iproc)=jjc
7676               zapas(3,nn,iproc)=facont_hb(j,ii)
7677               zapas(4,nn,iproc)=ees0p(j,ii)
7678               zapas(5,nn,iproc)=ees0m(j,ii)
7679               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7680               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7681               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7682               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7683               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7684               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7685               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7686               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7687               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7688               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7689               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7690               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7691               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7692               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7693               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7694               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7695               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7696               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7697               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7698               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7699               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7700               exit
7701             endif
7702           enddo
7703         endif
7704       enddo
7705       return
7706       end
7707 c------------------------------------------------------------------------------
7708       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7709      &  n_corr1)
7710 C This subroutine calculates multi-body contributions to hydrogen-bonding
7711       implicit real*8 (a-h,o-z)
7712       include 'DIMENSIONS'
7713       include 'COMMON.IOUNITS'
7714 #ifdef MPI
7715       include "mpif.h"
7716       parameter (max_cont=maxconts)
7717       parameter (max_dim=70)
7718       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7719       double precision zapas(max_dim,maxconts,max_fg_procs),
7720      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7721       common /przechowalnia/ zapas
7722       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7723      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7724 #endif
7725       include 'COMMON.SETUP'
7726       include 'COMMON.FFIELD'
7727       include 'COMMON.DERIV'
7728       include 'COMMON.LOCAL'
7729       include 'COMMON.INTERACT'
7730       include 'COMMON.CONTACTS'
7731       include 'COMMON.CHAIN'
7732       include 'COMMON.CONTROL'
7733       double precision gx(3),gx1(3)
7734       integer num_cont_hb_old(maxres)
7735       logical lprn,ldone
7736       double precision eello4,eello5,eelo6,eello_turn6
7737       external eello4,eello5,eello6,eello_turn6
7738 C Set lprn=.true. for debugging
7739       lprn=.false.
7740       eturn6=0.0d0
7741 #ifdef MPI
7742       do i=1,nres
7743         num_cont_hb_old(i)=num_cont_hb(i)
7744       enddo
7745       n_corr=0
7746       n_corr1=0
7747       if (nfgtasks.le.1) goto 30
7748       if (lprn) then
7749         write (iout,'(a)') 'Contact function values before RECEIVE:'
7750         do i=nnt,nct-2
7751           write (iout,'(2i3,50(1x,i2,f5.2))')
7752      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7753      &    j=1,num_cont_hb(i))
7754         enddo
7755       endif
7756       call flush(iout)
7757       do i=1,ntask_cont_from
7758         ncont_recv(i)=0
7759       enddo
7760       do i=1,ntask_cont_to
7761         ncont_sent(i)=0
7762       enddo
7763 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7764 c     & ntask_cont_to
7765 C Make the list of contacts to send to send to other procesors
7766       do i=iturn3_start,iturn3_end
7767 c        write (iout,*) "make contact list turn3",i," num_cont",
7768 c     &    num_cont_hb(i)
7769         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7770       enddo
7771       do i=iturn4_start,iturn4_end
7772 c        write (iout,*) "make contact list turn4",i," num_cont",
7773 c     &   num_cont_hb(i)
7774         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7775       enddo
7776       do ii=1,nat_sent
7777         i=iat_sent(ii)
7778 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7779 c     &    num_cont_hb(i)
7780         do j=1,num_cont_hb(i)
7781         do k=1,4
7782           jjc=jcont_hb(j,i)
7783           iproc=iint_sent_local(k,jjc,ii)
7784 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7785           if (iproc.ne.0) then
7786             ncont_sent(iproc)=ncont_sent(iproc)+1
7787             nn=ncont_sent(iproc)
7788             zapas(1,nn,iproc)=i
7789             zapas(2,nn,iproc)=jjc
7790             zapas(3,nn,iproc)=d_cont(j,i)
7791             ind=3
7792             do kk=1,3
7793               ind=ind+1
7794               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7795             enddo
7796             do kk=1,2
7797               do ll=1,2
7798                 ind=ind+1
7799                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7800               enddo
7801             enddo
7802             do jj=1,5
7803               do kk=1,3
7804                 do ll=1,2
7805                   do mm=1,2
7806                     ind=ind+1
7807                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7808                   enddo
7809                 enddo
7810               enddo
7811             enddo
7812           endif
7813         enddo
7814         enddo
7815       enddo
7816       if (lprn) then
7817       write (iout,*)
7818      &  "Numbers of contacts to be sent to other processors",
7819      &  (ncont_sent(i),i=1,ntask_cont_to)
7820       write (iout,*) "Contacts sent"
7821       do ii=1,ntask_cont_to
7822         nn=ncont_sent(ii)
7823         iproc=itask_cont_to(ii)
7824         write (iout,*) nn," contacts to processor",iproc,
7825      &   " of CONT_TO_COMM group"
7826         do i=1,nn
7827           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7828         enddo
7829       enddo
7830       call flush(iout)
7831       endif
7832       CorrelType=477
7833       CorrelID=fg_rank+1
7834       CorrelType1=478
7835       CorrelID1=nfgtasks+fg_rank+1
7836       ireq=0
7837 C Receive the numbers of needed contacts from other processors
7838       do ii=1,ntask_cont_from
7839         iproc=itask_cont_from(ii)
7840         ireq=ireq+1
7841         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7842      &    FG_COMM,req(ireq),IERR)
7843       enddo
7844 c      write (iout,*) "IRECV ended"
7845 c      call flush(iout)
7846 C Send the number of contacts needed by other processors
7847       do ii=1,ntask_cont_to
7848         iproc=itask_cont_to(ii)
7849         ireq=ireq+1
7850         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7851      &    FG_COMM,req(ireq),IERR)
7852       enddo
7853 c      write (iout,*) "ISEND ended"
7854 c      write (iout,*) "number of requests (nn)",ireq
7855       call flush(iout)
7856       if (ireq.gt.0)
7857      &  call MPI_Waitall(ireq,req,status_array,ierr)
7858 c      write (iout,*)
7859 c     &  "Numbers of contacts to be received from other processors",
7860 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7861 c      call flush(iout)
7862 C Receive contacts
7863       ireq=0
7864       do ii=1,ntask_cont_from
7865         iproc=itask_cont_from(ii)
7866         nn=ncont_recv(ii)
7867 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7868 c     &   " of CONT_TO_COMM group"
7869         call flush(iout)
7870         if (nn.gt.0) then
7871           ireq=ireq+1
7872           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7873      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7874 c          write (iout,*) "ireq,req",ireq,req(ireq)
7875         endif
7876       enddo
7877 C Send the contacts to processors that need them
7878       do ii=1,ntask_cont_to
7879         iproc=itask_cont_to(ii)
7880         nn=ncont_sent(ii)
7881 c        write (iout,*) nn," contacts to processor",iproc,
7882 c     &   " of CONT_TO_COMM group"
7883         if (nn.gt.0) then
7884           ireq=ireq+1
7885           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7886      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7887 c          write (iout,*) "ireq,req",ireq,req(ireq)
7888 c          do i=1,nn
7889 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7890 c          enddo
7891         endif
7892       enddo
7893 c      write (iout,*) "number of requests (contacts)",ireq
7894 c      write (iout,*) "req",(req(i),i=1,4)
7895 c      call flush(iout)
7896       if (ireq.gt.0)
7897      & call MPI_Waitall(ireq,req,status_array,ierr)
7898       do iii=1,ntask_cont_from
7899         iproc=itask_cont_from(iii)
7900         nn=ncont_recv(iii)
7901         if (lprn) then
7902         write (iout,*) "Received",nn," contacts from processor",iproc,
7903      &   " of CONT_FROM_COMM group"
7904         call flush(iout)
7905         do i=1,nn
7906           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7907         enddo
7908         call flush(iout)
7909         endif
7910         do i=1,nn
7911           ii=zapas_recv(1,i,iii)
7912 c Flag the received contacts to prevent double-counting
7913           jj=-zapas_recv(2,i,iii)
7914 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7915 c          call flush(iout)
7916           nnn=num_cont_hb(ii)+1
7917           num_cont_hb(ii)=nnn
7918           jcont_hb(nnn,ii)=jj
7919           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7920           ind=3
7921           do kk=1,3
7922             ind=ind+1
7923             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7924           enddo
7925           do kk=1,2
7926             do ll=1,2
7927               ind=ind+1
7928               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7929             enddo
7930           enddo
7931           do jj=1,5
7932             do kk=1,3
7933               do ll=1,2
7934                 do mm=1,2
7935                   ind=ind+1
7936                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7937                 enddo
7938               enddo
7939             enddo
7940           enddo
7941         enddo
7942       enddo
7943       call flush(iout)
7944       if (lprn) then
7945         write (iout,'(a)') 'Contact function values after receive:'
7946         do i=nnt,nct-2
7947           write (iout,'(2i3,50(1x,i3,5f6.3))')
7948      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7949      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7950         enddo
7951         call flush(iout)
7952       endif
7953    30 continue
7954 #endif
7955       if (lprn) then
7956         write (iout,'(a)') 'Contact function values:'
7957         do i=nnt,nct-2
7958           write (iout,'(2i3,50(1x,i2,5f6.3))')
7959      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7960      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7961         enddo
7962       endif
7963       ecorr=0.0D0
7964       ecorr5=0.0d0
7965       ecorr6=0.0d0
7966 C Remove the loop below after debugging !!!
7967       do i=nnt,nct
7968         do j=1,3
7969           gradcorr(j,i)=0.0D0
7970           gradxorr(j,i)=0.0D0
7971         enddo
7972       enddo
7973 C Calculate the dipole-dipole interaction energies
7974       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7975       do i=iatel_s,iatel_e+1
7976         num_conti=num_cont_hb(i)
7977         do jj=1,num_conti
7978           j=jcont_hb(jj,i)
7979 #ifdef MOMENT
7980           call dipole(i,j,jj)
7981 #endif
7982         enddo
7983       enddo
7984       endif
7985 C Calculate the local-electrostatic correlation terms
7986 c                write (iout,*) "gradcorr5 in eello5 before loop"
7987 c                do iii=1,nres
7988 c                  write (iout,'(i5,3f10.5)')
7989 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7990 c                enddo
7991       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7992 c        write (iout,*) "corr loop i",i
7993         i1=i+1
7994         num_conti=num_cont_hb(i)
7995         num_conti1=num_cont_hb(i+1)
7996         do jj=1,num_conti
7997           j=jcont_hb(jj,i)
7998           jp=iabs(j)
7999           do kk=1,num_conti1
8000             j1=jcont_hb(kk,i1)
8001             jp1=iabs(j1)
8002 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8003 c     &         ' jj=',jj,' kk=',kk
8004 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8005             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8006      &          .or. j.lt.0 .and. j1.gt.0) .and.
8007      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8008 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8009 C The system gains extra energy.
8010               n_corr=n_corr+1
8011               sqd1=dsqrt(d_cont(jj,i))
8012               sqd2=dsqrt(d_cont(kk,i1))
8013               sred_geom = sqd1*sqd2
8014               IF (sred_geom.lt.cutoff_corr) THEN
8015                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8016      &            ekont,fprimcont)
8017 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8018 cd     &         ' jj=',jj,' kk=',kk
8019                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8020                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8021                 do l=1,3
8022                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8023                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8024                 enddo
8025                 n_corr1=n_corr1+1
8026 cd               write (iout,*) 'sred_geom=',sred_geom,
8027 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8028 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8029 cd               write (iout,*) "g_contij",g_contij
8030 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8031 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8032                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8033                 if (wcorr4.gt.0.0d0)
8034      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8035                   if (energy_dec.and.wcorr4.gt.0.0d0)
8036      1                 write (iout,'(a6,4i5,0pf7.3)')
8037      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8038 c                write (iout,*) "gradcorr5 before eello5"
8039 c                do iii=1,nres
8040 c                  write (iout,'(i5,3f10.5)')
8041 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8042 c                enddo
8043                 if (wcorr5.gt.0.0d0)
8044      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8045 c                write (iout,*) "gradcorr5 after eello5"
8046 c                do iii=1,nres
8047 c                  write (iout,'(i5,3f10.5)')
8048 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8049 c                enddo
8050                   if (energy_dec.and.wcorr5.gt.0.0d0)
8051      1                 write (iout,'(a6,4i5,0pf7.3)')
8052      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8053 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8054 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8055                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8056      &               .or. wturn6.eq.0.0d0))then
8057 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8058                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8059                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8060      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8061 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8062 cd     &            'ecorr6=',ecorr6
8063 cd                write (iout,'(4e15.5)') sred_geom,
8064 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8065 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8066 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8067                 else if (wturn6.gt.0.0d0
8068      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8069 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8070                   eturn6=eturn6+eello_turn6(i,jj,kk)
8071                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8072      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8073 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8074                 endif
8075               ENDIF
8076 1111          continue
8077             endif
8078           enddo ! kk
8079         enddo ! jj
8080       enddo ! i
8081       do i=1,nres
8082         num_cont_hb(i)=num_cont_hb_old(i)
8083       enddo
8084 c                write (iout,*) "gradcorr5 in eello5"
8085 c                do iii=1,nres
8086 c                  write (iout,'(i5,3f10.5)')
8087 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8088 c                enddo
8089       return
8090       end
8091 c------------------------------------------------------------------------------
8092       subroutine add_hb_contact_eello(ii,jj,itask)
8093       implicit real*8 (a-h,o-z)
8094       include "DIMENSIONS"
8095       include "COMMON.IOUNITS"
8096       integer max_cont
8097       integer max_dim
8098       parameter (max_cont=maxconts)
8099       parameter (max_dim=70)
8100       include "COMMON.CONTACTS"
8101       double precision zapas(max_dim,maxconts,max_fg_procs),
8102      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8103       common /przechowalnia/ zapas
8104       integer i,j,ii,jj,iproc,itask(4),nn
8105 c      write (iout,*) "itask",itask
8106       do i=1,2
8107         iproc=itask(i)
8108         if (iproc.gt.0) then
8109           do j=1,num_cont_hb(ii)
8110             jjc=jcont_hb(j,ii)
8111 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8112             if (jjc.eq.jj) then
8113               ncont_sent(iproc)=ncont_sent(iproc)+1
8114               nn=ncont_sent(iproc)
8115               zapas(1,nn,iproc)=ii
8116               zapas(2,nn,iproc)=jjc
8117               zapas(3,nn,iproc)=d_cont(j,ii)
8118               ind=3
8119               do kk=1,3
8120                 ind=ind+1
8121                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8122               enddo
8123               do kk=1,2
8124                 do ll=1,2
8125                   ind=ind+1
8126                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8127                 enddo
8128               enddo
8129               do jj=1,5
8130                 do kk=1,3
8131                   do ll=1,2
8132                     do mm=1,2
8133                       ind=ind+1
8134                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8135                     enddo
8136                   enddo
8137                 enddo
8138               enddo
8139               exit
8140             endif
8141           enddo
8142         endif
8143       enddo
8144       return
8145       end
8146 c------------------------------------------------------------------------------
8147       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8148       implicit real*8 (a-h,o-z)
8149       include 'DIMENSIONS'
8150       include 'COMMON.IOUNITS'
8151       include 'COMMON.DERIV'
8152       include 'COMMON.INTERACT'
8153       include 'COMMON.CONTACTS'
8154       double precision gx(3),gx1(3)
8155       logical lprn
8156       lprn=.false.
8157       eij=facont_hb(jj,i)
8158       ekl=facont_hb(kk,k)
8159       ees0pij=ees0p(jj,i)
8160       ees0pkl=ees0p(kk,k)
8161       ees0mij=ees0m(jj,i)
8162       ees0mkl=ees0m(kk,k)
8163       ekont=eij*ekl
8164       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8165 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8166 C Following 4 lines for diagnostics.
8167 cd    ees0pkl=0.0D0
8168 cd    ees0pij=1.0D0
8169 cd    ees0mkl=0.0D0
8170 cd    ees0mij=1.0D0
8171 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8172 c     & 'Contacts ',i,j,
8173 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8174 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8175 c     & 'gradcorr_long'
8176 C Calculate the multi-body contribution to energy.
8177 c      ecorr=ecorr+ekont*ees
8178 C Calculate multi-body contributions to the gradient.
8179       coeffpees0pij=coeffp*ees0pij
8180       coeffmees0mij=coeffm*ees0mij
8181       coeffpees0pkl=coeffp*ees0pkl
8182       coeffmees0mkl=coeffm*ees0mkl
8183       do ll=1,3
8184 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8185         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8186      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8187      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8188         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8189      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8190      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8191 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8192         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8193      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8194      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8195         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8196      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8197      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8198         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8199      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8200      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8201         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8202         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8203         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8204      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8205      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8206         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8207         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8208 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8209       enddo
8210 c      write (iout,*)
8211 cgrad      do m=i+1,j-1
8212 cgrad        do ll=1,3
8213 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8214 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8215 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8216 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8217 cgrad        enddo
8218 cgrad      enddo
8219 cgrad      do m=k+1,l-1
8220 cgrad        do ll=1,3
8221 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8222 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8223 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8224 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8225 cgrad        enddo
8226 cgrad      enddo
8227 c      write (iout,*) "ehbcorr",ekont*ees
8228       ehbcorr=ekont*ees
8229       return
8230       end
8231 #ifdef MOMENT
8232 C---------------------------------------------------------------------------
8233       subroutine dipole(i,j,jj)
8234       implicit real*8 (a-h,o-z)
8235       include 'DIMENSIONS'
8236       include 'COMMON.IOUNITS'
8237       include 'COMMON.CHAIN'
8238       include 'COMMON.FFIELD'
8239       include 'COMMON.DERIV'
8240       include 'COMMON.INTERACT'
8241       include 'COMMON.CONTACTS'
8242       include 'COMMON.TORSION'
8243       include 'COMMON.VAR'
8244       include 'COMMON.GEO'
8245       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8246      &  auxmat(2,2)
8247       iti1 = itortyp(itype(i+1))
8248       if (j.lt.nres-1) then
8249         itj1 = itortyp(itype(j+1))
8250       else
8251         itj1=ntortyp
8252       endif
8253       do iii=1,2
8254         dipi(iii,1)=Ub2(iii,i)
8255         dipderi(iii)=Ub2der(iii,i)
8256         dipi(iii,2)=b1(iii,i+1)
8257         dipj(iii,1)=Ub2(iii,j)
8258         dipderj(iii)=Ub2der(iii,j)
8259         dipj(iii,2)=b1(iii,j+1)
8260       enddo
8261       kkk=0
8262       do iii=1,2
8263         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8264         do jjj=1,2
8265           kkk=kkk+1
8266           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8267         enddo
8268       enddo
8269       do kkk=1,5
8270         do lll=1,3
8271           mmm=0
8272           do iii=1,2
8273             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8274      &        auxvec(1))
8275             do jjj=1,2
8276               mmm=mmm+1
8277               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8278             enddo
8279           enddo
8280         enddo
8281       enddo
8282       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8283       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8284       do iii=1,2
8285         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8286       enddo
8287       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8288       do iii=1,2
8289         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8290       enddo
8291       return
8292       end
8293 #endif
8294 C---------------------------------------------------------------------------
8295       subroutine calc_eello(i,j,k,l,jj,kk)
8296 C
8297 C This subroutine computes matrices and vectors needed to calculate
8298 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8299 C
8300       implicit real*8 (a-h,o-z)
8301       include 'DIMENSIONS'
8302       include 'COMMON.IOUNITS'
8303       include 'COMMON.CHAIN'
8304       include 'COMMON.DERIV'
8305       include 'COMMON.INTERACT'
8306       include 'COMMON.CONTACTS'
8307       include 'COMMON.TORSION'
8308       include 'COMMON.VAR'
8309       include 'COMMON.GEO'
8310       include 'COMMON.FFIELD'
8311       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8312      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8313       logical lprn
8314       common /kutas/ lprn
8315 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8316 cd     & ' jj=',jj,' kk=',kk
8317 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8318 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8319 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8320       do iii=1,2
8321         do jjj=1,2
8322           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8323           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8324         enddo
8325       enddo
8326       call transpose2(aa1(1,1),aa1t(1,1))
8327       call transpose2(aa2(1,1),aa2t(1,1))
8328       do kkk=1,5
8329         do lll=1,3
8330           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8331      &      aa1tder(1,1,lll,kkk))
8332           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8333      &      aa2tder(1,1,lll,kkk))
8334         enddo
8335       enddo
8336       if (l.eq.j+1) then
8337 C parallel orientation of the two CA-CA-CA frames.
8338         if (i.gt.1) then
8339           iti=itortyp(itype(i))
8340         else
8341           iti=ntortyp
8342         endif
8343         itk1=itortyp(itype(k+1))
8344         itj=itortyp(itype(j))
8345         if (l.lt.nres-1) then
8346           itl1=itortyp(itype(l+1))
8347         else
8348           itl1=ntortyp
8349         endif
8350 C A1 kernel(j+1) A2T
8351 cd        do iii=1,2
8352 cd          write (iout,'(3f10.5,5x,3f10.5)')
8353 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8354 cd        enddo
8355         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8356      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8357      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8358 C Following matrices are needed only for 6-th order cumulants
8359         IF (wcorr6.gt.0.0d0) THEN
8360         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8361      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8362      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8363         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8364      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8365      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8366      &   ADtEAderx(1,1,1,1,1,1))
8367         lprn=.false.
8368         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8369      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8370      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8371      &   ADtEA1derx(1,1,1,1,1,1))
8372         ENDIF
8373 C End 6-th order cumulants
8374 cd        lprn=.false.
8375 cd        if (lprn) then
8376 cd        write (2,*) 'In calc_eello6'
8377 cd        do iii=1,2
8378 cd          write (2,*) 'iii=',iii
8379 cd          do kkk=1,5
8380 cd            write (2,*) 'kkk=',kkk
8381 cd            do jjj=1,2
8382 cd              write (2,'(3(2f10.5),5x)')
8383 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8384 cd            enddo
8385 cd          enddo
8386 cd        enddo
8387 cd        endif
8388         call transpose2(EUgder(1,1,k),auxmat(1,1))
8389         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8390         call transpose2(EUg(1,1,k),auxmat(1,1))
8391         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8392         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8393         do iii=1,2
8394           do kkk=1,5
8395             do lll=1,3
8396               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8397      &          EAEAderx(1,1,lll,kkk,iii,1))
8398             enddo
8399           enddo
8400         enddo
8401 C A1T kernel(i+1) A2
8402         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8403      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8404      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8405 C Following matrices are needed only for 6-th order cumulants
8406         IF (wcorr6.gt.0.0d0) THEN
8407         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8408      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8409      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8410         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8411      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8412      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8413      &   ADtEAderx(1,1,1,1,1,2))
8414         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8415      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8416      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8417      &   ADtEA1derx(1,1,1,1,1,2))
8418         ENDIF
8419 C End 6-th order cumulants
8420         call transpose2(EUgder(1,1,l),auxmat(1,1))
8421         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8422         call transpose2(EUg(1,1,l),auxmat(1,1))
8423         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8424         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8425         do iii=1,2
8426           do kkk=1,5
8427             do lll=1,3
8428               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8429      &          EAEAderx(1,1,lll,kkk,iii,2))
8430             enddo
8431           enddo
8432         enddo
8433 C AEAb1 and AEAb2
8434 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8435 C They are needed only when the fifth- or the sixth-order cumulants are
8436 C indluded.
8437         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8438         call transpose2(AEA(1,1,1),auxmat(1,1))
8439         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8440         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8441         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8442         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8443         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8444         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8445         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8446         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8447         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8448         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8449         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8450         call transpose2(AEA(1,1,2),auxmat(1,1))
8451         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8452         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8453         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8454         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8455         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8456         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8457         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8458         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8459         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8460         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8461         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8462 C Calculate the Cartesian derivatives of the vectors.
8463         do iii=1,2
8464           do kkk=1,5
8465             do lll=1,3
8466               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8467               call matvec2(auxmat(1,1),b1(1,i),
8468      &          AEAb1derx(1,lll,kkk,iii,1,1))
8469               call matvec2(auxmat(1,1),Ub2(1,i),
8470      &          AEAb2derx(1,lll,kkk,iii,1,1))
8471               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8472      &          AEAb1derx(1,lll,kkk,iii,2,1))
8473               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8474      &          AEAb2derx(1,lll,kkk,iii,2,1))
8475               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8476               call matvec2(auxmat(1,1),b1(1,j),
8477      &          AEAb1derx(1,lll,kkk,iii,1,2))
8478               call matvec2(auxmat(1,1),Ub2(1,j),
8479      &          AEAb2derx(1,lll,kkk,iii,1,2))
8480               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8481      &          AEAb1derx(1,lll,kkk,iii,2,2))
8482               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8483      &          AEAb2derx(1,lll,kkk,iii,2,2))
8484             enddo
8485           enddo
8486         enddo
8487         ENDIF
8488 C End vectors
8489       else
8490 C Antiparallel orientation of the two CA-CA-CA frames.
8491         if (i.gt.1) then
8492           iti=itortyp(itype(i))
8493         else
8494           iti=ntortyp
8495         endif
8496         itk1=itortyp(itype(k+1))
8497         itl=itortyp(itype(l))
8498         itj=itortyp(itype(j))
8499         if (j.lt.nres-1) then
8500           itj1=itortyp(itype(j+1))
8501         else
8502           itj1=ntortyp
8503         endif
8504 C A2 kernel(j-1)T A1T
8505         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8506      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8507      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8508 C Following matrices are needed only for 6-th order cumulants
8509         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8510      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8511         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8512      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8513      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8514         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8515      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8516      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8517      &   ADtEAderx(1,1,1,1,1,1))
8518         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8519      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8520      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8521      &   ADtEA1derx(1,1,1,1,1,1))
8522         ENDIF
8523 C End 6-th order cumulants
8524         call transpose2(EUgder(1,1,k),auxmat(1,1))
8525         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8526         call transpose2(EUg(1,1,k),auxmat(1,1))
8527         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8528         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8529         do iii=1,2
8530           do kkk=1,5
8531             do lll=1,3
8532               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8533      &          EAEAderx(1,1,lll,kkk,iii,1))
8534             enddo
8535           enddo
8536         enddo
8537 C A2T kernel(i+1)T A1
8538         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8539      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8540      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8541 C Following matrices are needed only for 6-th order cumulants
8542         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8543      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8544         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8545      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8546      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8547         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8548      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8549      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8550      &   ADtEAderx(1,1,1,1,1,2))
8551         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8552      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8553      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8554      &   ADtEA1derx(1,1,1,1,1,2))
8555         ENDIF
8556 C End 6-th order cumulants
8557         call transpose2(EUgder(1,1,j),auxmat(1,1))
8558         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8559         call transpose2(EUg(1,1,j),auxmat(1,1))
8560         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8561         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8562         do iii=1,2
8563           do kkk=1,5
8564             do lll=1,3
8565               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8566      &          EAEAderx(1,1,lll,kkk,iii,2))
8567             enddo
8568           enddo
8569         enddo
8570 C AEAb1 and AEAb2
8571 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8572 C They are needed only when the fifth- or the sixth-order cumulants are
8573 C indluded.
8574         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8575      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8576         call transpose2(AEA(1,1,1),auxmat(1,1))
8577         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8578         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8579         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8580         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8581         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8582         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8583         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8584         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8585         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8586         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8587         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8588         call transpose2(AEA(1,1,2),auxmat(1,1))
8589         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8590         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8591         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8592         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8593         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8594         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8595         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8596         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8597         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8598         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8599         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8600 C Calculate the Cartesian derivatives of the vectors.
8601         do iii=1,2
8602           do kkk=1,5
8603             do lll=1,3
8604               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8605               call matvec2(auxmat(1,1),b1(1,i),
8606      &          AEAb1derx(1,lll,kkk,iii,1,1))
8607               call matvec2(auxmat(1,1),Ub2(1,i),
8608      &          AEAb2derx(1,lll,kkk,iii,1,1))
8609               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8610      &          AEAb1derx(1,lll,kkk,iii,2,1))
8611               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8612      &          AEAb2derx(1,lll,kkk,iii,2,1))
8613               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8614               call matvec2(auxmat(1,1),b1(1,l),
8615      &          AEAb1derx(1,lll,kkk,iii,1,2))
8616               call matvec2(auxmat(1,1),Ub2(1,l),
8617      &          AEAb2derx(1,lll,kkk,iii,1,2))
8618               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8619      &          AEAb1derx(1,lll,kkk,iii,2,2))
8620               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8621      &          AEAb2derx(1,lll,kkk,iii,2,2))
8622             enddo
8623           enddo
8624         enddo
8625         ENDIF
8626 C End vectors
8627       endif
8628       return
8629       end
8630 C---------------------------------------------------------------------------
8631       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8632      &  KK,KKderg,AKA,AKAderg,AKAderx)
8633       implicit none
8634       integer nderg
8635       logical transp
8636       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8637      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8638      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8639       integer iii,kkk,lll
8640       integer jjj,mmm
8641       logical lprn
8642       common /kutas/ lprn
8643       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8644       do iii=1,nderg
8645         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8646      &    AKAderg(1,1,iii))
8647       enddo
8648 cd      if (lprn) write (2,*) 'In kernel'
8649       do kkk=1,5
8650 cd        if (lprn) write (2,*) 'kkk=',kkk
8651         do lll=1,3
8652           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8653      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8654 cd          if (lprn) then
8655 cd            write (2,*) 'lll=',lll
8656 cd            write (2,*) 'iii=1'
8657 cd            do jjj=1,2
8658 cd              write (2,'(3(2f10.5),5x)')
8659 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8660 cd            enddo
8661 cd          endif
8662           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8663      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8664 cd          if (lprn) then
8665 cd            write (2,*) 'lll=',lll
8666 cd            write (2,*) 'iii=2'
8667 cd            do jjj=1,2
8668 cd              write (2,'(3(2f10.5),5x)')
8669 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8670 cd            enddo
8671 cd          endif
8672         enddo
8673       enddo
8674       return
8675       end
8676 C---------------------------------------------------------------------------
8677       double precision function eello4(i,j,k,l,jj,kk)
8678       implicit real*8 (a-h,o-z)
8679       include 'DIMENSIONS'
8680       include 'COMMON.IOUNITS'
8681       include 'COMMON.CHAIN'
8682       include 'COMMON.DERIV'
8683       include 'COMMON.INTERACT'
8684       include 'COMMON.CONTACTS'
8685       include 'COMMON.TORSION'
8686       include 'COMMON.VAR'
8687       include 'COMMON.GEO'
8688       double precision pizda(2,2),ggg1(3),ggg2(3)
8689 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8690 cd        eello4=0.0d0
8691 cd        return
8692 cd      endif
8693 cd      print *,'eello4:',i,j,k,l,jj,kk
8694 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8695 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8696 cold      eij=facont_hb(jj,i)
8697 cold      ekl=facont_hb(kk,k)
8698 cold      ekont=eij*ekl
8699       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8700 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8701       gcorr_loc(k-1)=gcorr_loc(k-1)
8702      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8703       if (l.eq.j+1) then
8704         gcorr_loc(l-1)=gcorr_loc(l-1)
8705      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8706       else
8707         gcorr_loc(j-1)=gcorr_loc(j-1)
8708      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8709       endif
8710       do iii=1,2
8711         do kkk=1,5
8712           do lll=1,3
8713             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8714      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8715 cd            derx(lll,kkk,iii)=0.0d0
8716           enddo
8717         enddo
8718       enddo
8719 cd      gcorr_loc(l-1)=0.0d0
8720 cd      gcorr_loc(j-1)=0.0d0
8721 cd      gcorr_loc(k-1)=0.0d0
8722 cd      eel4=1.0d0
8723 cd      write (iout,*)'Contacts have occurred for peptide groups',
8724 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8725 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8726       if (j.lt.nres-1) then
8727         j1=j+1
8728         j2=j-1
8729       else
8730         j1=j-1
8731         j2=j-2
8732       endif
8733       if (l.lt.nres-1) then
8734         l1=l+1
8735         l2=l-1
8736       else
8737         l1=l-1
8738         l2=l-2
8739       endif
8740       do ll=1,3
8741 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8742 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8743         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8744         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8745 cgrad        ghalf=0.5d0*ggg1(ll)
8746         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8747         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8748         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8749         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8750         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8751         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8752 cgrad        ghalf=0.5d0*ggg2(ll)
8753         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8754         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8755         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8756         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8757         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8758         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8759       enddo
8760 cgrad      do m=i+1,j-1
8761 cgrad        do ll=1,3
8762 cgrad          gradcorr(ll,m)=gradcorr(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 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8768 cgrad        enddo
8769 cgrad      enddo
8770 cgrad      do m=i+2,j2
8771 cgrad        do ll=1,3
8772 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8773 cgrad        enddo
8774 cgrad      enddo
8775 cgrad      do m=k+2,l2
8776 cgrad        do ll=1,3
8777 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8778 cgrad        enddo
8779 cgrad      enddo
8780 cd      do iii=1,nres-3
8781 cd        write (2,*) iii,gcorr_loc(iii)
8782 cd      enddo
8783       eello4=ekont*eel4
8784 cd      write (2,*) 'ekont',ekont
8785 cd      write (iout,*) 'eello4',ekont*eel4
8786       return
8787       end
8788 C---------------------------------------------------------------------------
8789       double precision function eello5(i,j,k,l,jj,kk)
8790       implicit real*8 (a-h,o-z)
8791       include 'DIMENSIONS'
8792       include 'COMMON.IOUNITS'
8793       include 'COMMON.CHAIN'
8794       include 'COMMON.DERIV'
8795       include 'COMMON.INTERACT'
8796       include 'COMMON.CONTACTS'
8797       include 'COMMON.TORSION'
8798       include 'COMMON.VAR'
8799       include 'COMMON.GEO'
8800       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8801       double precision ggg1(3),ggg2(3)
8802 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8803 C                                                                              C
8804 C                            Parallel chains                                   C
8805 C                                                                              C
8806 C          o             o                   o             o                   C
8807 C         /l\           / \             \   / \           / \   /              C
8808 C        /   \         /   \             \ /   \         /   \ /               C
8809 C       j| o |l1       | o |              o| o |         | o |o                C
8810 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8811 C      \i/   \         /   \ /             /   \         /   \                 C
8812 C       o    k1             o                                                  C
8813 C         (I)          (II)                (III)          (IV)                 C
8814 C                                                                              C
8815 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8816 C                                                                              C
8817 C                            Antiparallel chains                               C
8818 C                                                                              C
8819 C          o             o                   o             o                   C
8820 C         /j\           / \             \   / \           / \   /              C
8821 C        /   \         /   \             \ /   \         /   \ /               C
8822 C      j1| o |l        | o |              o| o |         | o |o                C
8823 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8824 C      \i/   \         /   \ /             /   \         /   \                 C
8825 C       o     k1            o                                                  C
8826 C         (I)          (II)                (III)          (IV)                 C
8827 C                                                                              C
8828 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8829 C                                                                              C
8830 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8831 C                                                                              C
8832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8833 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8834 cd        eello5=0.0d0
8835 cd        return
8836 cd      endif
8837 cd      write (iout,*)
8838 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8839 cd     &   ' and',k,l
8840       itk=itortyp(itype(k))
8841       itl=itortyp(itype(l))
8842       itj=itortyp(itype(j))
8843       eello5_1=0.0d0
8844       eello5_2=0.0d0
8845       eello5_3=0.0d0
8846       eello5_4=0.0d0
8847 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8848 cd     &   eel5_3_num,eel5_4_num)
8849       do iii=1,2
8850         do kkk=1,5
8851           do lll=1,3
8852             derx(lll,kkk,iii)=0.0d0
8853           enddo
8854         enddo
8855       enddo
8856 cd      eij=facont_hb(jj,i)
8857 cd      ekl=facont_hb(kk,k)
8858 cd      ekont=eij*ekl
8859 cd      write (iout,*)'Contacts have occurred for peptide groups',
8860 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8861 cd      goto 1111
8862 C Contribution from the graph I.
8863 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8864 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8865       call transpose2(EUg(1,1,k),auxmat(1,1))
8866       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8867       vv(1)=pizda(1,1)-pizda(2,2)
8868       vv(2)=pizda(1,2)+pizda(2,1)
8869       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8870      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8871 C Explicit gradient in virtual-dihedral angles.
8872       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8873      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8874      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8875       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8876       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8877       vv(1)=pizda(1,1)-pizda(2,2)
8878       vv(2)=pizda(1,2)+pizda(2,1)
8879       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8880      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8881      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8882       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8883       vv(1)=pizda(1,1)-pizda(2,2)
8884       vv(2)=pizda(1,2)+pizda(2,1)
8885       if (l.eq.j+1) then
8886         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8887      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8888      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8889       else
8890         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8891      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8892      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8893       endif
8894 C Cartesian gradient
8895       do iii=1,2
8896         do kkk=1,5
8897           do lll=1,3
8898             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8899      &        pizda(1,1))
8900             vv(1)=pizda(1,1)-pizda(2,2)
8901             vv(2)=pizda(1,2)+pizda(2,1)
8902             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8903      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8904      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8905           enddo
8906         enddo
8907       enddo
8908 c      goto 1112
8909 c1111  continue
8910 C Contribution from graph II
8911       call transpose2(EE(1,1,itk),auxmat(1,1))
8912       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8913       vv(1)=pizda(1,1)+pizda(2,2)
8914       vv(2)=pizda(2,1)-pizda(1,2)
8915       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8916      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8917 C Explicit gradient in virtual-dihedral angles.
8918       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8919      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8920       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8921       vv(1)=pizda(1,1)+pizda(2,2)
8922       vv(2)=pizda(2,1)-pizda(1,2)
8923       if (l.eq.j+1) then
8924         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8925      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8926      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8927       else
8928         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8929      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8930      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8931       endif
8932 C Cartesian gradient
8933       do iii=1,2
8934         do kkk=1,5
8935           do lll=1,3
8936             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8937      &        pizda(1,1))
8938             vv(1)=pizda(1,1)+pizda(2,2)
8939             vv(2)=pizda(2,1)-pizda(1,2)
8940             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8941      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8942      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8943           enddo
8944         enddo
8945       enddo
8946 cd      goto 1112
8947 cd1111  continue
8948       if (l.eq.j+1) then
8949 cd        goto 1110
8950 C Parallel orientation
8951 C Contribution from graph III
8952         call transpose2(EUg(1,1,l),auxmat(1,1))
8953         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8954         vv(1)=pizda(1,1)-pizda(2,2)
8955         vv(2)=pizda(1,2)+pizda(2,1)
8956         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8957      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8958 C Explicit gradient in virtual-dihedral angles.
8959         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8960      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8961      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8962         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8963         vv(1)=pizda(1,1)-pizda(2,2)
8964         vv(2)=pizda(1,2)+pizda(2,1)
8965         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8966      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8967      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8968         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8969         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8970         vv(1)=pizda(1,1)-pizda(2,2)
8971         vv(2)=pizda(1,2)+pizda(2,1)
8972         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8973      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8974      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8975 C Cartesian gradient
8976         do iii=1,2
8977           do kkk=1,5
8978             do lll=1,3
8979               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8980      &          pizda(1,1))
8981               vv(1)=pizda(1,1)-pizda(2,2)
8982               vv(2)=pizda(1,2)+pizda(2,1)
8983               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8984      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8985      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8986             enddo
8987           enddo
8988         enddo
8989 cd        goto 1112
8990 C Contribution from graph IV
8991 cd1110    continue
8992         call transpose2(EE(1,1,itl),auxmat(1,1))
8993         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8994         vv(1)=pizda(1,1)+pizda(2,2)
8995         vv(2)=pizda(2,1)-pizda(1,2)
8996         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8997      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8998 C Explicit gradient in virtual-dihedral angles.
8999         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9000      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9001         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9002         vv(1)=pizda(1,1)+pizda(2,2)
9003         vv(2)=pizda(2,1)-pizda(1,2)
9004         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9005      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9006      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9007 C Cartesian gradient
9008         do iii=1,2
9009           do kkk=1,5
9010             do lll=1,3
9011               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9012      &          pizda(1,1))
9013               vv(1)=pizda(1,1)+pizda(2,2)
9014               vv(2)=pizda(2,1)-pizda(1,2)
9015               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9016      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9017      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9018             enddo
9019           enddo
9020         enddo
9021       else
9022 C Antiparallel orientation
9023 C Contribution from graph III
9024 c        goto 1110
9025         call transpose2(EUg(1,1,j),auxmat(1,1))
9026         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9027         vv(1)=pizda(1,1)-pizda(2,2)
9028         vv(2)=pizda(1,2)+pizda(2,1)
9029         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9030      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9031 C Explicit gradient in virtual-dihedral angles.
9032         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9033      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9034      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9035         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9036         vv(1)=pizda(1,1)-pizda(2,2)
9037         vv(2)=pizda(1,2)+pizda(2,1)
9038         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9039      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9040      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9041         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9042         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9043         vv(1)=pizda(1,1)-pizda(2,2)
9044         vv(2)=pizda(1,2)+pizda(2,1)
9045         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9046      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9047      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9048 C Cartesian gradient
9049         do iii=1,2
9050           do kkk=1,5
9051             do lll=1,3
9052               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9053      &          pizda(1,1))
9054               vv(1)=pizda(1,1)-pizda(2,2)
9055               vv(2)=pizda(1,2)+pizda(2,1)
9056               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9057      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9058      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9059             enddo
9060           enddo
9061         enddo
9062 cd        goto 1112
9063 C Contribution from graph IV
9064 1110    continue
9065         call transpose2(EE(1,1,itj),auxmat(1,1))
9066         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9067         vv(1)=pizda(1,1)+pizda(2,2)
9068         vv(2)=pizda(2,1)-pizda(1,2)
9069         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9070      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9071 C Explicit gradient in virtual-dihedral angles.
9072         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9073      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9074         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9075         vv(1)=pizda(1,1)+pizda(2,2)
9076         vv(2)=pizda(2,1)-pizda(1,2)
9077         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9078      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9079      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9080 C Cartesian gradient
9081         do iii=1,2
9082           do kkk=1,5
9083             do lll=1,3
9084               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9085      &          pizda(1,1))
9086               vv(1)=pizda(1,1)+pizda(2,2)
9087               vv(2)=pizda(2,1)-pizda(1,2)
9088               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9089      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9090      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9091             enddo
9092           enddo
9093         enddo
9094       endif
9095 1112  continue
9096       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9097 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9098 cd        write (2,*) 'ijkl',i,j,k,l
9099 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9100 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9101 cd      endif
9102 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9103 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9104 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9105 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9106       if (j.lt.nres-1) then
9107         j1=j+1
9108         j2=j-1
9109       else
9110         j1=j-1
9111         j2=j-2
9112       endif
9113       if (l.lt.nres-1) then
9114         l1=l+1
9115         l2=l-1
9116       else
9117         l1=l-1
9118         l2=l-2
9119       endif
9120 cd      eij=1.0d0
9121 cd      ekl=1.0d0
9122 cd      ekont=1.0d0
9123 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9124 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9125 C        summed up outside the subrouine as for the other subroutines
9126 C        handling long-range interactions. The old code is commented out
9127 C        with "cgrad" to keep track of changes.
9128       do ll=1,3
9129 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9130 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9131         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9132         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9133 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9134 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9135 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9136 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9137 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9138 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9139 c     &   gradcorr5ij,
9140 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9141 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9142 cgrad        ghalf=0.5d0*ggg1(ll)
9143 cd        ghalf=0.0d0
9144         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9145         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9146         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9147         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9148         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9149         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9150 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9151 cgrad        ghalf=0.5d0*ggg2(ll)
9152 cd        ghalf=0.0d0
9153         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9154         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9155         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9156         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9157         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9158         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9159       enddo
9160 cd      goto 1112
9161 cgrad      do m=i+1,j-1
9162 cgrad        do ll=1,3
9163 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9164 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9165 cgrad        enddo
9166 cgrad      enddo
9167 cgrad      do m=k+1,l-1
9168 cgrad        do ll=1,3
9169 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9170 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9171 cgrad        enddo
9172 cgrad      enddo
9173 c1112  continue
9174 cgrad      do m=i+2,j2
9175 cgrad        do ll=1,3
9176 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9177 cgrad        enddo
9178 cgrad      enddo
9179 cgrad      do m=k+2,l2
9180 cgrad        do ll=1,3
9181 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9182 cgrad        enddo
9183 cgrad      enddo
9184 cd      do iii=1,nres-3
9185 cd        write (2,*) iii,g_corr5_loc(iii)
9186 cd      enddo
9187       eello5=ekont*eel5
9188 cd      write (2,*) 'ekont',ekont
9189 cd      write (iout,*) 'eello5',ekont*eel5
9190       return
9191       end
9192 c--------------------------------------------------------------------------
9193       double precision function eello6(i,j,k,l,jj,kk)
9194       implicit real*8 (a-h,o-z)
9195       include 'DIMENSIONS'
9196       include 'COMMON.IOUNITS'
9197       include 'COMMON.CHAIN'
9198       include 'COMMON.DERIV'
9199       include 'COMMON.INTERACT'
9200       include 'COMMON.CONTACTS'
9201       include 'COMMON.TORSION'
9202       include 'COMMON.VAR'
9203       include 'COMMON.GEO'
9204       include 'COMMON.FFIELD'
9205       double precision ggg1(3),ggg2(3)
9206 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9207 cd        eello6=0.0d0
9208 cd        return
9209 cd      endif
9210 cd      write (iout,*)
9211 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9212 cd     &   ' and',k,l
9213       eello6_1=0.0d0
9214       eello6_2=0.0d0
9215       eello6_3=0.0d0
9216       eello6_4=0.0d0
9217       eello6_5=0.0d0
9218       eello6_6=0.0d0
9219 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9220 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9221       do iii=1,2
9222         do kkk=1,5
9223           do lll=1,3
9224             derx(lll,kkk,iii)=0.0d0
9225           enddo
9226         enddo
9227       enddo
9228 cd      eij=facont_hb(jj,i)
9229 cd      ekl=facont_hb(kk,k)
9230 cd      ekont=eij*ekl
9231 cd      eij=1.0d0
9232 cd      ekl=1.0d0
9233 cd      ekont=1.0d0
9234       if (l.eq.j+1) then
9235         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9236         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9237         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9238         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9239         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9240         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9241       else
9242         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9243         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9244         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9245         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9246         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9247           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9248         else
9249           eello6_5=0.0d0
9250         endif
9251         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9252       endif
9253 C If turn contributions are considered, they will be handled separately.
9254       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9255 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9256 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9257 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9258 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9259 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9260 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9261 cd      goto 1112
9262       if (j.lt.nres-1) then
9263         j1=j+1
9264         j2=j-1
9265       else
9266         j1=j-1
9267         j2=j-2
9268       endif
9269       if (l.lt.nres-1) then
9270         l1=l+1
9271         l2=l-1
9272       else
9273         l1=l-1
9274         l2=l-2
9275       endif
9276       do ll=1,3
9277 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9278 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9279 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9280 cgrad        ghalf=0.5d0*ggg1(ll)
9281 cd        ghalf=0.0d0
9282         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9283         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9284         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9285         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9286         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9287         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9288         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9289         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9290 cgrad        ghalf=0.5d0*ggg2(ll)
9291 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9292 cd        ghalf=0.0d0
9293         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9294         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9295         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9296         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9297         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9298         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9299       enddo
9300 cd      goto 1112
9301 cgrad      do m=i+1,j-1
9302 cgrad        do ll=1,3
9303 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9304 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9305 cgrad        enddo
9306 cgrad      enddo
9307 cgrad      do m=k+1,l-1
9308 cgrad        do ll=1,3
9309 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9310 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9311 cgrad        enddo
9312 cgrad      enddo
9313 cgrad1112  continue
9314 cgrad      do m=i+2,j2
9315 cgrad        do ll=1,3
9316 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9317 cgrad        enddo
9318 cgrad      enddo
9319 cgrad      do m=k+2,l2
9320 cgrad        do ll=1,3
9321 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9322 cgrad        enddo
9323 cgrad      enddo
9324 cd      do iii=1,nres-3
9325 cd        write (2,*) iii,g_corr6_loc(iii)
9326 cd      enddo
9327       eello6=ekont*eel6
9328 cd      write (2,*) 'ekont',ekont
9329 cd      write (iout,*) 'eello6',ekont*eel6
9330       return
9331       end
9332 c--------------------------------------------------------------------------
9333       double precision function eello6_graph1(i,j,k,l,imat,swap)
9334       implicit real*8 (a-h,o-z)
9335       include 'DIMENSIONS'
9336       include 'COMMON.IOUNITS'
9337       include 'COMMON.CHAIN'
9338       include 'COMMON.DERIV'
9339       include 'COMMON.INTERACT'
9340       include 'COMMON.CONTACTS'
9341       include 'COMMON.TORSION'
9342       include 'COMMON.VAR'
9343       include 'COMMON.GEO'
9344       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9345       logical swap
9346       logical lprn
9347       common /kutas/ lprn
9348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9349 C                                                                              C
9350 C      Parallel       Antiparallel                                             C
9351 C                                                                              C
9352 C          o             o                                                     C
9353 C         /l\           /j\                                                    C
9354 C        /   \         /   \                                                   C
9355 C       /| o |         | o |\                                                  C
9356 C     \ j|/k\|  /   \  |/k\|l /                                                C
9357 C      \ /   \ /     \ /   \ /                                                 C
9358 C       o     o       o     o                                                  C
9359 C       i             i                                                        C
9360 C                                                                              C
9361 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9362       itk=itortyp(itype(k))
9363       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9364       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9365       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9366       call transpose2(EUgC(1,1,k),auxmat(1,1))
9367       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9368       vv1(1)=pizda1(1,1)-pizda1(2,2)
9369       vv1(2)=pizda1(1,2)+pizda1(2,1)
9370       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9371       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9372       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9373       s5=scalar2(vv(1),Dtobr2(1,i))
9374 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9375       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9376       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9377      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9378      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9379      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9380      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9381      & +scalar2(vv(1),Dtobr2der(1,i)))
9382       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9383       vv1(1)=pizda1(1,1)-pizda1(2,2)
9384       vv1(2)=pizda1(1,2)+pizda1(2,1)
9385       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9386       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9387       if (l.eq.j+1) then
9388         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9389      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9390      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9391      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9392      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9393       else
9394         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9395      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9396      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9397      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9398      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9399       endif
9400       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9401       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9402       vv1(1)=pizda1(1,1)-pizda1(2,2)
9403       vv1(2)=pizda1(1,2)+pizda1(2,1)
9404       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9405      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9406      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9407      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9408       do iii=1,2
9409         if (swap) then
9410           ind=3-iii
9411         else
9412           ind=iii
9413         endif
9414         do kkk=1,5
9415           do lll=1,3
9416             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9417             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9418             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9419             call transpose2(EUgC(1,1,k),auxmat(1,1))
9420             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9421      &        pizda1(1,1))
9422             vv1(1)=pizda1(1,1)-pizda1(2,2)
9423             vv1(2)=pizda1(1,2)+pizda1(2,1)
9424             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9425             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9426      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9427             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9428      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9429             s5=scalar2(vv(1),Dtobr2(1,i))
9430             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9431           enddo
9432         enddo
9433       enddo
9434       return
9435       end
9436 c----------------------------------------------------------------------------
9437       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9438       implicit real*8 (a-h,o-z)
9439       include 'DIMENSIONS'
9440       include 'COMMON.IOUNITS'
9441       include 'COMMON.CHAIN'
9442       include 'COMMON.DERIV'
9443       include 'COMMON.INTERACT'
9444       include 'COMMON.CONTACTS'
9445       include 'COMMON.TORSION'
9446       include 'COMMON.VAR'
9447       include 'COMMON.GEO'
9448       logical swap
9449       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9450      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9451       logical lprn
9452       common /kutas/ lprn
9453 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9454 C                                                                              C
9455 C      Parallel       Antiparallel                                             C
9456 C                                                                              C
9457 C          o             o                                                     C
9458 C     \   /l\           /j\   /                                                C
9459 C      \ /   \         /   \ /                                                 C
9460 C       o| o |         | o |o                                                  C
9461 C     \ j|/k\|      \  |/k\|l                                                  C
9462 C      \ /   \       \ /   \                                                   C
9463 C       o             o                                                        C
9464 C       i             i                                                        C
9465 C                                                                              C
9466 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9467 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9468 C AL 7/4/01 s1 would occur in the sixth-order moment,
9469 C           but not in a cluster cumulant
9470 #ifdef MOMENT
9471       s1=dip(1,jj,i)*dip(1,kk,k)
9472 #endif
9473       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9474       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9475       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9476       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9477       call transpose2(EUg(1,1,k),auxmat(1,1))
9478       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9479       vv(1)=pizda(1,1)-pizda(2,2)
9480       vv(2)=pizda(1,2)+pizda(2,1)
9481       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9482 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9483 #ifdef MOMENT
9484       eello6_graph2=-(s1+s2+s3+s4)
9485 #else
9486       eello6_graph2=-(s2+s3+s4)
9487 #endif
9488 c      eello6_graph2=-s3
9489 C Derivatives in gamma(i-1)
9490       if (i.gt.1) then
9491 #ifdef MOMENT
9492         s1=dipderg(1,jj,i)*dip(1,kk,k)
9493 #endif
9494         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9495         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9496         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9497         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9498 #ifdef MOMENT
9499         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9500 #else
9501         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9502 #endif
9503 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9504       endif
9505 C Derivatives in gamma(k-1)
9506 #ifdef MOMENT
9507       s1=dip(1,jj,i)*dipderg(1,kk,k)
9508 #endif
9509       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9510       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9511       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9512       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9513       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9514       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9515       vv(1)=pizda(1,1)-pizda(2,2)
9516       vv(2)=pizda(1,2)+pizda(2,1)
9517       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9518 #ifdef MOMENT
9519       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9520 #else
9521       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9522 #endif
9523 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9524 C Derivatives in gamma(j-1) or gamma(l-1)
9525       if (j.gt.1) then
9526 #ifdef MOMENT
9527         s1=dipderg(3,jj,i)*dip(1,kk,k)
9528 #endif
9529         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9530         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9531         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9532         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9533         vv(1)=pizda(1,1)-pizda(2,2)
9534         vv(2)=pizda(1,2)+pizda(2,1)
9535         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9536 #ifdef MOMENT
9537         if (swap) then
9538           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9539         else
9540           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9541         endif
9542 #endif
9543         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9544 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9545       endif
9546 C Derivatives in gamma(l-1) or gamma(j-1)
9547       if (l.gt.1) then
9548 #ifdef MOMENT
9549         s1=dip(1,jj,i)*dipderg(3,kk,k)
9550 #endif
9551         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9552         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9553         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9554         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9555         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9556         vv(1)=pizda(1,1)-pizda(2,2)
9557         vv(2)=pizda(1,2)+pizda(2,1)
9558         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9559 #ifdef MOMENT
9560         if (swap) then
9561           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9562         else
9563           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9564         endif
9565 #endif
9566         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9567 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9568       endif
9569 C Cartesian derivatives.
9570       if (lprn) then
9571         write (2,*) 'In eello6_graph2'
9572         do iii=1,2
9573           write (2,*) 'iii=',iii
9574           do kkk=1,5
9575             write (2,*) 'kkk=',kkk
9576             do jjj=1,2
9577               write (2,'(3(2f10.5),5x)')
9578      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9579             enddo
9580           enddo
9581         enddo
9582       endif
9583       do iii=1,2
9584         do kkk=1,5
9585           do lll=1,3
9586 #ifdef MOMENT
9587             if (iii.eq.1) then
9588               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9589             else
9590               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9591             endif
9592 #endif
9593             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9594      &        auxvec(1))
9595             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9596             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9597      &        auxvec(1))
9598             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9599             call transpose2(EUg(1,1,k),auxmat(1,1))
9600             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9601      &        pizda(1,1))
9602             vv(1)=pizda(1,1)-pizda(2,2)
9603             vv(2)=pizda(1,2)+pizda(2,1)
9604             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9605 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9606 #ifdef MOMENT
9607             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9608 #else
9609             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9610 #endif
9611             if (swap) then
9612               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9613             else
9614               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9615             endif
9616           enddo
9617         enddo
9618       enddo
9619       return
9620       end
9621 c----------------------------------------------------------------------------
9622       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9623       implicit real*8 (a-h,o-z)
9624       include 'DIMENSIONS'
9625       include 'COMMON.IOUNITS'
9626       include 'COMMON.CHAIN'
9627       include 'COMMON.DERIV'
9628       include 'COMMON.INTERACT'
9629       include 'COMMON.CONTACTS'
9630       include 'COMMON.TORSION'
9631       include 'COMMON.VAR'
9632       include 'COMMON.GEO'
9633       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9634       logical swap
9635 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9636 C                                                                              C
9637 C      Parallel       Antiparallel                                             C
9638 C                                                                              C
9639 C          o             o                                                     C
9640 C         /l\   /   \   /j\                                                    C
9641 C        /   \ /     \ /   \                                                   C
9642 C       /| o |o       o| o |\                                                  C
9643 C       j|/k\|  /      |/k\|l /                                                C
9644 C        /   \ /       /   \ /                                                 C
9645 C       /     o       /     o                                                  C
9646 C       i             i                                                        C
9647 C                                                                              C
9648 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9649 C
9650 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9651 C           energy moment and not to the cluster cumulant.
9652       iti=itortyp(itype(i))
9653       if (j.lt.nres-1) then
9654         itj1=itortyp(itype(j+1))
9655       else
9656         itj1=ntortyp
9657       endif
9658       itk=itortyp(itype(k))
9659       itk1=itortyp(itype(k+1))
9660       if (l.lt.nres-1) then
9661         itl1=itortyp(itype(l+1))
9662       else
9663         itl1=ntortyp
9664       endif
9665 #ifdef MOMENT
9666       s1=dip(4,jj,i)*dip(4,kk,k)
9667 #endif
9668       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9669       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9670       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9671       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9672       call transpose2(EE(1,1,itk),auxmat(1,1))
9673       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9674       vv(1)=pizda(1,1)+pizda(2,2)
9675       vv(2)=pizda(2,1)-pizda(1,2)
9676       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9677 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9678 cd     & "sum",-(s2+s3+s4)
9679 #ifdef MOMENT
9680       eello6_graph3=-(s1+s2+s3+s4)
9681 #else
9682       eello6_graph3=-(s2+s3+s4)
9683 #endif
9684 c      eello6_graph3=-s4
9685 C Derivatives in gamma(k-1)
9686       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9687       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9688       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9689       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9690 C Derivatives in gamma(l-1)
9691       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9692       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9693       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9694       vv(1)=pizda(1,1)+pizda(2,2)
9695       vv(2)=pizda(2,1)-pizda(1,2)
9696       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9697       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9698 C Cartesian derivatives.
9699       do iii=1,2
9700         do kkk=1,5
9701           do lll=1,3
9702 #ifdef MOMENT
9703             if (iii.eq.1) then
9704               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9705             else
9706               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9707             endif
9708 #endif
9709             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9710      &        auxvec(1))
9711             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9712             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9713      &        auxvec(1))
9714             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9715             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9716      &        pizda(1,1))
9717             vv(1)=pizda(1,1)+pizda(2,2)
9718             vv(2)=pizda(2,1)-pizda(1,2)
9719             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9720 #ifdef MOMENT
9721             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9722 #else
9723             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9724 #endif
9725             if (swap) then
9726               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9727             else
9728               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9729             endif
9730 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9731           enddo
9732         enddo
9733       enddo
9734       return
9735       end
9736 c----------------------------------------------------------------------------
9737       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9738       implicit real*8 (a-h,o-z)
9739       include 'DIMENSIONS'
9740       include 'COMMON.IOUNITS'
9741       include 'COMMON.CHAIN'
9742       include 'COMMON.DERIV'
9743       include 'COMMON.INTERACT'
9744       include 'COMMON.CONTACTS'
9745       include 'COMMON.TORSION'
9746       include 'COMMON.VAR'
9747       include 'COMMON.GEO'
9748       include 'COMMON.FFIELD'
9749       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9750      & auxvec1(2),auxmat1(2,2)
9751       logical swap
9752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9753 C                                                                              C
9754 C      Parallel       Antiparallel                                             C
9755 C                                                                              C
9756 C          o             o                                                     C
9757 C         /l\   /   \   /j\                                                    C
9758 C        /   \ /     \ /   \                                                   C
9759 C       /| o |o       o| o |\                                                  C
9760 C     \ j|/k\|      \  |/k\|l                                                  C
9761 C      \ /   \       \ /   \                                                   C
9762 C       o     \       o     \                                                  C
9763 C       i             i                                                        C
9764 C                                                                              C
9765 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9766 C
9767 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9768 C           energy moment and not to the cluster cumulant.
9769 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9770       iti=itortyp(itype(i))
9771       itj=itortyp(itype(j))
9772       if (j.lt.nres-1) then
9773         itj1=itortyp(itype(j+1))
9774       else
9775         itj1=ntortyp
9776       endif
9777       itk=itortyp(itype(k))
9778       if (k.lt.nres-1) then
9779         itk1=itortyp(itype(k+1))
9780       else
9781         itk1=ntortyp
9782       endif
9783       itl=itortyp(itype(l))
9784       if (l.lt.nres-1) then
9785         itl1=itortyp(itype(l+1))
9786       else
9787         itl1=ntortyp
9788       endif
9789 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9790 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9791 cd     & ' itl',itl,' itl1',itl1
9792 #ifdef MOMENT
9793       if (imat.eq.1) then
9794         s1=dip(3,jj,i)*dip(3,kk,k)
9795       else
9796         s1=dip(2,jj,j)*dip(2,kk,l)
9797       endif
9798 #endif
9799       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9800       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9801       if (j.eq.l+1) then
9802         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9803         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9804       else
9805         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9806         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9807       endif
9808       call transpose2(EUg(1,1,k),auxmat(1,1))
9809       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9810       vv(1)=pizda(1,1)-pizda(2,2)
9811       vv(2)=pizda(2,1)+pizda(1,2)
9812       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9813 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9814 #ifdef MOMENT
9815       eello6_graph4=-(s1+s2+s3+s4)
9816 #else
9817       eello6_graph4=-(s2+s3+s4)
9818 #endif
9819 C Derivatives in gamma(i-1)
9820       if (i.gt.1) then
9821 #ifdef MOMENT
9822         if (imat.eq.1) then
9823           s1=dipderg(2,jj,i)*dip(3,kk,k)
9824         else
9825           s1=dipderg(4,jj,j)*dip(2,kk,l)
9826         endif
9827 #endif
9828         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9829         if (j.eq.l+1) then
9830           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9831           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9832         else
9833           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9834           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9835         endif
9836         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9837         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9838 cd          write (2,*) 'turn6 derivatives'
9839 #ifdef MOMENT
9840           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9841 #else
9842           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9843 #endif
9844         else
9845 #ifdef MOMENT
9846           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9847 #else
9848           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9849 #endif
9850         endif
9851       endif
9852 C Derivatives in gamma(k-1)
9853 #ifdef MOMENT
9854       if (imat.eq.1) then
9855         s1=dip(3,jj,i)*dipderg(2,kk,k)
9856       else
9857         s1=dip(2,jj,j)*dipderg(4,kk,l)
9858       endif
9859 #endif
9860       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9861       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9862       if (j.eq.l+1) then
9863         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9864         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9865       else
9866         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9867         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9868       endif
9869       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9870       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9871       vv(1)=pizda(1,1)-pizda(2,2)
9872       vv(2)=pizda(2,1)+pizda(1,2)
9873       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9874       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9875 #ifdef MOMENT
9876         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9877 #else
9878         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9879 #endif
9880       else
9881 #ifdef MOMENT
9882         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9883 #else
9884         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9885 #endif
9886       endif
9887 C Derivatives in gamma(j-1) or gamma(l-1)
9888       if (l.eq.j+1 .and. l.gt.1) then
9889         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9890         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9891         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9892         vv(1)=pizda(1,1)-pizda(2,2)
9893         vv(2)=pizda(2,1)+pizda(1,2)
9894         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9895         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9896       else if (j.gt.1) then
9897         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9898         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9899         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9900         vv(1)=pizda(1,1)-pizda(2,2)
9901         vv(2)=pizda(2,1)+pizda(1,2)
9902         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9903         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9904           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9905         else
9906           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9907         endif
9908       endif
9909 C Cartesian derivatives.
9910       do iii=1,2
9911         do kkk=1,5
9912           do lll=1,3
9913 #ifdef MOMENT
9914             if (iii.eq.1) then
9915               if (imat.eq.1) then
9916                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9917               else
9918                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9919               endif
9920             else
9921               if (imat.eq.1) then
9922                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9923               else
9924                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9925               endif
9926             endif
9927 #endif
9928             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9929      &        auxvec(1))
9930             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9931             if (j.eq.l+1) then
9932               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9933      &          b1(1,j+1),auxvec(1))
9934               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9935             else
9936               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9937      &          b1(1,l+1),auxvec(1))
9938               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9939             endif
9940             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9941      &        pizda(1,1))
9942             vv(1)=pizda(1,1)-pizda(2,2)
9943             vv(2)=pizda(2,1)+pizda(1,2)
9944             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9945             if (swap) then
9946               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9947 #ifdef MOMENT
9948                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9949      &             -(s1+s2+s4)
9950 #else
9951                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9952      &             -(s2+s4)
9953 #endif
9954                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9955               else
9956 #ifdef MOMENT
9957                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9958 #else
9959                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9960 #endif
9961                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9962               endif
9963             else
9964 #ifdef MOMENT
9965               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9966 #else
9967               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9968 #endif
9969               if (l.eq.j+1) then
9970                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9971               else
9972                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9973               endif
9974             endif
9975           enddo
9976         enddo
9977       enddo
9978       return
9979       end
9980 c----------------------------------------------------------------------------
9981       double precision function eello_turn6(i,jj,kk)
9982       implicit real*8 (a-h,o-z)
9983       include 'DIMENSIONS'
9984       include 'COMMON.IOUNITS'
9985       include 'COMMON.CHAIN'
9986       include 'COMMON.DERIV'
9987       include 'COMMON.INTERACT'
9988       include 'COMMON.CONTACTS'
9989       include 'COMMON.TORSION'
9990       include 'COMMON.VAR'
9991       include 'COMMON.GEO'
9992       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9993      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9994      &  ggg1(3),ggg2(3)
9995       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9996      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9997 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9998 C           the respective energy moment and not to the cluster cumulant.
9999       s1=0.0d0
10000       s8=0.0d0
10001       s13=0.0d0
10002 c
10003       eello_turn6=0.0d0
10004       j=i+4
10005       k=i+1
10006       l=i+3
10007       iti=itortyp(itype(i))
10008       itk=itortyp(itype(k))
10009       itk1=itortyp(itype(k+1))
10010       itl=itortyp(itype(l))
10011       itj=itortyp(itype(j))
10012 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10013 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10014 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10015 cd        eello6=0.0d0
10016 cd        return
10017 cd      endif
10018 cd      write (iout,*)
10019 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10020 cd     &   ' and',k,l
10021 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10022       do iii=1,2
10023         do kkk=1,5
10024           do lll=1,3
10025             derx_turn(lll,kkk,iii)=0.0d0
10026           enddo
10027         enddo
10028       enddo
10029 cd      eij=1.0d0
10030 cd      ekl=1.0d0
10031 cd      ekont=1.0d0
10032       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10033 cd      eello6_5=0.0d0
10034 cd      write (2,*) 'eello6_5',eello6_5
10035 #ifdef MOMENT
10036       call transpose2(AEA(1,1,1),auxmat(1,1))
10037       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10038       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10039       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10040 #endif
10041       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10042       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10043       s2 = scalar2(b1(1,k),vtemp1(1))
10044 #ifdef MOMENT
10045       call transpose2(AEA(1,1,2),atemp(1,1))
10046       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10047       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10048       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10049 #endif
10050       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10051       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10052       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10053 #ifdef MOMENT
10054       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10055       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10056       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10057       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10058       ss13 = scalar2(b1(1,k),vtemp4(1))
10059       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10060 #endif
10061 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10062 c      s1=0.0d0
10063 c      s2=0.0d0
10064 c      s8=0.0d0
10065 c      s12=0.0d0
10066 c      s13=0.0d0
10067       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10068 C Derivatives in gamma(i+2)
10069       s1d =0.0d0
10070       s8d =0.0d0
10071 #ifdef MOMENT
10072       call transpose2(AEA(1,1,1),auxmatd(1,1))
10073       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10074       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10075       call transpose2(AEAderg(1,1,2),atempd(1,1))
10076       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10077       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10078 #endif
10079       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10080       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10081       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10082 c      s1d=0.0d0
10083 c      s2d=0.0d0
10084 c      s8d=0.0d0
10085 c      s12d=0.0d0
10086 c      s13d=0.0d0
10087       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10088 C Derivatives in gamma(i+3)
10089 #ifdef MOMENT
10090       call transpose2(AEA(1,1,1),auxmatd(1,1))
10091       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10092       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10093       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10094 #endif
10095       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10096       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10097       s2d = scalar2(b1(1,k),vtemp1d(1))
10098 #ifdef MOMENT
10099       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10100       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10101 #endif
10102       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10103 #ifdef MOMENT
10104       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10105       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10106       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10107 #endif
10108 c      s1d=0.0d0
10109 c      s2d=0.0d0
10110 c      s8d=0.0d0
10111 c      s12d=0.0d0
10112 c      s13d=0.0d0
10113 #ifdef MOMENT
10114       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10115      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10116 #else
10117       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10118      &               -0.5d0*ekont*(s2d+s12d)
10119 #endif
10120 C Derivatives in gamma(i+4)
10121       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10122       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10123       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10124 #ifdef MOMENT
10125       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10126       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10127       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10128 #endif
10129 c      s1d=0.0d0
10130 c      s2d=0.0d0
10131 c      s8d=0.0d0
10132 C      s12d=0.0d0
10133 c      s13d=0.0d0
10134 #ifdef MOMENT
10135       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10136 #else
10137       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10138 #endif
10139 C Derivatives in gamma(i+5)
10140 #ifdef MOMENT
10141       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10142       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10143       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10144 #endif
10145       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10146       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10147       s2d = scalar2(b1(1,k),vtemp1d(1))
10148 #ifdef MOMENT
10149       call transpose2(AEA(1,1,2),atempd(1,1))
10150       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10151       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10152 #endif
10153       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10154       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10155 #ifdef MOMENT
10156       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10157       ss13d = scalar2(b1(1,k),vtemp4d(1))
10158       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10159 #endif
10160 c      s1d=0.0d0
10161 c      s2d=0.0d0
10162 c      s8d=0.0d0
10163 c      s12d=0.0d0
10164 c      s13d=0.0d0
10165 #ifdef MOMENT
10166       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10167      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10168 #else
10169       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10170      &               -0.5d0*ekont*(s2d+s12d)
10171 #endif
10172 C Cartesian derivatives
10173       do iii=1,2
10174         do kkk=1,5
10175           do lll=1,3
10176 #ifdef MOMENT
10177             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10178             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10179             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10180 #endif
10181             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10182             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10183      &          vtemp1d(1))
10184             s2d = scalar2(b1(1,k),vtemp1d(1))
10185 #ifdef MOMENT
10186             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10187             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10188             s8d = -(atempd(1,1)+atempd(2,2))*
10189      &           scalar2(cc(1,1,itl),vtemp2(1))
10190 #endif
10191             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10192      &           auxmatd(1,1))
10193             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10194             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10195 c      s1d=0.0d0
10196 c      s2d=0.0d0
10197 c      s8d=0.0d0
10198 c      s12d=0.0d0
10199 c      s13d=0.0d0
10200 #ifdef MOMENT
10201             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10202      &        - 0.5d0*(s1d+s2d)
10203 #else
10204             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10205      &        - 0.5d0*s2d
10206 #endif
10207 #ifdef MOMENT
10208             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10209      &        - 0.5d0*(s8d+s12d)
10210 #else
10211             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10212      &        - 0.5d0*s12d
10213 #endif
10214           enddo
10215         enddo
10216       enddo
10217 #ifdef MOMENT
10218       do kkk=1,5
10219         do lll=1,3
10220           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10221      &      achuj_tempd(1,1))
10222           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10223           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10224           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10225           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10226           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10227      &      vtemp4d(1))
10228           ss13d = scalar2(b1(1,k),vtemp4d(1))
10229           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10230           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10231         enddo
10232       enddo
10233 #endif
10234 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10235 cd     &  16*eel_turn6_num
10236 cd      goto 1112
10237       if (j.lt.nres-1) then
10238         j1=j+1
10239         j2=j-1
10240       else
10241         j1=j-1
10242         j2=j-2
10243       endif
10244       if (l.lt.nres-1) then
10245         l1=l+1
10246         l2=l-1
10247       else
10248         l1=l-1
10249         l2=l-2
10250       endif
10251       do ll=1,3
10252 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10253 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10254 cgrad        ghalf=0.5d0*ggg1(ll)
10255 cd        ghalf=0.0d0
10256         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10257         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10258         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10259      &    +ekont*derx_turn(ll,2,1)
10260         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10261         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10262      &    +ekont*derx_turn(ll,4,1)
10263         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10264         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10265         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10266 cgrad        ghalf=0.5d0*ggg2(ll)
10267 cd        ghalf=0.0d0
10268         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10269      &    +ekont*derx_turn(ll,2,2)
10270         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10271         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10272      &    +ekont*derx_turn(ll,4,2)
10273         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10274         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10275         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10276       enddo
10277 cd      goto 1112
10278 cgrad      do m=i+1,j-1
10279 cgrad        do ll=1,3
10280 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10281 cgrad        enddo
10282 cgrad      enddo
10283 cgrad      do m=k+1,l-1
10284 cgrad        do ll=1,3
10285 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10286 cgrad        enddo
10287 cgrad      enddo
10288 cgrad1112  continue
10289 cgrad      do m=i+2,j2
10290 cgrad        do ll=1,3
10291 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10292 cgrad        enddo
10293 cgrad      enddo
10294 cgrad      do m=k+2,l2
10295 cgrad        do ll=1,3
10296 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10297 cgrad        enddo
10298 cgrad      enddo
10299 cd      do iii=1,nres-3
10300 cd        write (2,*) iii,g_corr6_loc(iii)
10301 cd      enddo
10302       eello_turn6=ekont*eel_turn6
10303 cd      write (2,*) 'ekont',ekont
10304 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10305       return
10306       end
10307
10308 C-----------------------------------------------------------------------------
10309       double precision function scalar(u,v)
10310 !DIR$ INLINEALWAYS scalar
10311 #ifndef OSF
10312 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10313 #endif
10314       implicit none
10315       double precision u(3),v(3)
10316 cd      double precision sc
10317 cd      integer i
10318 cd      sc=0.0d0
10319 cd      do i=1,3
10320 cd        sc=sc+u(i)*v(i)
10321 cd      enddo
10322 cd      scalar=sc
10323
10324       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10325       return
10326       end
10327 crc-------------------------------------------------
10328       SUBROUTINE MATVEC2(A1,V1,V2)
10329 !DIR$ INLINEALWAYS MATVEC2
10330 #ifndef OSF
10331 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10332 #endif
10333       implicit real*8 (a-h,o-z)
10334       include 'DIMENSIONS'
10335       DIMENSION A1(2,2),V1(2),V2(2)
10336 c      DO 1 I=1,2
10337 c        VI=0.0
10338 c        DO 3 K=1,2
10339 c    3     VI=VI+A1(I,K)*V1(K)
10340 c        Vaux(I)=VI
10341 c    1 CONTINUE
10342
10343       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10344       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10345
10346       v2(1)=vaux1
10347       v2(2)=vaux2
10348       END
10349 C---------------------------------------
10350       SUBROUTINE MATMAT2(A1,A2,A3)
10351 #ifndef OSF
10352 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10353 #endif
10354       implicit real*8 (a-h,o-z)
10355       include 'DIMENSIONS'
10356       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10357 c      DIMENSION AI3(2,2)
10358 c        DO  J=1,2
10359 c          A3IJ=0.0
10360 c          DO K=1,2
10361 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10362 c          enddo
10363 c          A3(I,J)=A3IJ
10364 c       enddo
10365 c      enddo
10366
10367       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10368       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10369       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10370       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10371
10372       A3(1,1)=AI3_11
10373       A3(2,1)=AI3_21
10374       A3(1,2)=AI3_12
10375       A3(2,2)=AI3_22
10376       END
10377
10378 c-------------------------------------------------------------------------
10379       double precision function scalar2(u,v)
10380 !DIR$ INLINEALWAYS scalar2
10381       implicit none
10382       double precision u(2),v(2)
10383       double precision sc
10384       integer i
10385       scalar2=u(1)*v(1)+u(2)*v(2)
10386       return
10387       end
10388
10389 C-----------------------------------------------------------------------------
10390
10391       subroutine transpose2(a,at)
10392 !DIR$ INLINEALWAYS transpose2
10393 #ifndef OSF
10394 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10395 #endif
10396       implicit none
10397       double precision a(2,2),at(2,2)
10398       at(1,1)=a(1,1)
10399       at(1,2)=a(2,1)
10400       at(2,1)=a(1,2)
10401       at(2,2)=a(2,2)
10402       return
10403       end
10404 c--------------------------------------------------------------------------
10405       subroutine transpose(n,a,at)
10406       implicit none
10407       integer n,i,j
10408       double precision a(n,n),at(n,n)
10409       do i=1,n
10410         do j=1,n
10411           at(j,i)=a(i,j)
10412         enddo
10413       enddo
10414       return
10415       end
10416 C---------------------------------------------------------------------------
10417       subroutine prodmat3(a1,a2,kk,transp,prod)
10418 !DIR$ INLINEALWAYS prodmat3
10419 #ifndef OSF
10420 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10421 #endif
10422       implicit none
10423       integer i,j
10424       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10425       logical transp
10426 crc      double precision auxmat(2,2),prod_(2,2)
10427
10428       if (transp) then
10429 crc        call transpose2(kk(1,1),auxmat(1,1))
10430 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10431 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10432
10433            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10434      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10435            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10436      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10437            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10438      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10439            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10440      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10441
10442       else
10443 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10444 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10445
10446            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10447      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10448            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10449      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10450            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10451      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10452            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10453      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10454
10455       endif
10456 c      call transpose2(a2(1,1),a2t(1,1))
10457
10458 crc      print *,transp
10459 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10460 crc      print *,((prod(i,j),i=1,2),j=1,2)
10461
10462       return
10463       end
10464 CCC----------------------------------------------
10465       subroutine Eliptransfer(eliptran)
10466       implicit real*8 (a-h,o-z)
10467       include 'DIMENSIONS'
10468       include 'COMMON.GEO'
10469       include 'COMMON.VAR'
10470       include 'COMMON.LOCAL'
10471       include 'COMMON.CHAIN'
10472       include 'COMMON.DERIV'
10473       include 'COMMON.NAMES'
10474       include 'COMMON.INTERACT'
10475       include 'COMMON.IOUNITS'
10476       include 'COMMON.CALC'
10477       include 'COMMON.CONTROL'
10478       include 'COMMON.SPLITELE'
10479       include 'COMMON.SBRIDGE'
10480 C this is done by Adasko
10481 C      print *,"wchodze"
10482 C structure of box:
10483 C      water
10484 C--bordliptop-- buffore starts
10485 C--bufliptop--- here true lipid starts
10486 C      lipid
10487 C--buflipbot--- lipid ends buffore starts
10488 C--bordlipbot--buffore ends
10489       eliptran=0.0
10490       do i=ilip_start,ilip_end
10491 C       do i=1,1
10492         if (itype(i).eq.ntyp1) cycle
10493
10494         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10495         if (positi.le.0) positi=positi+boxzsize
10496 C        print *,i
10497 C first for peptide groups
10498 c for each residue check if it is in lipid or lipid water border area
10499        if ((positi.gt.bordlipbot)
10500      &.and.(positi.lt.bordliptop)) then
10501 C the energy transfer exist
10502         if (positi.lt.buflipbot) then
10503 C what fraction I am in
10504          fracinbuf=1.0d0-
10505      &        ((positi-bordlipbot)/lipbufthick)
10506 C lipbufthick is thickenes of lipid buffore
10507          sslip=sscalelip(fracinbuf)
10508          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10509          eliptran=eliptran+sslip*pepliptran
10510          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10511          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10512 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10513
10514 C        print *,"doing sccale for lower part"
10515 C         print *,i,sslip,fracinbuf,ssgradlip
10516         elseif (positi.gt.bufliptop) then
10517          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10518          sslip=sscalelip(fracinbuf)
10519          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10520          eliptran=eliptran+sslip*pepliptran
10521          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10522          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10523 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10524 C          print *, "doing sscalefor top part"
10525 C         print *,i,sslip,fracinbuf,ssgradlip
10526         else
10527          eliptran=eliptran+pepliptran
10528 C         print *,"I am in true lipid"
10529         endif
10530 C       else
10531 C       eliptran=elpitran+0.0 ! I am in water
10532        endif
10533        enddo
10534 C       print *, "nic nie bylo w lipidzie?"
10535 C now multiply all by the peptide group transfer factor
10536 C       eliptran=eliptran*pepliptran
10537 C now the same for side chains
10538 CV       do i=1,1
10539        do i=ilip_start,ilip_end
10540         if (itype(i).eq.ntyp1) cycle
10541         positi=(mod(c(3,i+nres),boxzsize))
10542         if (positi.le.0) positi=positi+boxzsize
10543 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10544 c for each residue check if it is in lipid or lipid water border area
10545 C       respos=mod(c(3,i+nres),boxzsize)
10546 C       print *,positi,bordlipbot,buflipbot
10547        if ((positi.gt.bordlipbot)
10548      & .and.(positi.lt.bordliptop)) then
10549 C the energy transfer exist
10550         if (positi.lt.buflipbot) then
10551          fracinbuf=1.0d0-
10552      &     ((positi-bordlipbot)/lipbufthick)
10553 C lipbufthick is thickenes of lipid buffore
10554          sslip=sscalelip(fracinbuf)
10555          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10556          eliptran=eliptran+sslip*liptranene(itype(i))
10557          gliptranx(3,i)=gliptranx(3,i)
10558      &+ssgradlip*liptranene(itype(i))
10559          gliptranc(3,i-1)= gliptranc(3,i-1)
10560      &+ssgradlip*liptranene(itype(i))
10561 C         print *,"doing sccale for lower part"
10562         elseif (positi.gt.bufliptop) then
10563          fracinbuf=1.0d0-
10564      &((bordliptop-positi)/lipbufthick)
10565          sslip=sscalelip(fracinbuf)
10566          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10567          eliptran=eliptran+sslip*liptranene(itype(i))
10568          gliptranx(3,i)=gliptranx(3,i)
10569      &+ssgradlip*liptranene(itype(i))
10570          gliptranc(3,i-1)= gliptranc(3,i-1)
10571      &+ssgradlip*liptranene(itype(i))
10572 C          print *, "doing sscalefor top part",sslip,fracinbuf
10573         else
10574          eliptran=eliptran+liptranene(itype(i))
10575 C         print *,"I am in true lipid"
10576         endif
10577         endif ! if in lipid or buffor
10578 C       else
10579 C       eliptran=elpitran+0.0 ! I am in water
10580        enddo
10581        return
10582        end
10583 C---------------------------------------------------------
10584 C AFM soubroutine for constant force
10585        subroutine AFMforce(Eafmforce)
10586        implicit real*8 (a-h,o-z)
10587       include 'DIMENSIONS'
10588       include 'COMMON.GEO'
10589       include 'COMMON.VAR'
10590       include 'COMMON.LOCAL'
10591       include 'COMMON.CHAIN'
10592       include 'COMMON.DERIV'
10593       include 'COMMON.NAMES'
10594       include 'COMMON.INTERACT'
10595       include 'COMMON.IOUNITS'
10596       include 'COMMON.CALC'
10597       include 'COMMON.CONTROL'
10598       include 'COMMON.SPLITELE'
10599       include 'COMMON.SBRIDGE'
10600       real*8 diffafm(3)
10601       dist=0.0d0
10602       Eafmforce=0.0d0
10603       do i=1,3
10604       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10605       dist=dist+diffafm(i)**2
10606       enddo
10607       dist=dsqrt(dist)
10608       Eafmforce=-forceAFMconst*(dist-distafminit)
10609       do i=1,3
10610       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10611       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10612       enddo
10613 C      print *,'AFM',Eafmforce
10614       return
10615       end
10616 C---------------------------------------------------------
10617 C AFM subroutine with pseudoconstant velocity
10618        subroutine AFMvel(Eafmforce)
10619        implicit real*8 (a-h,o-z)
10620       include 'DIMENSIONS'
10621       include 'COMMON.GEO'
10622       include 'COMMON.VAR'
10623       include 'COMMON.LOCAL'
10624       include 'COMMON.CHAIN'
10625       include 'COMMON.DERIV'
10626       include 'COMMON.NAMES'
10627       include 'COMMON.INTERACT'
10628       include 'COMMON.IOUNITS'
10629       include 'COMMON.CALC'
10630       include 'COMMON.CONTROL'
10631       include 'COMMON.SPLITELE'
10632       include 'COMMON.SBRIDGE'
10633       real*8 diffafm(3)
10634 C Only for check grad COMMENT if not used for checkgrad
10635 C      totT=3.0d0
10636 C--------------------------------------------------------
10637 C      print *,"wchodze"
10638       dist=0.0d0
10639       Eafmforce=0.0d0
10640       do i=1,3
10641       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10642       dist=dist+diffafm(i)**2
10643       enddo
10644       dist=dsqrt(dist)
10645       Eafmforce=0.5d0*forceAFMconst
10646      & *(distafminit+totTafm*velAFMconst-dist)**2
10647 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10648       do i=1,3
10649       gradafm(i,afmend-1)=-forceAFMconst*
10650      &(distafminit+totTafm*velAFMconst-dist)
10651      &*diffafm(i)/dist
10652       gradafm(i,afmbeg-1)=forceAFMconst*
10653      &(distafminit+totTafm*velAFMconst-dist)
10654      &*diffafm(i)/dist
10655       enddo
10656 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10657       return
10658       end
10659 C-----------------------------------------------------------
10660 C first for shielding is setting of function of side-chains
10661        subroutine set_shield_fac
10662       implicit real*8 (a-h,o-z)
10663       include 'DIMENSIONS'
10664       include 'COMMON.CHAIN'
10665       include 'COMMON.DERIV'
10666       include 'COMMON.IOUNITS'
10667       include 'COMMON.SHIELD'
10668       include 'COMMON.INTERACT'
10669 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10670       double precision div77_81/0.974996043d0/,
10671      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10672
10673 C the vector between center of side_chain and peptide group
10674        double precision pep_side(3),long,side_calf(3),
10675      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10676      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10677 C the line belowe needs to be changed for FGPROC>1
10678       do i=1,nres-1
10679       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10680       ishield_list(i)=0
10681 Cif there two consequtive dummy atoms there is no peptide group between them
10682 C the line below has to be changed for FGPROC>1
10683       VolumeTotal=0.0
10684       do k=1,nres
10685        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10686        dist_pep_side=0.0
10687        dist_side_calf=0.0
10688        do j=1,3
10689 C first lets set vector conecting the ithe side-chain with kth side-chain
10690       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10691 C      pep_side(j)=2.0d0
10692 C and vector conecting the side-chain with its proper calfa
10693       side_calf(j)=c(j,k+nres)-c(j,k)
10694 C      side_calf(j)=2.0d0
10695       pept_group(j)=c(j,i)-c(j,i+1)
10696 C lets have their lenght
10697       dist_pep_side=pep_side(j)**2+dist_pep_side
10698       dist_side_calf=dist_side_calf+side_calf(j)**2
10699       dist_pept_group=dist_pept_group+pept_group(j)**2
10700       enddo
10701        dist_pep_side=dsqrt(dist_pep_side)
10702        dist_pept_group=dsqrt(dist_pept_group)
10703        dist_side_calf=dsqrt(dist_side_calf)
10704       do j=1,3
10705         pep_side_norm(j)=pep_side(j)/dist_pep_side
10706         side_calf_norm(j)=dist_side_calf
10707       enddo
10708 C now sscale fraction
10709        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10710 C       print *,buff_shield,"buff"
10711 C now sscale
10712         if (sh_frac_dist.le.0.0) cycle
10713 C If we reach here it means that this side chain reaches the shielding sphere
10714 C Lets add him to the list for gradient
10715         ishield_list(i)=ishield_list(i)+1
10716 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10717 C this list is essential otherwise problem would be O3
10718         shield_list(ishield_list(i),i)=k
10719 C Lets have the sscale value
10720         if (sh_frac_dist.gt.1.0) then
10721          scale_fac_dist=1.0d0
10722          do j=1,3
10723          sh_frac_dist_grad(j)=0.0d0
10724          enddo
10725         else
10726          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10727      &                   *(2.0*sh_frac_dist-3.0d0)
10728          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10729      &                  /dist_pep_side/buff_shield*0.5
10730 C remember for the final gradient multiply sh_frac_dist_grad(j)
10731 C for side_chain by factor -2 !
10732          do j=1,3
10733          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10734 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10735 C     &                    sh_frac_dist_grad(j)
10736          enddo
10737         endif
10738 C        if ((i.eq.3).and.(k.eq.2)) then
10739 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10740 C     & ,"TU"
10741 C        endif
10742
10743 C this is what is now we have the distance scaling now volume...
10744       short=short_r_sidechain(itype(k))
10745       long=long_r_sidechain(itype(k))
10746       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10747 C now costhet_grad
10748 C       costhet=0.0d0
10749        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10750 C       costhet_fac=0.0d0
10751        do j=1,3
10752          costhet_grad(j)=costhet_fac*pep_side(j)
10753        enddo
10754 C remember for the final gradient multiply costhet_grad(j)
10755 C for side_chain by factor -2 !
10756 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10757 C pep_side0pept_group is vector multiplication
10758       pep_side0pept_group=0.0
10759       do j=1,3
10760       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10761       enddo
10762       cosalfa=(pep_side0pept_group/
10763      & (dist_pep_side*dist_side_calf))
10764       fac_alfa_sin=1.0-cosalfa**2
10765       fac_alfa_sin=dsqrt(fac_alfa_sin)
10766       rkprim=fac_alfa_sin*(long-short)+short
10767 C now costhet_grad
10768        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10769        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10770
10771        do j=1,3
10772          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10773      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10774      &*(long-short)/fac_alfa_sin*cosalfa/
10775      &((dist_pep_side*dist_side_calf))*
10776      &((side_calf(j))-cosalfa*
10777      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10778
10779         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10780      &*(long-short)/fac_alfa_sin*cosalfa
10781      &/((dist_pep_side*dist_side_calf))*
10782      &(pep_side(j)-
10783      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10784        enddo
10785
10786       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10787      &                    /VSolvSphere_div
10788 C now the gradient...
10789 C grad_shield is gradient of Calfa for peptide groups
10790       do j=1,3
10791       grad_shield(j,i)=grad_shield(j,i)
10792 C gradient po skalowaniu
10793      &                +(sh_frac_dist_grad(j)
10794 C  gradient po costhet
10795      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10796      &-scale_fac_dist*(cosphi_grad_long(j))
10797      &/(1.0-cosphi) )*div77_81
10798      &*VofOverlap
10799 C grad_shield_side is Cbeta sidechain gradient
10800       grad_shield_side(j,ishield_list(i),i)=
10801      &        (sh_frac_dist_grad(j)*-2.0d0
10802      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10803      &       +scale_fac_dist*(cosphi_grad_long(j))
10804      &        *2.0d0/(1.0-cosphi))
10805      &        *div77_81*VofOverlap
10806
10807        grad_shield_loc(j,ishield_list(i),i)=
10808      &   scale_fac_dist*cosphi_grad_loc(j)
10809      &        *2.0d0/(1.0-cosphi)
10810      &        *div77_81*VofOverlap
10811       enddo
10812       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10813       enddo
10814       fac_shield(i)=VolumeTotal*div77_81+div4_81
10815 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10816       enddo
10817       return
10818       end
10819