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      print *,"Processor",myrank," left VEC_AND_DERIV"
 141       if (ipot.lt.6) then
 142 #ifdef SPLITELE
 143          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 144      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 145      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 146      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 147 #else
 148          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 149      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 150      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 151      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 152 #endif
 153             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 154          else
 155             ees=0.0d0
 156             evdw1=0.0d0
 157             eel_loc=0.0d0
 158             eello_turn3=0.0d0
 159             eello_turn4=0.0d0
 160          endif
 161       else
 162         write (iout,*) "Soft-spheer ELEC potential"
 163 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164 c     &   eello_turn4)
 165       endif
 166 c      print *,"Processor",myrank," computed UELEC"
 167 C
 168 C Calculate excluded-volume interaction energy between peptide groups
 169 C and side chains.
 170 C
 171       if (ipot.lt.6) then
 172        if(wscp.gt.0d0) then
 173         call escp(evdw2,evdw2_14)
 174        else
 175         evdw2=0
 176         evdw2_14=0
 177        endif
 178       else
 179 c        write (iout,*) "Soft-sphere SCP potential"
 180         call escp_soft_sphere(evdw2,evdw2_14)
 181       endif
 182 c
 183 c Calculate the bond-stretching energy
 184 c
 185       call ebond(estr)
 186 C
 187 C Calculate the disulfide-bridge and other energy and the contributions
 188 C from other distance constraints.
 189 cd    print *,'Calling EHPB'
 190       call edis(ehpb)
 191 cd    print *,'EHPB exitted succesfully.'
 192 C
 193 C Calculate the virtual-bond-angle energy.
 194 C
 195       if (wang.gt.0d0) then
 196         call ebend(ebe)
 197       else
 198         ebe=0
 199       endif
 200 c      print *,"Processor",myrank," computed UB"
 201 C
 202 C Calculate the SC local energy.
 203 C
 204 C      print *,"TU DOCHODZE?"
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utor"
 218 C
 219 C 6/23/01 Calculate double-torsional energy
 220 C
 221       if (wtor_d.gt.0) then
 222        call etor_d(etors_d)
 223       else
 224        etors_d=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utord"
 227 C
 228 C 21/5/07 Calculate local sicdechain correlation energy
 229 C
 230       if (wsccor.gt.0.0d0) then
 231         call eback_sc_corr(esccor)
 232       else
 233         esccor=0.0d0
 234       endif
 235 C      print *,"PRZED MULIt"
 236 c      print *,"Processor",myrank," computed Usccorr"
 237 C
 238 C 12/1/95 Multi-body terms
 239 C
 240       n_corr=0
 241       n_corr1=0
 242       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 243      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 245 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 246 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 247       else
 248          ecorr=0.0d0
 249          ecorr5=0.0d0
 250          ecorr6=0.0d0
 251          eturn6=0.0d0
 252       endif
 253       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 254          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 255 cd         write (iout,*) "multibody_hb ecorr",ecorr
 256       endif
 257 c      print *,"Processor",myrank," computed Ucorr"
 258 C
 259 C If performing constraint dynamics, call the constraint energy
 260 C  after the equilibration time
 261       if(usampl.and.totT.gt.eq_time) then
 262          call EconstrQ
 263          call Econstr_back
 264       else
 265          Uconst=0.0d0
 266          Uconst_back=0.0d0
 267       endif
 268 C 01/27/2015 added by adasko
 269 C the energy component below is energy transfer into lipid environment
 270 C based on partition function
 271 C      print *,"przed lipidami"
 272       if (wliptran.gt.0) then
 273         call Eliptransfer(eliptran)
 274       endif
 275 C      print *,"za lipidami"
 276 #ifdef TIMING
 277       time_enecalc=time_enecalc+MPI_Wtime()-time00
 278 #endif
 279 c      print *,"Processor",myrank," computed Uconstr"
 280 #ifdef TIMING
 281       time00=MPI_Wtime()
 282 #endif
 283 c
 284 C Sum the energies
 285 C
 286       energia(1)=evdw
 287 #ifdef SCP14
 288       energia(2)=evdw2-evdw2_14
 289       energia(18)=evdw2_14
 290 #else
 291       energia(2)=evdw2
 292       energia(18)=0.0d0
 293 #endif
 294 #ifdef SPLITELE
 295       energia(3)=ees
 296       energia(16)=evdw1
 297 #else
 298       energia(3)=ees+evdw1
 299       energia(16)=0.0d0
 300 #endif
 301       energia(4)=ecorr
 302       energia(5)=ecorr5
 303       energia(6)=ecorr6
 304       energia(7)=eel_loc
 305       energia(8)=eello_turn3
 306       energia(9)=eello_turn4
 307       energia(10)=eturn6
 308       energia(11)=ebe
 309       energia(12)=escloc
 310       energia(13)=etors
 311       energia(14)=etors_d
 312       energia(15)=ehpb
 313       energia(19)=edihcnstr
 314       energia(17)=estr
 315       energia(20)=Uconst+Uconst_back
 316       energia(21)=esccor
 317       energia(22)=eliptran
 318 c    Here are the energies showed per procesor if the are more processors
 319 c    per molecule then we sum it up in sum_energy subroutine
 320 c      print *," Processor",myrank," calls SUM_ENERGY"
 321       call sum_energy(energia,.true.)
 322       if (dyn_ss) call dyn_set_nss
 323 c      print *," Processor",myrank," left SUM_ENERGY"
 324 #ifdef TIMING
 325       time_sumene=time_sumene+MPI_Wtime()-time00
 326 #endif
 327       return
 328       end
 329 c-------------------------------------------------------------------------------
 330       subroutine sum_energy(energia,reduce)
 331       implicit real*8 (a-h,o-z)
 332       include 'DIMENSIONS'
 333 #ifndef ISNAN
 334       external proc_proc
 335 #ifdef WINPGI
 336 cMS$ATTRIBUTES C ::  proc_proc
 337 #endif
 338 #endif
 339 #ifdef MPI
 340       include "mpif.h"
 341 #endif
 342       include 'COMMON.SETUP'
 343       include 'COMMON.IOUNITS'
 344       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 345       include 'COMMON.FFIELD'
 346       include 'COMMON.DERIV'
 347       include 'COMMON.INTERACT'
 348       include 'COMMON.SBRIDGE'
 349       include 'COMMON.CHAIN'
 350       include 'COMMON.VAR'
 351       include 'COMMON.CONTROL'
 352       include 'COMMON.TIME1'
 353       logical reduce
 354 #ifdef MPI
 355       if (nfgtasks.gt.1 .and. reduce) then
 356 #ifdef DEBUG
 357         write (iout,*) "energies before REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         do i=0,n_ene
 362           enebuff(i)=energia(i)
 363         enddo
 364         time00=MPI_Wtime()
 365         call MPI_Barrier(FG_COMM,IERR)
 366         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 367         time00=MPI_Wtime()
 368         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 369      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 370 #ifdef DEBUG
 371         write (iout,*) "energies after REDUCE"
 372         call enerprint(energia)
 373         call flush(iout)
 374 #endif
 375         time_Reduce=time_Reduce+MPI_Wtime()-time00
 376       endif
 377       if (fg_rank.eq.0) then
 378 #endif
 379       evdw=energia(1)
 380 #ifdef SCP14
 381       evdw2=energia(2)+energia(18)
 382       evdw2_14=energia(18)
 383 #else
 384       evdw2=energia(2)
 385 #endif
 386 #ifdef SPLITELE
 387       ees=energia(3)
 388       evdw1=energia(16)
 389 #else
 390       ees=energia(3)
 391       evdw1=0.0d0
 392 #endif
 393       ecorr=energia(4)
 394       ecorr5=energia(5)
 395       ecorr6=energia(6)
 396       eel_loc=energia(7)
 397       eello_turn3=energia(8)
 398       eello_turn4=energia(9)
 399       eturn6=energia(10)
 400       ebe=energia(11)
 401       escloc=energia(12)
 402       etors=energia(13)
 403       etors_d=energia(14)
 404       ehpb=energia(15)
 405       edihcnstr=energia(19)
 406       estr=energia(17)
 407       Uconst=energia(20)
 408       esccor=energia(21)
 409       eliptran=energia(22)
 410 #ifdef SPLITELE
 411       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 412      & +wang*ebe+wtor*etors+wscloc*escloc
 413      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 414      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 415      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 416      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 417 #else
 418       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 419      & +wang*ebe+wtor*etors+wscloc*escloc
 420      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 421      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 422      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 423      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 424 #endif
 425       energia(0)=etot
 426 c detecting NaNQ
 427 #ifdef ISNAN
 428 #ifdef AIX
 429       if (isnan(etot).ne.0) energia(0)=1.0d+99
 430 #else
 431       if (isnan(etot)) energia(0)=1.0d+99
 432 #endif
 433 #else
 434       i=0
 435 #ifdef WINPGI
 436       idumm=proc_proc(etot,i)
 437 #else
 438       call proc_proc(etot,i)
 439 #endif
 440       if(i.eq.1)energia(0)=1.0d+99
 441 #endif
 442 #ifdef MPI
 443       endif
 444 #endif
 445       return
 446       end
 447 c-------------------------------------------------------------------------------
 448       subroutine sum_gradient
 449       implicit real*8 (a-h,o-z)
 450       include 'DIMENSIONS'
 451 #ifndef ISNAN
 452       external proc_proc
 453 #ifdef WINPGI
 454 cMS$ATTRIBUTES C ::  proc_proc
 455 #endif
 456 #endif
 457 #ifdef MPI
 458       include 'mpif.h'
 459 #endif
 460       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 461      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 462      & ,gloc_scbuf(3,-1:maxres)
 463       include 'COMMON.SETUP'
 464       include 'COMMON.IOUNITS'
 465       include 'COMMON.FFIELD'
 466       include 'COMMON.DERIV'
 467       include 'COMMON.INTERACT'
 468       include 'COMMON.SBRIDGE'
 469       include 'COMMON.CHAIN'
 470       include 'COMMON.VAR'
 471       include 'COMMON.CONTROL'
 472       include 'COMMON.TIME1'
 473       include 'COMMON.MAXGRAD'
 474       include 'COMMON.SCCOR'
 475 #ifdef TIMING
 476       time01=MPI_Wtime()
 477 #endif
 478 #ifdef DEBUG
 479       write (iout,*) "sum_gradient gvdwc, gvdwx"
 480       do i=1,nres
 481         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 482      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 483       enddo
 484       call flush(iout)
 485 #endif
 486 #ifdef MPI
 487 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 488         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 489      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 490 #endif
 491 C
 492 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 493 C            in virtual-bond-vector coordinates
 494 C
 495 #ifdef DEBUG
 496 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 497 c      do i=1,nres-1
 498 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 499 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 500 c      enddo
 501 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 502 c      do i=1,nres-1
 503 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 504 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 505 c      enddo
 506       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 507       do i=1,nres
 508         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 509      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 510      &   g_corr5_loc(i)
 511       enddo
 512       call flush(iout)
 513 #endif
 514 #ifdef SPLITELE
 515       do i=0,nct
 516         do j=1,3
 517           gradbufc(j,i)=wsc*gvdwc(j,i)+
 518      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 519      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526      &                +wliptran*gliptranc(j,i)
 527
 528         enddo
 529       enddo
 530 #else
 531       do i=0,nct
 532         do j=1,3
 533           gradbufc(j,i)=wsc*gvdwc(j,i)+
 534      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 535      &                welec*gelc_long(j,i)+
 536      &                wbond*gradb(j,i)+
 537      &                wel_loc*gel_loc_long(j,i)+
 538      &                wcorr*gradcorr_long(j,i)+
 539      &                wcorr5*gradcorr5_long(j,i)+
 540      &                wcorr6*gradcorr6_long(j,i)+
 541      &                wturn6*gcorr6_turn_long(j,i)+
 542      &                wstrain*ghpbc(j,i)
 543      &                +wliptran*gliptranc(j,i)
 544         enddo
 545       enddo
 546 #endif
 547 #ifdef MPI
 548       if (nfgtasks.gt.1) then
 549       time00=MPI_Wtime()
 550 #ifdef DEBUG
 551       write (iout,*) "gradbufc before allreduce"
 552       do i=1,nres
 553         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 554       enddo
 555       call flush(iout)
 556 #endif
 557       do i=0,nres
 558         do j=1,3
 559           gradbufc_sum(j,i)=gradbufc(j,i)
 560         enddo
 561       enddo
 562 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 563 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 564 c      time_reduce=time_reduce+MPI_Wtime()-time00
 565 #ifdef DEBUG
 566 c      write (iout,*) "gradbufc_sum after allreduce"
 567 c      do i=1,nres
 568 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 569 c      enddo
 570 c      call flush(iout)
 571 #endif
 572 #ifdef TIMING
 573 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 574 #endif
 575       do i=nnt,nres
 576         do k=1,3
 577           gradbufc(k,i)=0.0d0
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 582       write (iout,*) (i," jgrad_start",jgrad_start(i),
 583      &                  " jgrad_end  ",jgrad_end(i),
 584      &                  i=igrad_start,igrad_end)
 585 #endif
 586 c
 587 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 588 c do not parallelize this part.
 589 c
 590 c      do i=igrad_start,igrad_end
 591 c        do j=jgrad_start(i),jgrad_end(i)
 592 c          do k=1,3
 593 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 594 c          enddo
 595 c        enddo
 596 c      enddo
 597       do j=1,3
 598         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 599       enddo
 600       do i=nres-2,-1,-1
 601         do j=1,3
 602           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 603         enddo
 604       enddo
 605 #ifdef DEBUG
 606       write (iout,*) "gradbufc after summing"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612       else
 613 #endif
 614 #ifdef DEBUG
 615       write (iout,*) "gradbufc"
 616       do i=1,nres
 617         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 618       enddo
 619       call flush(iout)
 620 #endif
 621       do i=-1,nres
 622         do j=1,3
 623           gradbufc_sum(j,i)=gradbufc(j,i)
 624           gradbufc(j,i)=0.0d0
 625         enddo
 626       enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,-1,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 c      do i=nnt,nres-1
 636 c        do k=1,3
 637 c          gradbufc(k,i)=0.0d0
 638 c        enddo
 639 c        do j=i+1,nres
 640 c          do k=1,3
 641 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 642 c          enddo
 643 c        enddo
 644 c      enddo
 645 #ifdef DEBUG
 646       write (iout,*) "gradbufc after summing"
 647       do i=1,nres
 648         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 649       enddo
 650       call flush(iout)
 651 #endif
 652 #ifdef MPI
 653       endif
 654 #endif
 655       do k=1,3
 656         gradbufc(k,nres)=0.0d0
 657       enddo
 658       do i=-1,nct
 659         do j=1,3
 660 #ifdef SPLITELE
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gradcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679      &               +wliptran*gliptranc(j,i)
 680 #else
 681           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 682      &                wel_loc*gel_loc(j,i)+
 683      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 684      &                welec*gelc_long(j,i)
 685      &                wel_loc*gel_loc_long(j,i)+
 686      &                wcorr*gcorr_long(j,i)+
 687      &                wcorr5*gradcorr5_long(j,i)+
 688      &                wcorr6*gradcorr6_long(j,i)+
 689      &                wturn6*gcorr6_turn_long(j,i))+
 690      &                wbond*gradb(j,i)+
 691      &                wcorr*gradcorr(j,i)+
 692      &                wturn3*gcorr3_turn(j,i)+
 693      &                wturn4*gcorr4_turn(j,i)+
 694      &                wcorr5*gradcorr5(j,i)+
 695      &                wcorr6*gradcorr6(j,i)+
 696      &                wturn6*gcorr6_turn(j,i)+
 697      &                wsccor*gsccorc(j,i)
 698      &               +wscloc*gscloc(j,i)
 699      &               +wliptran*gliptranc(j,i)
 700 #endif
 701           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 702      &                  wbond*gradbx(j,i)+
 703      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 704      &                  wsccor*gsccorx(j,i)
 705      &                 +wscloc*gsclocx(j,i)
 706      &                 +wliptran*gliptranx(j,i)
 707         enddo
 708       enddo
 709 #ifdef DEBUG
 710       write (iout,*) "gloc before adding corr"
 711       do i=1,4*nres
 712         write (iout,*) i,gloc(i,icg)
 713       enddo
 714 #endif
 715       do i=1,nres-3
 716         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 717      &   +wcorr5*g_corr5_loc(i)
 718      &   +wcorr6*g_corr6_loc(i)
 719      &   +wturn4*gel_loc_turn4(i)
 720      &   +wturn3*gel_loc_turn3(i)
 721      &   +wturn6*gel_loc_turn6(i)
 722      &   +wel_loc*gel_loc_loc(i)
 723       enddo
 724 #ifdef DEBUG
 725       write (iout,*) "gloc after adding corr"
 726       do i=1,4*nres
 727         write (iout,*) i,gloc(i,icg)
 728       enddo
 729 #endif
 730 #ifdef MPI
 731       if (nfgtasks.gt.1) then
 732         do j=1,3
 733           do i=1,nres
 734             gradbufc(j,i)=gradc(j,i,icg)
 735             gradbufx(j,i)=gradx(j,i,icg)
 736           enddo
 737         enddo
 738         do i=1,4*nres
 739           glocbuf(i)=gloc(i,icg)
 740         enddo
 741 c#define DEBUG
 742 #ifdef DEBUG
 743       write (iout,*) "gloc_sc before reduce"
 744       do i=1,nres
 745        do j=1,1
 746         write (iout,*) i,j,gloc_sc(j,i,icg)
 747        enddo
 748       enddo
 749 #endif
 750 c#undef DEBUG
 751         do i=1,nres
 752          do j=1,3
 753           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 754          enddo
 755         enddo
 756         time00=MPI_Wtime()
 757         call MPI_Barrier(FG_COMM,IERR)
 758         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 759         time00=MPI_Wtime()
 760         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 761      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 762         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 763      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 764         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 765      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 766         time_reduce=time_reduce+MPI_Wtime()-time00
 767         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 768      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 769         time_reduce=time_reduce+MPI_Wtime()-time00
 770 c#define DEBUG
 771 #ifdef DEBUG
 772       write (iout,*) "gloc_sc after reduce"
 773       do i=1,nres
 774        do j=1,1
 775         write (iout,*) i,j,gloc_sc(j,i,icg)
 776        enddo
 777       enddo
 778 #endif
 779 c#undef DEBUG
 780 #ifdef DEBUG
 781       write (iout,*) "gloc after reduce"
 782       do i=1,4*nres
 783         write (iout,*) i,gloc(i,icg)
 784       enddo
 785 #endif
 786       endif
 787 #endif
 788       if (gnorm_check) then
 789 c
 790 c Compute the maximum elements of the gradient
 791 c
 792       gvdwc_max=0.0d0
 793       gvdwc_scp_max=0.0d0
 794       gelc_max=0.0d0
 795       gvdwpp_max=0.0d0
 796       gradb_max=0.0d0
 797       ghpbc_max=0.0d0
 798       gradcorr_max=0.0d0
 799       gel_loc_max=0.0d0
 800       gcorr3_turn_max=0.0d0
 801       gcorr4_turn_max=0.0d0
 802       gradcorr5_max=0.0d0
 803       gradcorr6_max=0.0d0
 804       gcorr6_turn_max=0.0d0
 805       gsccorc_max=0.0d0
 806       gscloc_max=0.0d0
 807       gvdwx_max=0.0d0
 808       gradx_scp_max=0.0d0
 809       ghpbx_max=0.0d0
 810       gradxorr_max=0.0d0
 811       gsccorx_max=0.0d0
 812       gsclocx_max=0.0d0
 813       do i=1,nct
 814         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 815         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 816         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 817         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 818      &   gvdwc_scp_max=gvdwc_scp_norm
 819         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 820         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 821         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 822         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 823         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 824         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 825         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 826         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 827         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 828         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 829         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 830         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 831         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 832      &    gcorr3_turn(1,i)))
 833         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 834      &    gcorr3_turn_max=gcorr3_turn_norm
 835         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 836      &    gcorr4_turn(1,i)))
 837         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 838      &    gcorr4_turn_max=gcorr4_turn_norm
 839         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 840         if (gradcorr5_norm.gt.gradcorr5_max)
 841      &    gradcorr5_max=gradcorr5_norm
 842         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 843         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 844         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 845      &    gcorr6_turn(1,i)))
 846         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 847      &    gcorr6_turn_max=gcorr6_turn_norm
 848         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 849         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 850         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 851         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 852         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 853         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 854         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 855         if (gradx_scp_norm.gt.gradx_scp_max)
 856      &    gradx_scp_max=gradx_scp_norm
 857         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 858         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 859         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 860         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 861         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 862         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 863         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 864         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 865       enddo
 866       if (gradout) then
 867 #ifdef AIX
 868         open(istat,file=statname,position="append")
 869 #else
 870         open(istat,file=statname,access="append")
 871 #endif
 872         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 873      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 874      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 875      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 876      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 877      &     gsccorx_max,gsclocx_max
 878         close(istat)
 879         if (gvdwc_max.gt.1.0d4) then
 880           write (iout,*) "gvdwc gvdwx gradb gradbx"
 881           do i=nnt,nct
 882             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 883      &        gradb(j,i),gradbx(j,i),j=1,3)
 884           enddo
 885           call pdbout(0.0d0,'cipiszcze',iout)
 886           call flush(iout)
 887         endif
 888       endif
 889       endif
 890 #ifdef DEBUG
 891       write (iout,*) "gradc gradx gloc"
 892       do i=1,nres
 893         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 894      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 895       enddo
 896 #endif
 897 #ifdef TIMING
 898       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 899 #endif
 900       return
 901       end
 902 c-------------------------------------------------------------------------------
 903       subroutine rescale_weights(t_bath)
 904       implicit real*8 (a-h,o-z)
 905       include 'DIMENSIONS'
 906       include 'COMMON.IOUNITS'
 907       include 'COMMON.FFIELD'
 908       include 'COMMON.SBRIDGE'
 909       double precision kfac /2.4d0/
 910       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 911 c      facT=temp0/t_bath
 912 c      facT=2*temp0/(t_bath+temp0)
 913       if (rescale_mode.eq.0) then
 914         facT=1.0d0
 915         facT2=1.0d0
 916         facT3=1.0d0
 917         facT4=1.0d0
 918         facT5=1.0d0
 919       else if (rescale_mode.eq.1) then
 920         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 921         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 922         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 923         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 924         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 925       else if (rescale_mode.eq.2) then
 926         x=t_bath/temp0
 927         x2=x*x
 928         x3=x2*x
 929         x4=x3*x
 930         x5=x4*x
 931         facT=licznik/dlog(dexp(x)+dexp(-x))
 932         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 933         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 934         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 935         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 936       else
 937         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 938         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 939 #ifdef MPI
 940        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 941 #endif
 942        stop 555
 943       endif
 944       welec=weights(3)*fact
 945       wcorr=weights(4)*fact3
 946       wcorr5=weights(5)*fact4
 947       wcorr6=weights(6)*fact5
 948       wel_loc=weights(7)*fact2
 949       wturn3=weights(8)*fact2
 950       wturn4=weights(9)*fact3
 951       wturn6=weights(10)*fact5
 952       wtor=weights(13)*fact
 953       wtor_d=weights(14)*fact2
 954       wsccor=weights(21)*fact
 955
 956       return
 957       end
 958 C------------------------------------------------------------------------
 959       subroutine enerprint(energia)
 960       implicit real*8 (a-h,o-z)
 961       include 'DIMENSIONS'
 962       include 'COMMON.IOUNITS'
 963       include 'COMMON.FFIELD'
 964       include 'COMMON.SBRIDGE'
 965       include 'COMMON.MD'
 966       double precision energia(0:n_ene)
 967       etot=energia(0)
 968       evdw=energia(1)
 969       evdw2=energia(2)
 970 #ifdef SCP14
 971       evdw2=energia(2)+energia(18)
 972 #else
 973       evdw2=energia(2)
 974 #endif
 975       ees=energia(3)
 976 #ifdef SPLITELE
 977       evdw1=energia(16)
 978 #endif
 979       ecorr=energia(4)
 980       ecorr5=energia(5)
 981       ecorr6=energia(6)
 982       eel_loc=energia(7)
 983       eello_turn3=energia(8)
 984       eello_turn4=energia(9)
 985       eello_turn6=energia(10)
 986       ebe=energia(11)
 987       escloc=energia(12)
 988       etors=energia(13)
 989       etors_d=energia(14)
 990       ehpb=energia(15)
 991       edihcnstr=energia(19)
 992       estr=energia(17)
 993       Uconst=energia(20)
 994       esccor=energia(21)
 995       eliptran=energia(22)
 996 #ifdef SPLITELE
 997       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 998      &  estr,wbond,ebe,wang,
 999      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1000      &  ecorr,wcorr,
1001      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1002      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1003      &  edihcnstr,ebr*nss,
1004      &  Uconst,eliptran,wliptran,etot
1005    10 format (/'Virtual-chain energies:'//
1006      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1007      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1008      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1009      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1010      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1011      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1012      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1013      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1014      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1015      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1016      & ' (SS bridges & dist. cnstr.)'/
1017      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1018      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1019      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1021      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1022      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1023      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1024      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1025      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1026      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1027      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1028      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1029      & 'ETOT=  ',1pE16.6,' (total)')
1030 #else
1031       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1032      &  estr,wbond,ebe,wang,
1033      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1034      &  ecorr,wcorr,
1035      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1036      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1037      &  ebr*nss,Uconst,eliptran,wliptran,etot
1038    10 format (/'Virtual-chain energies:'//
1039      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1040      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1041      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1042      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1043      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1044      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1045      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1046      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1047      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1048      & ' (SS bridges & dist. cnstr.)'/
1049      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1050      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1051      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1052      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1053      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1054      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1055      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1056      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1057      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1058      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1059      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1060      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1061      & 'ETOT=  ',1pE16.6,' (total)')
1062 #endif
1063       return
1064       end
1065 C-----------------------------------------------------------------------
1066       subroutine elj(evdw)
1067 C
1068 C This subroutine calculates the interaction energy of nonbonded side chains
1069 C assuming the LJ potential of interaction.
1070 C
1071       implicit real*8 (a-h,o-z)
1072       include 'DIMENSIONS'
1073       parameter (accur=1.0d-10)
1074       include 'COMMON.GEO'
1075       include 'COMMON.VAR'
1076       include 'COMMON.LOCAL'
1077       include 'COMMON.CHAIN'
1078       include 'COMMON.DERIV'
1079       include 'COMMON.INTERACT'
1080       include 'COMMON.TORSION'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.NAMES'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CONTACTS'
1085       dimension gg(3)
1086 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1087       evdw=0.0D0
1088       do i=iatsc_s,iatsc_e
1089         itypi=iabs(itype(i))
1090         if (itypi.eq.ntyp1) cycle
1091         itypi1=iabs(itype(i+1))
1092         xi=c(1,nres+i)
1093         yi=c(2,nres+i)
1094         zi=c(3,nres+i)
1095 C Change 12/1/95
1096         num_conti=0
1097 C
1098 C Calculate SC interaction energy.
1099 C
1100         do iint=1,nint_gr(i)
1101 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1102 cd   &                  'iend=',iend(i,iint)
1103           do j=istart(i,iint),iend(i,iint)
1104             itypj=iabs(itype(j))
1105             if (itypj.eq.ntyp1) cycle
1106             xj=c(1,nres+j)-xi
1107             yj=c(2,nres+j)-yi
1108             zj=c(3,nres+j)-zi
1109 C Change 12/1/95 to calculate four-body interactions
1110             rij=xj*xj+yj*yj+zj*zj
1111             rrij=1.0D0/rij
1112 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1113             eps0ij=eps(itypi,itypj)
1114             fac=rrij**expon2
1115 C have you changed here?
1116             e1=fac*fac*aa
1117             e2=fac*bb
1118             evdwij=e1+e2
1119 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1120 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1121 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1122 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1123 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1124 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1125             evdw=evdw+evdwij
1126 C
1127 C Calculate the components of the gradient in DC and X
1128 C
1129             fac=-rrij*(e1+evdwij)
1130             gg(1)=xj*fac
1131             gg(2)=yj*fac
1132             gg(3)=zj*fac
1133             do k=1,3
1134               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1135               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1136               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1137               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1138             enddo
1139 cgrad            do k=i,j-1
1140 cgrad              do l=1,3
1141 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1142 cgrad              enddo
1143 cgrad            enddo
1144 C
1145 C 12/1/95, revised on 5/20/97
1146 C
1147 C Calculate the contact function. The ith column of the array JCONT will
1148 C contain the numbers of atoms that make contacts with the atom I (of numbers
1149 C greater than I). The arrays FACONT and GACONT will contain the values of
1150 C the contact function and its derivative.
1151 C
1152 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1153 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1154 C Uncomment next line, if the correlation interactions are contact function only
1155             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1156               rij=dsqrt(rij)
1157               sigij=sigma(itypi,itypj)
1158               r0ij=rs0(itypi,itypj)
1159 C
1160 C Check whether the SC's are not too far to make a contact.
1161 C
1162               rcut=1.5d0*r0ij
1163               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1164 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1165 C
1166               if (fcont.gt.0.0D0) then
1167 C If the SC-SC distance if close to sigma, apply spline.
1168 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1169 cAdam &             fcont1,fprimcont1)
1170 cAdam           fcont1=1.0d0-fcont1
1171 cAdam           if (fcont1.gt.0.0d0) then
1172 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1173 cAdam             fcont=fcont*fcont1
1174 cAdam           endif
1175 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1176 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1177 cga             do k=1,3
1178 cga               gg(k)=gg(k)*eps0ij
1179 cga             enddo
1180 cga             eps0ij=-evdwij*eps0ij
1181 C Uncomment for AL's type of SC correlation interactions.
1182 cadam           eps0ij=-evdwij
1183                 num_conti=num_conti+1
1184                 jcont(num_conti,i)=j
1185                 facont(num_conti,i)=fcont*eps0ij
1186                 fprimcont=eps0ij*fprimcont/rij
1187                 fcont=expon*fcont
1188 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1189 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1190 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1191 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1192                 gacont(1,num_conti,i)=-fprimcont*xj
1193                 gacont(2,num_conti,i)=-fprimcont*yj
1194                 gacont(3,num_conti,i)=-fprimcont*zj
1195 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1196 cd              write (iout,'(2i3,3f10.5)')
1197 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1198               endif
1199             endif
1200           enddo      ! j
1201         enddo        ! iint
1202 C Change 12/1/95
1203         num_cont(i)=num_conti
1204       enddo          ! i
1205       do i=1,nct
1206         do j=1,3
1207           gvdwc(j,i)=expon*gvdwc(j,i)
1208           gvdwx(j,i)=expon*gvdwx(j,i)
1209         enddo
1210       enddo
1211 C******************************************************************************
1212 C
1213 C                              N O T E !!!
1214 C
1215 C To save time, the factor of EXPON has been extracted from ALL components
1216 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1217 C use!
1218 C
1219 C******************************************************************************
1220       return
1221       end
1222 C-----------------------------------------------------------------------------
1223       subroutine eljk(evdw)
1224 C
1225 C This subroutine calculates the interaction energy of nonbonded side chains
1226 C assuming the LJK potential of interaction.
1227 C
1228       implicit real*8 (a-h,o-z)
1229       include 'DIMENSIONS'
1230       include 'COMMON.GEO'
1231       include 'COMMON.VAR'
1232       include 'COMMON.LOCAL'
1233       include 'COMMON.CHAIN'
1234       include 'COMMON.DERIV'
1235       include 'COMMON.INTERACT'
1236       include 'COMMON.IOUNITS'
1237       include 'COMMON.NAMES'
1238       dimension gg(3)
1239       logical scheck
1240 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1241       evdw=0.0D0
1242       do i=iatsc_s,iatsc_e
1243         itypi=iabs(itype(i))
1244         if (itypi.eq.ntyp1) cycle
1245         itypi1=iabs(itype(i+1))
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C
1250 C Calculate SC interaction energy.
1251 C
1252         do iint=1,nint_gr(i)
1253           do j=istart(i,iint),iend(i,iint)
1254             itypj=iabs(itype(j))
1255             if (itypj.eq.ntyp1) cycle
1256             xj=c(1,nres+j)-xi
1257             yj=c(2,nres+j)-yi
1258             zj=c(3,nres+j)-zi
1259             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1260             fac_augm=rrij**expon
1261             e_augm=augm(itypi,itypj)*fac_augm
1262             r_inv_ij=dsqrt(rrij)
1263             rij=1.0D0/r_inv_ij
1264             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1265             fac=r_shift_inv**expon
1266 C have you changed here?
1267             e1=fac*fac*aa
1268             e2=fac*bb
1269             evdwij=e_augm+e1+e2
1270 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1271 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1272 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1273 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1274 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1275 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277             evdw=evdw+evdwij
1278 C
1279 C Calculate the components of the gradient in DC and X
1280 C
1281             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1282             gg(1)=xj*fac
1283             gg(2)=yj*fac
1284             gg(3)=zj*fac
1285             do k=1,3
1286               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1287               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1288               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1289               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1290             enddo
1291 cgrad            do k=i,j-1
1292 cgrad              do l=1,3
1293 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1294 cgrad              enddo
1295 cgrad            enddo
1296           enddo      ! j
1297         enddo        ! iint
1298       enddo          ! i
1299       do i=1,nct
1300         do j=1,3
1301           gvdwc(j,i)=expon*gvdwc(j,i)
1302           gvdwx(j,i)=expon*gvdwx(j,i)
1303         enddo
1304       enddo
1305       return
1306       end
1307 C-----------------------------------------------------------------------------
1308       subroutine ebp(evdw)
1309 C
1310 C This subroutine calculates the interaction energy of nonbonded side chains
1311 C assuming the Berne-Pechukas potential of interaction.
1312 C
1313       implicit real*8 (a-h,o-z)
1314       include 'DIMENSIONS'
1315       include 'COMMON.GEO'
1316       include 'COMMON.VAR'
1317       include 'COMMON.LOCAL'
1318       include 'COMMON.CHAIN'
1319       include 'COMMON.DERIV'
1320       include 'COMMON.NAMES'
1321       include 'COMMON.INTERACT'
1322       include 'COMMON.IOUNITS'
1323       include 'COMMON.CALC'
1324       common /srutu/ icall
1325 c     double precision rrsave(maxdim)
1326       logical lprn
1327       evdw=0.0D0
1328 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1329       evdw=0.0D0
1330 c     if (icall.eq.0) then
1331 c       lprn=.true.
1332 c     else
1333         lprn=.false.
1334 c     endif
1335       ind=0
1336       do i=iatsc_s,iatsc_e
1337         itypi=iabs(itype(i))
1338         if (itypi.eq.ntyp1) cycle
1339         itypi1=iabs(itype(i+1))
1340         xi=c(1,nres+i)
1341         yi=c(2,nres+i)
1342         zi=c(3,nres+i)
1343         dxi=dc_norm(1,nres+i)
1344         dyi=dc_norm(2,nres+i)
1345         dzi=dc_norm(3,nres+i)
1346 c        dsci_inv=dsc_inv(itypi)
1347         dsci_inv=vbld_inv(i+nres)
1348 C
1349 C Calculate SC interaction energy.
1350 C
1351         do iint=1,nint_gr(i)
1352           do j=istart(i,iint),iend(i,iint)
1353             ind=ind+1
1354             itypj=iabs(itype(j))
1355             if (itypj.eq.ntyp1) cycle
1356 c            dscj_inv=dsc_inv(itypj)
1357             dscj_inv=vbld_inv(j+nres)
1358             chi1=chi(itypi,itypj)
1359             chi2=chi(itypj,itypi)
1360             chi12=chi1*chi2
1361             chip1=chip(itypi)
1362             chip2=chip(itypj)
1363             chip12=chip1*chip2
1364             alf1=alp(itypi)
1365             alf2=alp(itypj)
1366             alf12=0.5D0*(alf1+alf2)
1367 C For diagnostics only!!!
1368 c           chi1=0.0D0
1369 c           chi2=0.0D0
1370 c           chi12=0.0D0
1371 c           chip1=0.0D0
1372 c           chip2=0.0D0
1373 c           chip12=0.0D0
1374 c           alf1=0.0D0
1375 c           alf2=0.0D0
1376 c           alf12=0.0D0
1377             xj=c(1,nres+j)-xi
1378             yj=c(2,nres+j)-yi
1379             zj=c(3,nres+j)-zi
1380             dxj=dc_norm(1,nres+j)
1381             dyj=dc_norm(2,nres+j)
1382             dzj=dc_norm(3,nres+j)
1383             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1384 cd          if (icall.eq.0) then
1385 cd            rrsave(ind)=rrij
1386 cd          else
1387 cd            rrij=rrsave(ind)
1388 cd          endif
1389             rij=dsqrt(rrij)
1390 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1391             call sc_angular
1392 C Calculate whole angle-dependent part of epsilon and contributions
1393 C to its derivatives
1394 C have you changed here?
1395             fac=(rrij*sigsq)**expon2
1396             e1=fac*fac*aa
1397             e2=fac*bb
1398             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1399             eps2der=evdwij*eps3rt
1400             eps3der=evdwij*eps2rt
1401             evdwij=evdwij*eps2rt*eps3rt
1402             evdw=evdw+evdwij
1403             if (lprn) then
1404             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1405             epsi=bb**2/aa
1406 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1407 cd     &        restyp(itypi),i,restyp(itypj),j,
1408 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1409 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1410 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1411 cd     &        evdwij
1412             endif
1413 C Calculate gradient components.
1414             e1=e1*eps1*eps2rt**2*eps3rt**2
1415             fac=-expon*(e1+evdwij)
1416             sigder=fac/sigsq
1417             fac=rrij*fac
1418 C Calculate radial part of the gradient
1419             gg(1)=xj*fac
1420             gg(2)=yj*fac
1421             gg(3)=zj*fac
1422 C Calculate the angular part of the gradient and sum add the contributions
1423 C to the appropriate components of the Cartesian gradient.
1424             call sc_grad
1425           enddo      ! j
1426         enddo        ! iint
1427       enddo          ! i
1428 c     stop
1429       return
1430       end
1431 C-----------------------------------------------------------------------------
1432       subroutine egb(evdw)
1433 C
1434 C This subroutine calculates the interaction energy of nonbonded side chains
1435 C assuming the Gay-Berne potential of interaction.
1436 C
1437       implicit real*8 (a-h,o-z)
1438       include 'DIMENSIONS'
1439       include 'COMMON.GEO'
1440       include 'COMMON.VAR'
1441       include 'COMMON.LOCAL'
1442       include 'COMMON.CHAIN'
1443       include 'COMMON.DERIV'
1444       include 'COMMON.NAMES'
1445       include 'COMMON.INTERACT'
1446       include 'COMMON.IOUNITS'
1447       include 'COMMON.CALC'
1448       include 'COMMON.CONTROL'
1449       include 'COMMON.SPLITELE'
1450       include 'COMMON.SBRIDGE'
1451       logical lprn
1452       integer xshift,yshift,zshift
1453       evdw=0.0D0
1454 ccccc      energy_dec=.false.
1455 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1456       evdw=0.0D0
1457       lprn=.false.
1458 c     if (icall.eq.0) lprn=.false.
1459       ind=0
1460 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1461 C we have the original box)
1462 C      do xshift=-1,1
1463 C      do yshift=-1,1
1464 C      do zshift=-1,1
1465       do i=iatsc_s,iatsc_e
1466         itypi=iabs(itype(i))
1467         if (itypi.eq.ntyp1) cycle
1468         itypi1=iabs(itype(i+1))
1469         xi=c(1,nres+i)
1470         yi=c(2,nres+i)
1471         zi=c(3,nres+i)
1472 C Return atom into box, boxxsize is size of box in x dimension
1473 c  134   continue
1474 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1475 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1476 C Condition for being inside the proper box
1477 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1478 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1479 c        go to 134
1480 c        endif
1481 c  135   continue
1482 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1483 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1484 C Condition for being inside the proper box
1485 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1486 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1487 c        go to 135
1488 c        endif
1489 c  136   continue
1490 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1491 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1492 C Condition for being inside the proper box
1493 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1494 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1495 c        go to 136
1496 c        endif
1497           xi=mod(xi,boxxsize)
1498           if (xi.lt.0) xi=xi+boxxsize
1499           yi=mod(yi,boxysize)
1500           if (yi.lt.0) yi=yi+boxysize
1501           zi=mod(zi,boxzsize)
1502           if (zi.lt.0) zi=zi+boxzsize
1503 C define scaling factor for lipids
1504
1505 C        if (positi.le.0) positi=positi+boxzsize
1506 C        print *,i
1507 C first for peptide groups
1508 c for each residue check if it is in lipid or lipid water border area
1509        if ((zi.gt.bordlipbot)
1510      &.and.(zi.lt.bordliptop)) then
1511 C the energy transfer exist
1512         if (zi.lt.buflipbot) then
1513 C what fraction I am in
1514          fracinbuf=1.0d0-
1515      &        ((zi-bordlipbot)/lipbufthick)
1516 C lipbufthick is thickenes of lipid buffore
1517          sslipi=sscalelip(fracinbuf)
1518          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1519         elseif (zi.gt.bufliptop) then
1520          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1521          sslipi=sscalelip(fracinbuf)
1522          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1523         else
1524          sslipi=1.0d0
1525          ssgradlipi=0.0
1526         endif
1527        else
1528          sslipi=0.0d0
1529          ssgradlipi=0.0
1530        endif
1531
1532 C          xi=xi+xshift*boxxsize
1533 C          yi=yi+yshift*boxysize
1534 C          zi=zi+zshift*boxzsize
1535
1536         dxi=dc_norm(1,nres+i)
1537         dyi=dc_norm(2,nres+i)
1538         dzi=dc_norm(3,nres+i)
1539 c        dsci_inv=dsc_inv(itypi)
1540         dsci_inv=vbld_inv(i+nres)
1541 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1542 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1543 C
1544 C Calculate SC interaction energy.
1545 C
1546         do iint=1,nint_gr(i)
1547           do j=istart(i,iint),iend(i,iint)
1548             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1549               call dyn_ssbond_ene(i,j,evdwij)
1550               evdw=evdw+evdwij
1551               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1552      &                        'evdw',i,j,evdwij,' ss'
1553             ELSE
1554             ind=ind+1
1555             itypj=iabs(itype(j))
1556             if (itypj.eq.ntyp1) cycle
1557 c            dscj_inv=dsc_inv(itypj)
1558             dscj_inv=vbld_inv(j+nres)
1559 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1560 c     &       1.0d0/vbld(j+nres)
1561 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1562             sig0ij=sigma(itypi,itypj)
1563             chi1=chi(itypi,itypj)
1564             chi2=chi(itypj,itypi)
1565             chi12=chi1*chi2
1566             chip1=chip(itypi)
1567             chip2=chip(itypj)
1568             chip12=chip1*chip2
1569             alf1=alp(itypi)
1570             alf2=alp(itypj)
1571             alf12=0.5D0*(alf1+alf2)
1572 C For diagnostics only!!!
1573 c           chi1=0.0D0
1574 c           chi2=0.0D0
1575 c           chi12=0.0D0
1576 c           chip1=0.0D0
1577 c           chip2=0.0D0
1578 c           chip12=0.0D0
1579 c           alf1=0.0D0
1580 c           alf2=0.0D0
1581 c           alf12=0.0D0
1582             xj=c(1,nres+j)
1583             yj=c(2,nres+j)
1584             zj=c(3,nres+j)
1585 C Return atom J into box the original box
1586 c  137   continue
1587 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1588 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1589 C Condition for being inside the proper box
1590 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1591 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1592 c        go to 137
1593 c        endif
1594 c  138   continue
1595 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1596 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1597 C Condition for being inside the proper box
1598 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1599 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1600 c        go to 138
1601 c        endif
1602 c  139   continue
1603 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1604 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1605 C Condition for being inside the proper box
1606 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1607 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1608 c        go to 139
1609 c        endif
1610           xj=mod(xj,boxxsize)
1611           if (xj.lt.0) xj=xj+boxxsize
1612           yj=mod(yj,boxysize)
1613           if (yj.lt.0) yj=yj+boxysize
1614           zj=mod(zj,boxzsize)
1615           if (zj.lt.0) zj=zj+boxzsize
1616        if ((zj.gt.bordlipbot)
1617      &.and.(zj.lt.bordliptop)) then
1618 C the energy transfer exist
1619         if (zj.lt.buflipbot) then
1620 C what fraction I am in
1621          fracinbuf=1.0d0-
1622      &        ((zj-bordlipbot)/lipbufthick)
1623 C lipbufthick is thickenes of lipid buffore
1624          sslipj=sscalelip(fracinbuf)
1625          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1626         elseif (zi.gt.bufliptop) then
1627          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1628          sslipj=sscalelip(fracinbuf)
1629          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1630         else
1631          sslipj=1.0d0
1632          ssgradlipj=0.0
1633         endif
1634        else
1635          sslipj=0.0d0
1636          ssgradlipj=0.0
1637        endif
1638       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1639      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1640       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1641      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1642 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1643 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1644 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1645 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1646       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1647       xj_safe=xj
1648       yj_safe=yj
1649       zj_safe=zj
1650       subchap=0
1651       do xshift=-1,1
1652       do yshift=-1,1
1653       do zshift=-1,1
1654           xj=xj_safe+xshift*boxxsize
1655           yj=yj_safe+yshift*boxysize
1656           zj=zj_safe+zshift*boxzsize
1657           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1658           if(dist_temp.lt.dist_init) then
1659             dist_init=dist_temp
1660             xj_temp=xj
1661             yj_temp=yj
1662             zj_temp=zj
1663             subchap=1
1664           endif
1665        enddo
1666        enddo
1667        enddo
1668        if (subchap.eq.1) then
1669           xj=xj_temp-xi
1670           yj=yj_temp-yi
1671           zj=zj_temp-zi
1672        else
1673           xj=xj_safe-xi
1674           yj=yj_safe-yi
1675           zj=zj_safe-zi
1676        endif
1677             dxj=dc_norm(1,nres+j)
1678             dyj=dc_norm(2,nres+j)
1679             dzj=dc_norm(3,nres+j)
1680 C            xj=xj-xi
1681 C            yj=yj-yi
1682 C            zj=zj-zi
1683 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1684 c            write (iout,*) "j",j," dc_norm",
1685 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1686             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1687             rij=dsqrt(rrij)
1688             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1689             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1690
1691 c            write (iout,'(a7,4f8.3)')
1692 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1693             if (sss.gt.0.0d0) then
1694 C Calculate angle-dependent terms of energy and contributions to their
1695 C derivatives.
1696             call sc_angular
1697             sigsq=1.0D0/sigsq
1698             sig=sig0ij*dsqrt(sigsq)
1699             rij_shift=1.0D0/rij-sig+sig0ij
1700 c for diagnostics; uncomment
1701 c            rij_shift=1.2*sig0ij
1702 C I hate to put IF's in the loops, but here don't have another choice!!!!
1703             if (rij_shift.le.0.0D0) then
1704               evdw=1.0D20
1705 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1706 cd     &        restyp(itypi),i,restyp(itypj),j,
1707 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1708               return
1709             endif
1710             sigder=-sig*sigsq
1711 c---------------------------------------------------------------
1712             rij_shift=1.0D0/rij_shift
1713             fac=rij_shift**expon
1714 C here to start with
1715 C            if (c(i,3).gt.
1716             faclip=fac
1717             e1=fac*fac*aa
1718             e2=fac*bb
1719             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1720             eps2der=evdwij*eps3rt
1721             eps3der=evdwij*eps2rt
1722 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1723 C     &((sslipi+sslipj)/2.0d0+
1724 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1725 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1726 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1727             evdwij=evdwij*eps2rt*eps3rt
1728             evdw=evdw+evdwij*sss
1729             if (lprn) then
1730             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1731             epsi=bb**2/aa
1732             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1733      &        restyp(itypi),i,restyp(itypj),j,
1734      &        epsi,sigm,chi1,chi2,chip1,chip2,
1735      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1736      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1737      &        evdwij
1738             endif
1739
1740             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1741      &                        'evdw',i,j,evdwij
1742
1743 C Calculate gradient components.
1744             e1=e1*eps1*eps2rt**2*eps3rt**2
1745             fac=-expon*(e1+evdwij)*rij_shift
1746             sigder=fac*sigder
1747             fac=rij*fac
1748 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1749 c     &      evdwij,fac,sigma(itypi,itypj),expon
1750             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1751 c            fac=0.0d0
1752 C Calculate the radial part of the gradient
1753             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1754      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1755      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1756      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1757             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1758             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1759 C            gg_lipi(3)=0.0d0
1760 C            gg_lipj(3)=0.0d0
1761             gg(1)=xj*fac
1762             gg(2)=yj*fac
1763             gg(3)=zj*fac
1764 C Calculate angular part of the gradient.
1765             call sc_grad
1766             endif
1767             ENDIF    ! dyn_ss
1768           enddo      ! j
1769         enddo        ! iint
1770       enddo          ! i
1771 C      enddo          ! zshift
1772 C      enddo          ! yshift
1773 C      enddo          ! xshift
1774 c      write (iout,*) "Number of loop steps in EGB:",ind
1775 cccc      energy_dec=.false.
1776       return
1777       end
1778 C-----------------------------------------------------------------------------
1779       subroutine egbv(evdw)
1780 C
1781 C This subroutine calculates the interaction energy of nonbonded side chains
1782 C assuming the Gay-Berne-Vorobjev potential of interaction.
1783 C
1784       implicit real*8 (a-h,o-z)
1785       include 'DIMENSIONS'
1786       include 'COMMON.GEO'
1787       include 'COMMON.VAR'
1788       include 'COMMON.LOCAL'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.DERIV'
1791       include 'COMMON.NAMES'
1792       include 'COMMON.INTERACT'
1793       include 'COMMON.IOUNITS'
1794       include 'COMMON.CALC'
1795       common /srutu/ icall
1796       logical lprn
1797       evdw=0.0D0
1798 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1799       evdw=0.0D0
1800       lprn=.false.
1801 c     if (icall.eq.0) lprn=.true.
1802       ind=0
1803       do i=iatsc_s,iatsc_e
1804         itypi=iabs(itype(i))
1805         if (itypi.eq.ntyp1) cycle
1806         itypi1=iabs(itype(i+1))
1807         xi=c(1,nres+i)
1808         yi=c(2,nres+i)
1809         zi=c(3,nres+i)
1810           xi=mod(xi,boxxsize)
1811           if (xi.lt.0) xi=xi+boxxsize
1812           yi=mod(yi,boxysize)
1813           if (yi.lt.0) yi=yi+boxysize
1814           zi=mod(zi,boxzsize)
1815           if (zi.lt.0) zi=zi+boxzsize
1816 C define scaling factor for lipids
1817
1818 C        if (positi.le.0) positi=positi+boxzsize
1819 C        print *,i
1820 C first for peptide groups
1821 c for each residue check if it is in lipid or lipid water border area
1822        if ((zi.gt.bordlipbot)
1823      &.and.(zi.lt.bordliptop)) then
1824 C the energy transfer exist
1825         if (zi.lt.buflipbot) then
1826 C what fraction I am in
1827          fracinbuf=1.0d0-
1828      &        ((positi-bordlipbot)/lipbufthick)
1829 C lipbufthick is thickenes of lipid buffore
1830          sslipi=sscalelip(fracinbuf)
1831          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1832         elseif (zi.gt.bufliptop) then
1833          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
1834          sslipi=sscalelip(fracinbuf)
1835          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1836         else
1837          sslipi=1.0d0
1838          ssgradlipi=0.0
1839         endif
1840        else
1841          sslipi=0.0d0
1842          ssgradlipi=0.0
1843        endif
1844
1845         dxi=dc_norm(1,nres+i)
1846         dyi=dc_norm(2,nres+i)
1847         dzi=dc_norm(3,nres+i)
1848 c        dsci_inv=dsc_inv(itypi)
1849         dsci_inv=vbld_inv(i+nres)
1850 C
1851 C Calculate SC interaction energy.
1852 C
1853         do iint=1,nint_gr(i)
1854           do j=istart(i,iint),iend(i,iint)
1855             ind=ind+1
1856             itypj=iabs(itype(j))
1857             if (itypj.eq.ntyp1) cycle
1858 c            dscj_inv=dsc_inv(itypj)
1859             dscj_inv=vbld_inv(j+nres)
1860             sig0ij=sigma(itypi,itypj)
1861             r0ij=r0(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881 C            xj=c(1,nres+j)-xi
1882 C            yj=c(2,nres+j)-yi
1883 C            zj=c(3,nres+j)-zi
1884           xj=mod(xj,boxxsize)
1885           if (xj.lt.0) xj=xj+boxxsize
1886           yj=mod(yj,boxysize)
1887           if (yj.lt.0) yj=yj+boxysize
1888           zj=mod(zj,boxzsize)
1889           if (zj.lt.0) zj=zj+boxzsize
1890        if ((zj.gt.bordlipbot)
1891      &.and.(zj.lt.bordliptop)) then
1892 C the energy transfer exist
1893         if (zj.lt.buflipbot) then
1894 C what fraction I am in
1895          fracinbuf=1.0d0-
1896      &        ((positi-bordlipbot)/lipbufthick)
1897 C lipbufthick is thickenes of lipid buffore
1898          sslipj=sscalelip(fracinbuf)
1899          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1900         elseif (zi.gt.bufliptop) then
1901          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
1902          sslipj=sscalelip(fracinbuf)
1903          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1904         else
1905          sslipj=1.0d0
1906          ssgradlipj=0.0
1907         endif
1908        else
1909          sslipj=0.0d0
1910          ssgradlipj=0.0
1911        endif
1912       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1913      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1914       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1915      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1916 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1917 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1918       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1919       xj_safe=xj
1920       yj_safe=yj
1921       zj_safe=zj
1922       subchap=0
1923       do xshift=-1,1
1924       do yshift=-1,1
1925       do zshift=-1,1
1926           xj=xj_safe+xshift*boxxsize
1927           yj=yj_safe+yshift*boxysize
1928           zj=zj_safe+zshift*boxzsize
1929           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1930           if(dist_temp.lt.dist_init) then
1931             dist_init=dist_temp
1932             xj_temp=xj
1933             yj_temp=yj
1934             zj_temp=zj
1935             subchap=1
1936           endif
1937        enddo
1938        enddo
1939        enddo
1940        if (subchap.eq.1) then
1941           xj=xj_temp-xi
1942           yj=yj_temp-yi
1943           zj=zj_temp-zi
1944        else
1945           xj=xj_safe-xi
1946           yj=yj_safe-yi
1947           zj=zj_safe-zi
1948        endif
1949             dxj=dc_norm(1,nres+j)
1950             dyj=dc_norm(2,nres+j)
1951             dzj=dc_norm(3,nres+j)
1952             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1953             rij=dsqrt(rrij)
1954 C Calculate angle-dependent terms of energy and contributions to their
1955 C derivatives.
1956             call sc_angular
1957             sigsq=1.0D0/sigsq
1958             sig=sig0ij*dsqrt(sigsq)
1959             rij_shift=1.0D0/rij-sig+r0ij
1960 C I hate to put IF's in the loops, but here don't have another choice!!!!
1961             if (rij_shift.le.0.0D0) then
1962               evdw=1.0D20
1963               return
1964             endif
1965             sigder=-sig*sigsq
1966 c---------------------------------------------------------------
1967             rij_shift=1.0D0/rij_shift
1968             fac=rij_shift**expon
1969             e1=fac*fac*aa
1970             e2=fac*bb
1971             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1972             eps2der=evdwij*eps3rt
1973             eps3der=evdwij*eps2rt
1974             fac_augm=rrij**expon
1975             e_augm=augm(itypi,itypj)*fac_augm
1976             evdwij=evdwij*eps2rt*eps3rt
1977             evdw=evdw+evdwij+e_augm
1978             if (lprn) then
1979             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1980             epsi=bb**2/aa
1981             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1982      &        restyp(itypi),i,restyp(itypj),j,
1983      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1984      &        chi1,chi2,chip1,chip2,
1985      &        eps1,eps2rt**2,eps3rt**2,
1986      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1987      &        evdwij+e_augm
1988             endif
1989 C Calculate gradient components.
1990             e1=e1*eps1*eps2rt**2*eps3rt**2
1991             fac=-expon*(e1+evdwij)*rij_shift
1992             sigder=fac*sigder
1993             fac=rij*fac-2*expon*rrij*e_augm
1994             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1995 C Calculate the radial part of the gradient
1996             gg(1)=xj*fac
1997             gg(2)=yj*fac
1998             gg(3)=zj*fac
1999 C Calculate angular part of the gradient.
2000             call sc_grad
2001           enddo      ! j
2002         enddo        ! iint
2003       enddo          ! i
2004       end
2005 C-----------------------------------------------------------------------------
2006       subroutine sc_angular
2007 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2008 C om12. Called by ebp, egb, and egbv.
2009       implicit none
2010       include 'COMMON.CALC'
2011       include 'COMMON.IOUNITS'
2012       erij(1)=xj*rij
2013       erij(2)=yj*rij
2014       erij(3)=zj*rij
2015       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2016       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2017       om12=dxi*dxj+dyi*dyj+dzi*dzj
2018       chiom12=chi12*om12
2019 C Calculate eps1(om12) and its derivative in om12
2020       faceps1=1.0D0-om12*chiom12
2021       faceps1_inv=1.0D0/faceps1
2022       eps1=dsqrt(faceps1_inv)
2023 C Following variable is eps1*deps1/dom12
2024       eps1_om12=faceps1_inv*chiom12
2025 c diagnostics only
2026 c      faceps1_inv=om12
2027 c      eps1=om12
2028 c      eps1_om12=1.0d0
2029 c      write (iout,*) "om12",om12," eps1",eps1
2030 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2031 C and om12.
2032       om1om2=om1*om2
2033       chiom1=chi1*om1
2034       chiom2=chi2*om2
2035       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2036       sigsq=1.0D0-facsig*faceps1_inv
2037       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2038       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2039       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2040 c diagnostics only
2041 c      sigsq=1.0d0
2042 c      sigsq_om1=0.0d0
2043 c      sigsq_om2=0.0d0
2044 c      sigsq_om12=0.0d0
2045 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2046 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2047 c     &    " eps1",eps1
2048 C Calculate eps2 and its derivatives in om1, om2, and om12.
2049       chipom1=chip1*om1
2050       chipom2=chip2*om2
2051       chipom12=chip12*om12
2052       facp=1.0D0-om12*chipom12
2053       facp_inv=1.0D0/facp
2054       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2055 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2056 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2057 C Following variable is the square root of eps2
2058       eps2rt=1.0D0-facp1*facp_inv
2059 C Following three variables are the derivatives of the square root of eps
2060 C in om1, om2, and om12.
2061       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2062       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2063       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2064 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2065       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2066 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2067 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2068 c     &  " eps2rt_om12",eps2rt_om12
2069 C Calculate whole angle-dependent part of epsilon and contributions
2070 C to its derivatives
2071       return
2072       end
2073 C----------------------------------------------------------------------------
2074       subroutine sc_grad
2075       implicit real*8 (a-h,o-z)
2076       include 'DIMENSIONS'
2077       include 'COMMON.CHAIN'
2078       include 'COMMON.DERIV'
2079       include 'COMMON.CALC'
2080       include 'COMMON.IOUNITS'
2081       double precision dcosom1(3),dcosom2(3)
2082 cc      print *,'sss=',sss
2083       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2084       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2085       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2086      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2087 c diagnostics only
2088 c      eom1=0.0d0
2089 c      eom2=0.0d0
2090 c      eom12=evdwij*eps1_om12
2091 c end diagnostics
2092 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2093 c     &  " sigder",sigder
2094 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2095 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2096       do k=1,3
2097         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2098         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2099       enddo
2100       do k=1,3
2101         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2102       enddo
2103 c      write (iout,*) "gg",(gg(k),k=1,3)
2104       do k=1,3
2105         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2106      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2107      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2108         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2109      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2110      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2111 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2112 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2113 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2114 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2115       enddo
2116 C
2117 C Calculate the components of the gradient in DC and X
2118 C
2119 cgrad      do k=i,j-1
2120 cgrad        do l=1,3
2121 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2122 cgrad        enddo
2123 cgrad      enddo
2124       do l=1,3
2125         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2126         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2127       enddo
2128       return
2129       end
2130 C-----------------------------------------------------------------------
2131       subroutine e_softsphere(evdw)
2132 C
2133 C This subroutine calculates the interaction energy of nonbonded side chains
2134 C assuming the LJ potential of interaction.
2135 C
2136       implicit real*8 (a-h,o-z)
2137       include 'DIMENSIONS'
2138       parameter (accur=1.0d-10)
2139       include 'COMMON.GEO'
2140       include 'COMMON.VAR'
2141       include 'COMMON.LOCAL'
2142       include 'COMMON.CHAIN'
2143       include 'COMMON.DERIV'
2144       include 'COMMON.INTERACT'
2145       include 'COMMON.TORSION'
2146       include 'COMMON.SBRIDGE'
2147       include 'COMMON.NAMES'
2148       include 'COMMON.IOUNITS'
2149       include 'COMMON.CONTACTS'
2150       dimension gg(3)
2151 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2152       evdw=0.0D0
2153       do i=iatsc_s,iatsc_e
2154         itypi=iabs(itype(i))
2155         if (itypi.eq.ntyp1) cycle
2156         itypi1=iabs(itype(i+1))
2157         xi=c(1,nres+i)
2158         yi=c(2,nres+i)
2159         zi=c(3,nres+i)
2160 C
2161 C Calculate SC interaction energy.
2162 C
2163         do iint=1,nint_gr(i)
2164 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2165 cd   &                  'iend=',iend(i,iint)
2166           do j=istart(i,iint),iend(i,iint)
2167             itypj=iabs(itype(j))
2168             if (itypj.eq.ntyp1) cycle
2169             xj=c(1,nres+j)-xi
2170             yj=c(2,nres+j)-yi
2171             zj=c(3,nres+j)-zi
2172             rij=xj*xj+yj*yj+zj*zj
2173 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2174             r0ij=r0(itypi,itypj)
2175             r0ijsq=r0ij*r0ij
2176 c            print *,i,j,r0ij,dsqrt(rij)
2177             if (rij.lt.r0ijsq) then
2178               evdwij=0.25d0*(rij-r0ijsq)**2
2179               fac=rij-r0ijsq
2180             else
2181               evdwij=0.0d0
2182               fac=0.0d0
2183             endif
2184             evdw=evdw+evdwij
2185 C
2186 C Calculate the components of the gradient in DC and X
2187 C
2188             gg(1)=xj*fac
2189             gg(2)=yj*fac
2190             gg(3)=zj*fac
2191             do k=1,3
2192               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2193               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2194               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2195               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2196             enddo
2197 cgrad            do k=i,j-1
2198 cgrad              do l=1,3
2199 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2200 cgrad              enddo
2201 cgrad            enddo
2202           enddo ! j
2203         enddo ! iint
2204       enddo ! i
2205       return
2206       end
2207 C--------------------------------------------------------------------------
2208       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2209      &              eello_turn4)
2210 C
2211 C Soft-sphere potential of p-p interaction
2212 C
2213       implicit real*8 (a-h,o-z)
2214       include 'DIMENSIONS'
2215       include 'COMMON.CONTROL'
2216       include 'COMMON.IOUNITS'
2217       include 'COMMON.GEO'
2218       include 'COMMON.VAR'
2219       include 'COMMON.LOCAL'
2220       include 'COMMON.CHAIN'
2221       include 'COMMON.DERIV'
2222       include 'COMMON.INTERACT'
2223       include 'COMMON.CONTACTS'
2224       include 'COMMON.TORSION'
2225       include 'COMMON.VECTORS'
2226       include 'COMMON.FFIELD'
2227       dimension ggg(3)
2228 C      write(iout,*) 'In EELEC_soft_sphere'
2229       ees=0.0D0
2230       evdw1=0.0D0
2231       eel_loc=0.0d0
2232       eello_turn3=0.0d0
2233       eello_turn4=0.0d0
2234       ind=0
2235       do i=iatel_s,iatel_e
2236         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2237         dxi=dc(1,i)
2238         dyi=dc(2,i)
2239         dzi=dc(3,i)
2240         xmedi=c(1,i)+0.5d0*dxi
2241         ymedi=c(2,i)+0.5d0*dyi
2242         zmedi=c(3,i)+0.5d0*dzi
2243           xmedi=mod(xmedi,boxxsize)
2244           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2245           ymedi=mod(ymedi,boxysize)
2246           if (ymedi.lt.0) ymedi=ymedi+boxysize
2247           zmedi=mod(zmedi,boxzsize)
2248           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2249         num_conti=0
2250 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2251         do j=ielstart(i),ielend(i)
2252           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2253           ind=ind+1
2254           iteli=itel(i)
2255           itelj=itel(j)
2256           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2257           r0ij=rpp(iteli,itelj)
2258           r0ijsq=r0ij*r0ij
2259           dxj=dc(1,j)
2260           dyj=dc(2,j)
2261           dzj=dc(3,j)
2262           xj=c(1,j)+0.5D0*dxj
2263           yj=c(2,j)+0.5D0*dyj
2264           zj=c(3,j)+0.5D0*dzj
2265           xj=mod(xj,boxxsize)
2266           if (xj.lt.0) xj=xj+boxxsize
2267           yj=mod(yj,boxysize)
2268           if (yj.lt.0) yj=yj+boxysize
2269           zj=mod(zj,boxzsize)
2270           if (zj.lt.0) zj=zj+boxzsize
2271       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2272       xj_safe=xj
2273       yj_safe=yj
2274       zj_safe=zj
2275       isubchap=0
2276       do xshift=-1,1
2277       do yshift=-1,1
2278       do zshift=-1,1
2279           xj=xj_safe+xshift*boxxsize
2280           yj=yj_safe+yshift*boxysize
2281           zj=zj_safe+zshift*boxzsize
2282           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2283           if(dist_temp.lt.dist_init) then
2284             dist_init=dist_temp
2285             xj_temp=xj
2286             yj_temp=yj
2287             zj_temp=zj
2288             isubchap=1
2289           endif
2290        enddo
2291        enddo
2292        enddo
2293        if (isubchap.eq.1) then
2294           xj=xj_temp-xmedi
2295           yj=yj_temp-ymedi
2296           zj=zj_temp-zmedi
2297        else
2298           xj=xj_safe-xmedi
2299           yj=yj_safe-ymedi
2300           zj=zj_safe-zmedi
2301        endif
2302           rij=xj*xj+yj*yj+zj*zj
2303             sss=sscale(sqrt(rij))
2304             sssgrad=sscagrad(sqrt(rij))
2305           if (rij.lt.r0ijsq) then
2306             evdw1ij=0.25d0*(rij-r0ijsq)**2
2307             fac=rij-r0ijsq
2308           else
2309             evdw1ij=0.0d0
2310             fac=0.0d0
2311           endif
2312           evdw1=evdw1+evdw1ij*sss
2313 C
2314 C Calculate contributions to the Cartesian gradient.
2315 C
2316           ggg(1)=fac*xj*sssgrad
2317           ggg(2)=fac*yj*sssgrad
2318           ggg(3)=fac*zj*sssgrad
2319           do k=1,3
2320             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2321             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2322           enddo
2323 *
2324 * Loop over residues i+1 thru j-1.
2325 *
2326 cgrad          do k=i+1,j-1
2327 cgrad            do l=1,3
2328 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2329 cgrad            enddo
2330 cgrad          enddo
2331         enddo ! j
2332       enddo   ! i
2333 cgrad      do i=nnt,nct-1
2334 cgrad        do k=1,3
2335 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2336 cgrad        enddo
2337 cgrad        do j=i+1,nct-1
2338 cgrad          do k=1,3
2339 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2340 cgrad          enddo
2341 cgrad        enddo
2342 cgrad      enddo
2343       return
2344       end
2345 c------------------------------------------------------------------------------
2346       subroutine vec_and_deriv
2347       implicit real*8 (a-h,o-z)
2348       include 'DIMENSIONS'
2349 #ifdef MPI
2350       include 'mpif.h'
2351 #endif
2352       include 'COMMON.IOUNITS'
2353       include 'COMMON.GEO'
2354       include 'COMMON.VAR'
2355       include 'COMMON.LOCAL'
2356       include 'COMMON.CHAIN'
2357       include 'COMMON.VECTORS'
2358       include 'COMMON.SETUP'
2359       include 'COMMON.TIME1'
2360       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2361 C Compute the local reference systems. For reference system (i), the
2362 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2363 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2364 #ifdef PARVEC
2365       do i=ivec_start,ivec_end
2366 #else
2367       do i=1,nres-1
2368 #endif
2369           if (i.eq.nres-1) then
2370 C Case of the last full residue
2371 C Compute the Z-axis
2372             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2373             costh=dcos(pi-theta(nres))
2374             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2375             do k=1,3
2376               uz(k,i)=fac*uz(k,i)
2377             enddo
2378 C Compute the derivatives of uz
2379             uzder(1,1,1)= 0.0d0
2380             uzder(2,1,1)=-dc_norm(3,i-1)
2381             uzder(3,1,1)= dc_norm(2,i-1)
2382             uzder(1,2,1)= dc_norm(3,i-1)
2383             uzder(2,2,1)= 0.0d0
2384             uzder(3,2,1)=-dc_norm(1,i-1)
2385             uzder(1,3,1)=-dc_norm(2,i-1)
2386             uzder(2,3,1)= dc_norm(1,i-1)
2387             uzder(3,3,1)= 0.0d0
2388             uzder(1,1,2)= 0.0d0
2389             uzder(2,1,2)= dc_norm(3,i)
2390             uzder(3,1,2)=-dc_norm(2,i)
2391             uzder(1,2,2)=-dc_norm(3,i)
2392             uzder(2,2,2)= 0.0d0
2393             uzder(3,2,2)= dc_norm(1,i)
2394             uzder(1,3,2)= dc_norm(2,i)
2395             uzder(2,3,2)=-dc_norm(1,i)
2396             uzder(3,3,2)= 0.0d0
2397 C Compute the Y-axis
2398             facy=fac
2399             do k=1,3
2400               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2401             enddo
2402 C Compute the derivatives of uy
2403             do j=1,3
2404               do k=1,3
2405                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2406      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2407                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2408               enddo
2409               uyder(j,j,1)=uyder(j,j,1)-costh
2410               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2411             enddo
2412             do j=1,2
2413               do k=1,3
2414                 do l=1,3
2415                   uygrad(l,k,j,i)=uyder(l,k,j)
2416                   uzgrad(l,k,j,i)=uzder(l,k,j)
2417                 enddo
2418               enddo
2419             enddo
2420             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2421             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2422             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2423             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2424           else
2425 C Other residues
2426 C Compute the Z-axis
2427             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2428             costh=dcos(pi-theta(i+2))
2429             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2430             do k=1,3
2431               uz(k,i)=fac*uz(k,i)
2432             enddo
2433 C Compute the derivatives of uz
2434             uzder(1,1,1)= 0.0d0
2435             uzder(2,1,1)=-dc_norm(3,i+1)
2436             uzder(3,1,1)= dc_norm(2,i+1)
2437             uzder(1,2,1)= dc_norm(3,i+1)
2438             uzder(2,2,1)= 0.0d0
2439             uzder(3,2,1)=-dc_norm(1,i+1)
2440             uzder(1,3,1)=-dc_norm(2,i+1)
2441             uzder(2,3,1)= dc_norm(1,i+1)
2442             uzder(3,3,1)= 0.0d0
2443             uzder(1,1,2)= 0.0d0
2444             uzder(2,1,2)= dc_norm(3,i)
2445             uzder(3,1,2)=-dc_norm(2,i)
2446             uzder(1,2,2)=-dc_norm(3,i)
2447             uzder(2,2,2)= 0.0d0
2448             uzder(3,2,2)= dc_norm(1,i)
2449             uzder(1,3,2)= dc_norm(2,i)
2450             uzder(2,3,2)=-dc_norm(1,i)
2451             uzder(3,3,2)= 0.0d0
2452 C Compute the Y-axis
2453             facy=fac
2454             do k=1,3
2455               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2456             enddo
2457 C Compute the derivatives of uy
2458             do j=1,3
2459               do k=1,3
2460                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2461      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2462                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2463               enddo
2464               uyder(j,j,1)=uyder(j,j,1)-costh
2465               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2466             enddo
2467             do j=1,2
2468               do k=1,3
2469                 do l=1,3
2470                   uygrad(l,k,j,i)=uyder(l,k,j)
2471                   uzgrad(l,k,j,i)=uzder(l,k,j)
2472                 enddo
2473               enddo
2474             enddo
2475             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2476             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2477             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2478             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2479           endif
2480       enddo
2481       do i=1,nres-1
2482         vbld_inv_temp(1)=vbld_inv(i+1)
2483         if (i.lt.nres-1) then
2484           vbld_inv_temp(2)=vbld_inv(i+2)
2485           else
2486           vbld_inv_temp(2)=vbld_inv(i)
2487           endif
2488         do j=1,2
2489           do k=1,3
2490             do l=1,3
2491               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2492               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2493             enddo
2494           enddo
2495         enddo
2496       enddo
2497 #if defined(PARVEC) && defined(MPI)
2498       if (nfgtasks1.gt.1) then
2499         time00=MPI_Wtime()
2500 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2501 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2502 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2503         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2504      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2505      &   FG_COMM1,IERR)
2506         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2510      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2511      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2512         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2513      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2514      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2515         time_gather=time_gather+MPI_Wtime()-time00
2516       endif
2517 c      if (fg_rank.eq.0) then
2518 c        write (iout,*) "Arrays UY and UZ"
2519 c        do i=1,nres-1
2520 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2521 c     &     (uz(k,i),k=1,3)
2522 c        enddo
2523 c      endif
2524 #endif
2525       return
2526       end
2527 C-----------------------------------------------------------------------------
2528       subroutine check_vecgrad
2529       implicit real*8 (a-h,o-z)
2530       include 'DIMENSIONS'
2531       include 'COMMON.IOUNITS'
2532       include 'COMMON.GEO'
2533       include 'COMMON.VAR'
2534       include 'COMMON.LOCAL'
2535       include 'COMMON.CHAIN'
2536       include 'COMMON.VECTORS'
2537       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2538       dimension uyt(3,maxres),uzt(3,maxres)
2539       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2540       double precision delta /1.0d-7/
2541       call vec_and_deriv
2542 cd      do i=1,nres
2543 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2544 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2545 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2546 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2547 cd     &     (dc_norm(if90,i),if90=1,3)
2548 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2549 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2550 cd          write(iout,'(a)')
2551 cd      enddo
2552       do i=1,nres
2553         do j=1,2
2554           do k=1,3
2555             do l=1,3
2556               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2557               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2558             enddo
2559           enddo
2560         enddo
2561       enddo
2562       call vec_and_deriv
2563       do i=1,nres
2564         do j=1,3
2565           uyt(j,i)=uy(j,i)
2566           uzt(j,i)=uz(j,i)
2567         enddo
2568       enddo
2569       do i=1,nres
2570 cd        write (iout,*) 'i=',i
2571         do k=1,3
2572           erij(k)=dc_norm(k,i)
2573         enddo
2574         do j=1,3
2575           do k=1,3
2576             dc_norm(k,i)=erij(k)
2577           enddo
2578           dc_norm(j,i)=dc_norm(j,i)+delta
2579 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2580 c          do k=1,3
2581 c            dc_norm(k,i)=dc_norm(k,i)/fac
2582 c          enddo
2583 c          write (iout,*) (dc_norm(k,i),k=1,3)
2584 c          write (iout,*) (erij(k),k=1,3)
2585           call vec_and_deriv
2586           do k=1,3
2587             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2588             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2589             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2590             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2591           enddo
2592 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2593 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2594 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2595         enddo
2596         do k=1,3
2597           dc_norm(k,i)=erij(k)
2598         enddo
2599 cd        do k=1,3
2600 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2601 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2602 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2603 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2604 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2605 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2606 cd          write (iout,'(a)')
2607 cd        enddo
2608       enddo
2609       return
2610       end
2611 C--------------------------------------------------------------------------
2612       subroutine set_matrices
2613       implicit real*8 (a-h,o-z)
2614       include 'DIMENSIONS'
2615 #ifdef MPI
2616       include "mpif.h"
2617       include "COMMON.SETUP"
2618       integer IERR
2619       integer status(MPI_STATUS_SIZE)
2620 #endif
2621       include 'COMMON.IOUNITS'
2622       include 'COMMON.GEO'
2623       include 'COMMON.VAR'
2624       include 'COMMON.LOCAL'
2625       include 'COMMON.CHAIN'
2626       include 'COMMON.DERIV'
2627       include 'COMMON.INTERACT'
2628       include 'COMMON.CONTACTS'
2629       include 'COMMON.TORSION'
2630       include 'COMMON.VECTORS'
2631       include 'COMMON.FFIELD'
2632       double precision auxvec(2),auxmat(2,2)
2633 C
2634 C Compute the virtual-bond-torsional-angle dependent quantities needed
2635 C to calculate the el-loc multibody terms of various order.
2636 C
2637 c      write(iout,*) 'nphi=',nphi,nres
2638 #ifdef PARMAT
2639       do i=ivec_start+2,ivec_end+2
2640 #else
2641       do i=3,nres+1
2642 #endif
2643 #ifdef NEWCORR
2644         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2645           iti = itortyp(itype(i-2))
2646         else
2647           iti=ntortyp+1
2648         endif
2649 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2650         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2651           iti1 = itortyp(itype(i-1))
2652         else
2653           iti1=ntortyp+1
2654         endif
2655 c        write(iout,*),i
2656         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2657      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2658      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2659         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2660      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2661      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2662 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2663 c     &*(cos(theta(i)/2.0)
2664         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2665      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2666      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2667 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2668 c     &*(cos(theta(i)/2.0)
2669         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2670      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2671      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2672 c        if (ggb1(1,i).eq.0.0d0) then
2673 c        write(iout,*) 'i=',i,ggb1(1,i),
2674 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2675 c     &bnew1(2,1,iti)*cos(theta(i)),
2676 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2677 c        endif
2678         b1(2,i-2)=bnew1(1,2,iti)
2679         gtb1(2,i-2)=0.0
2680         b2(2,i-2)=bnew2(1,2,iti)
2681         gtb2(2,i-2)=0.0
2682         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2683         EE(1,2,i-2)=eeold(1,2,iti)
2684         EE(2,1,i-2)=eeold(2,1,iti)
2685         EE(2,2,i-2)=eeold(2,2,iti)
2686         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2687         gtEE(1,2,i-2)=0.0d0
2688         gtEE(2,2,i-2)=0.0d0
2689         gtEE(2,1,i-2)=0.0d0
2690 c        EE(2,2,iti)=0.0d0
2691 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2692 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2693 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2694 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2695        b1tilde(1,i-2)=b1(1,i-2)
2696        b1tilde(2,i-2)=-b1(2,i-2)
2697        b2tilde(1,i-2)=b2(1,i-2)
2698        b2tilde(2,i-2)=-b2(2,i-2)
2699 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2700 c       write(iout,*)  'b1=',b1(1,i-2)
2701 c       write (iout,*) 'theta=', theta(i-1)
2702        enddo
2703 #else
2704         b1(1,i-2)=b(3,iti)
2705         b1(2,i-2)=b(5,iti)
2706         b2(1,i-2)=b(2,iti)
2707         b2(2,i-2)=b(4,iti)
2708        b1tilde(1,i-2)=b1(1,i-2)
2709        b1tilde(2,i-2)=-b1(2,i-2)
2710        b2tilde(1,i-2)=b2(1,i-2)
2711        b2tilde(2,i-2)=-b2(2,i-2)
2712         EE(1,2,i-2)=eeold(1,2,iti)
2713         EE(2,1,i-2)=eeold(2,1,iti)
2714         EE(2,2,i-2)=eeold(2,2,iti)
2715         EE(1,1,i-2)=eeold(1,1,iti)
2716       enddo
2717 #endif
2718 #ifdef PARMAT
2719       do i=ivec_start+2,ivec_end+2
2720 #else
2721       do i=3,nres+1
2722 #endif
2723         if (i .lt. nres+1) then
2724           sin1=dsin(phi(i))
2725           cos1=dcos(phi(i))
2726           sintab(i-2)=sin1
2727           costab(i-2)=cos1
2728           obrot(1,i-2)=cos1
2729           obrot(2,i-2)=sin1
2730           sin2=dsin(2*phi(i))
2731           cos2=dcos(2*phi(i))
2732           sintab2(i-2)=sin2
2733           costab2(i-2)=cos2
2734           obrot2(1,i-2)=cos2
2735           obrot2(2,i-2)=sin2
2736           Ug(1,1,i-2)=-cos1
2737           Ug(1,2,i-2)=-sin1
2738           Ug(2,1,i-2)=-sin1
2739           Ug(2,2,i-2)= cos1
2740           Ug2(1,1,i-2)=-cos2
2741           Ug2(1,2,i-2)=-sin2
2742           Ug2(2,1,i-2)=-sin2
2743           Ug2(2,2,i-2)= cos2
2744         else
2745           costab(i-2)=1.0d0
2746           sintab(i-2)=0.0d0
2747           obrot(1,i-2)=1.0d0
2748           obrot(2,i-2)=0.0d0
2749           obrot2(1,i-2)=0.0d0
2750           obrot2(2,i-2)=0.0d0
2751           Ug(1,1,i-2)=1.0d0
2752           Ug(1,2,i-2)=0.0d0
2753           Ug(2,1,i-2)=0.0d0
2754           Ug(2,2,i-2)=1.0d0
2755           Ug2(1,1,i-2)=0.0d0
2756           Ug2(1,2,i-2)=0.0d0
2757           Ug2(2,1,i-2)=0.0d0
2758           Ug2(2,2,i-2)=0.0d0
2759         endif
2760         if (i .gt. 3 .and. i .lt. nres+1) then
2761           obrot_der(1,i-2)=-sin1
2762           obrot_der(2,i-2)= cos1
2763           Ugder(1,1,i-2)= sin1
2764           Ugder(1,2,i-2)=-cos1
2765           Ugder(2,1,i-2)=-cos1
2766           Ugder(2,2,i-2)=-sin1
2767           dwacos2=cos2+cos2
2768           dwasin2=sin2+sin2
2769           obrot2_der(1,i-2)=-dwasin2
2770           obrot2_der(2,i-2)= dwacos2
2771           Ug2der(1,1,i-2)= dwasin2
2772           Ug2der(1,2,i-2)=-dwacos2
2773           Ug2der(2,1,i-2)=-dwacos2
2774           Ug2der(2,2,i-2)=-dwasin2
2775         else
2776           obrot_der(1,i-2)=0.0d0
2777           obrot_der(2,i-2)=0.0d0
2778           Ugder(1,1,i-2)=0.0d0
2779           Ugder(1,2,i-2)=0.0d0
2780           Ugder(2,1,i-2)=0.0d0
2781           Ugder(2,2,i-2)=0.0d0
2782           obrot2_der(1,i-2)=0.0d0
2783           obrot2_der(2,i-2)=0.0d0
2784           Ug2der(1,1,i-2)=0.0d0
2785           Ug2der(1,2,i-2)=0.0d0
2786           Ug2der(2,1,i-2)=0.0d0
2787           Ug2der(2,2,i-2)=0.0d0
2788         endif
2789 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2790         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2791           iti = itortyp(itype(i-2))
2792         else
2793           iti=ntortyp
2794         endif
2795 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2796         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2797           iti1 = itortyp(itype(i-1))
2798         else
2799           iti1=ntortyp
2800         endif
2801 cd        write (iout,*) '*******i',i,' iti1',iti
2802 cd        write (iout,*) 'b1',b1(:,iti)
2803 cd        write (iout,*) 'b2',b2(:,iti)
2804 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2805 c        if (i .gt. iatel_s+2) then
2806         if (i .gt. nnt+2) then
2807           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2808 #ifdef NEWCORR
2809           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2810 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2811 #endif
2812 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2813 c     &    EE(1,2,iti),EE(2,2,iti)
2814           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2815           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2816 c          write(iout,*) "Macierz EUG",
2817 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2818 c     &    eug(2,2,i-2)
2819           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2820      &    then
2821           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2822           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2823           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2824           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2825           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2826           endif
2827         else
2828           do k=1,2
2829             Ub2(k,i-2)=0.0d0
2830             Ctobr(k,i-2)=0.0d0
2831             Dtobr2(k,i-2)=0.0d0
2832             do l=1,2
2833               EUg(l,k,i-2)=0.0d0
2834               CUg(l,k,i-2)=0.0d0
2835               DUg(l,k,i-2)=0.0d0
2836               DtUg2(l,k,i-2)=0.0d0
2837             enddo
2838           enddo
2839         endif
2840         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2841         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2842         do k=1,2
2843           muder(k,i-2)=Ub2der(k,i-2)
2844         enddo
2845 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2846         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2847           if (itype(i-1).le.ntyp) then
2848             iti1 = itortyp(itype(i-1))
2849           else
2850             iti1=ntortyp
2851           endif
2852         else
2853           iti1=ntortyp
2854         endif
2855         do k=1,2
2856           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2857         enddo
2858 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2859 cd        write (iout,*) 'mu1',mu1(:,i-2)
2860 cd        write (iout,*) 'mu2',mu2(:,i-2)
2861         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2862      &  then
2863         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2864         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2865         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2866         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2867         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2868 C Vectors and matrices dependent on a single virtual-bond dihedral.
2869         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2870         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2871         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2872         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2873         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2874         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2875         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2876         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2877         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2878         endif
2879       enddo
2880 C Matrices dependent on two consecutive virtual-bond dihedrals.
2881 C The order of matrices is from left to right.
2882       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2883      &then
2884 c      do i=max0(ivec_start,2),ivec_end
2885       do i=2,nres-1
2886         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2887         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2888         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2889         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2890         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2891         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2892         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2893         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2894       enddo
2895       endif
2896 #if defined(MPI) && defined(PARMAT)
2897 #ifdef DEBUG
2898 c      if (fg_rank.eq.0) then
2899         write (iout,*) "Arrays UG and UGDER before GATHER"
2900         do i=1,nres-1
2901           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2902      &     ((ug(l,k,i),l=1,2),k=1,2),
2903      &     ((ugder(l,k,i),l=1,2),k=1,2)
2904         enddo
2905         write (iout,*) "Arrays UG2 and UG2DER"
2906         do i=1,nres-1
2907           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2908      &     ((ug2(l,k,i),l=1,2),k=1,2),
2909      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2910         enddo
2911         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2912         do i=1,nres-1
2913           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2914      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2915      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2916         enddo
2917         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2918         do i=1,nres-1
2919           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2920      &     costab(i),sintab(i),costab2(i),sintab2(i)
2921         enddo
2922         write (iout,*) "Array MUDER"
2923         do i=1,nres-1
2924           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2925         enddo
2926 c      endif
2927 #endif
2928       if (nfgtasks.gt.1) then
2929         time00=MPI_Wtime()
2930 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2931 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2932 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2933 #ifdef MATGATHER
2934         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2935      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2936      &   FG_COMM1,IERR)
2937         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2938      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2939      &   FG_COMM1,IERR)
2940         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2941      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2942      &   FG_COMM1,IERR)
2943         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2944      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2945      &   FG_COMM1,IERR)
2946         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2947      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2948      &   FG_COMM1,IERR)
2949         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2950      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2951      &   FG_COMM1,IERR)
2952         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2953      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2954      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2955         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2956      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2957      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2958         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2959      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2960      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2961         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2962      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2963      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2964         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2965      &  then
2966         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2967      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2968      &   FG_COMM1,IERR)
2969         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2970      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2971      &   FG_COMM1,IERR)
2972         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2973      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2974      &   FG_COMM1,IERR)
2975        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2976      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2977      &   FG_COMM1,IERR)
2978         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2979      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2980      &   FG_COMM1,IERR)
2981         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2982      &   ivec_count(fg_rank1),
2983      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2984      &   FG_COMM1,IERR)
2985         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2986      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2987      &   FG_COMM1,IERR)
2988         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2989      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2990      &   FG_COMM1,IERR)
2991         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2992      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2993      &   FG_COMM1,IERR)
2994         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2995      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2996      &   FG_COMM1,IERR)
2997         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2998      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2999      &   FG_COMM1,IERR)
3000         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3001      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3002      &   FG_COMM1,IERR)
3003         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3004      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3005      &   FG_COMM1,IERR)
3006         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3007      &   ivec_count(fg_rank1),
3008      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3009      &   FG_COMM1,IERR)
3010         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3011      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3012      &   FG_COMM1,IERR)
3013        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3014      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3015      &   FG_COMM1,IERR)
3016         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3017      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3018      &   FG_COMM1,IERR)
3019        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3020      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3021      &   FG_COMM1,IERR)
3022         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3023      &   ivec_count(fg_rank1),
3024      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3025      &   FG_COMM1,IERR)
3026         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3027      &   ivec_count(fg_rank1),
3028      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3029      &   FG_COMM1,IERR)
3030         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3031      &   ivec_count(fg_rank1),
3032      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3033      &   MPI_MAT2,FG_COMM1,IERR)
3034         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3035      &   ivec_count(fg_rank1),
3036      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3037      &   MPI_MAT2,FG_COMM1,IERR)
3038         endif
3039 #else
3040 c Passes matrix info through the ring
3041       isend=fg_rank1
3042       irecv=fg_rank1-1
3043       if (irecv.lt.0) irecv=nfgtasks1-1
3044       iprev=irecv
3045       inext=fg_rank1+1
3046       if (inext.ge.nfgtasks1) inext=0
3047       do i=1,nfgtasks1-1
3048 c        write (iout,*) "isend",isend," irecv",irecv
3049 c        call flush(iout)
3050         lensend=lentyp(isend)
3051         lenrecv=lentyp(irecv)
3052 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3053 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3054 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3055 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3056 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3057 c        write (iout,*) "Gather ROTAT1"
3058 c        call flush(iout)
3059 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3060 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3061 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3062 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3063 c        write (iout,*) "Gather ROTAT2"
3064 c        call flush(iout)
3065         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3066      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3067      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3068      &   iprev,4400+irecv,FG_COMM,status,IERR)
3069 c        write (iout,*) "Gather ROTAT_OLD"
3070 c        call flush(iout)
3071         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3072      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3073      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3074      &   iprev,5500+irecv,FG_COMM,status,IERR)
3075 c        write (iout,*) "Gather PRECOMP11"
3076 c        call flush(iout)
3077         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3078      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3079      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3080      &   iprev,6600+irecv,FG_COMM,status,IERR)
3081 c        write (iout,*) "Gather PRECOMP12"
3082 c        call flush(iout)
3083         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3084      &  then
3085         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3086      &   MPI_ROTAT2(lensend),inext,7700+isend,
3087      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3088      &   iprev,7700+irecv,FG_COMM,status,IERR)
3089 c        write (iout,*) "Gather PRECOMP21"
3090 c        call flush(iout)
3091         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3092      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3093      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3094      &   iprev,8800+irecv,FG_COMM,status,IERR)
3095 c        write (iout,*) "Gather PRECOMP22"
3096 c        call flush(iout)
3097         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3098      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3099      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3100      &   MPI_PRECOMP23(lenrecv),
3101      &   iprev,9900+irecv,FG_COMM,status,IERR)
3102 c        write (iout,*) "Gather PRECOMP23"
3103 c        call flush(iout)
3104         endif
3105         isend=irecv
3106         irecv=irecv-1
3107         if (irecv.lt.0) irecv=nfgtasks1-1
3108       enddo
3109 #endif
3110         time_gather=time_gather+MPI_Wtime()-time00
3111       endif
3112 #ifdef DEBUG
3113 c      if (fg_rank.eq.0) then
3114         write (iout,*) "Arrays UG and UGDER"
3115         do i=1,nres-1
3116           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3117      &     ((ug(l,k,i),l=1,2),k=1,2),
3118      &     ((ugder(l,k,i),l=1,2),k=1,2)
3119         enddo
3120         write (iout,*) "Arrays UG2 and UG2DER"
3121         do i=1,nres-1
3122           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3123      &     ((ug2(l,k,i),l=1,2),k=1,2),
3124      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3125         enddo
3126         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3127         do i=1,nres-1
3128           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3129      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3130      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3131         enddo
3132         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3133         do i=1,nres-1
3134           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3135      &     costab(i),sintab(i),costab2(i),sintab2(i)
3136         enddo
3137         write (iout,*) "Array MUDER"
3138         do i=1,nres-1
3139           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3140         enddo
3141 c      endif
3142 #endif
3143 #endif
3144 cd      do i=1,nres
3145 cd        iti = itortyp(itype(i))
3146 cd        write (iout,*) i
3147 cd        do j=1,2
3148 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3149 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3150 cd        enddo
3151 cd      enddo
3152       return
3153       end
3154 C--------------------------------------------------------------------------
3155       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3156 C
3157 C This subroutine calculates the average interaction energy and its gradient
3158 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3159 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3160 C The potential depends both on the distance of peptide-group centers and on
3161 C the orientation of the CA-CA virtual bonds.
3162 C
3163       implicit real*8 (a-h,o-z)
3164 #ifdef MPI
3165       include 'mpif.h'
3166 #endif
3167       include 'DIMENSIONS'
3168       include 'COMMON.CONTROL'
3169       include 'COMMON.SETUP'
3170       include 'COMMON.IOUNITS'
3171       include 'COMMON.GEO'
3172       include 'COMMON.VAR'
3173       include 'COMMON.LOCAL'
3174       include 'COMMON.CHAIN'
3175       include 'COMMON.DERIV'
3176       include 'COMMON.INTERACT'
3177       include 'COMMON.CONTACTS'
3178       include 'COMMON.TORSION'
3179       include 'COMMON.VECTORS'
3180       include 'COMMON.FFIELD'
3181       include 'COMMON.TIME1'
3182       include 'COMMON.SPLITELE'
3183       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3184      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3185       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3186      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3187       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3188      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3189      &    num_conti,j1,j2
3190 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3191 #ifdef MOMENT
3192       double precision scal_el /1.0d0/
3193 #else
3194       double precision scal_el /0.5d0/
3195 #endif
3196 C 12/13/98
3197 C 13-go grudnia roku pamietnego...
3198       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3199      &                   0.0d0,1.0d0,0.0d0,
3200      &                   0.0d0,0.0d0,1.0d0/
3201 cd      write(iout,*) 'In EELEC'
3202 cd      do i=1,nloctyp
3203 cd        write(iout,*) 'Type',i
3204 cd        write(iout,*) 'B1',B1(:,i)
3205 cd        write(iout,*) 'B2',B2(:,i)
3206 cd        write(iout,*) 'CC',CC(:,:,i)
3207 cd        write(iout,*) 'DD',DD(:,:,i)
3208 cd        write(iout,*) 'EE',EE(:,:,i)
3209 cd      enddo
3210 cd      call check_vecgrad
3211 cd      stop
3212       if (icheckgrad.eq.1) then
3213         do i=1,nres-1
3214           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3215           do k=1,3
3216             dc_norm(k,i)=dc(k,i)*fac
3217           enddo
3218 c          write (iout,*) 'i',i,' fac',fac
3219         enddo
3220       endif
3221       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3222      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3223      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3224 c        call vec_and_deriv
3225 #ifdef TIMING
3226         time01=MPI_Wtime()
3227 #endif
3228         call set_matrices
3229 #ifdef TIMING
3230         time_mat=time_mat+MPI_Wtime()-time01
3231 #endif
3232       endif
3233 cd      do i=1,nres-1
3234 cd        write (iout,*) 'i=',i
3235 cd        do k=1,3
3236 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3237 cd        enddo
3238 cd        do k=1,3
3239 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3240 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3241 cd        enddo
3242 cd      enddo
3243       t_eelecij=0.0d0
3244       ees=0.0D0
3245       evdw1=0.0D0
3246       eel_loc=0.0d0
3247       eello_turn3=0.0d0
3248       eello_turn4=0.0d0
3249       ind=0
3250       do i=1,nres
3251         num_cont_hb(i)=0
3252       enddo
3253 cd      print '(a)','Enter EELEC'
3254 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3255       do i=1,nres
3256         gel_loc_loc(i)=0.0d0
3257         gcorr_loc(i)=0.0d0
3258       enddo
3259 c
3260 c
3261 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3262 C
3263 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3264 C
3265 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3266       do i=iturn3_start,iturn3_end
3267         if (i.le.1) cycle
3268 C        write(iout,*) "tu jest i",i
3269         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3270      &  .or. itype(i+2).eq.ntyp1
3271      &  .or. itype(i+3).eq.ntyp1
3272      &  .or. itype(i-1).eq.ntyp1
3273      &  .or. itype(i+4).eq.ntyp1
3274      &  ) cycle
3275         dxi=dc(1,i)
3276         dyi=dc(2,i)
3277         dzi=dc(3,i)
3278         dx_normi=dc_norm(1,i)
3279         dy_normi=dc_norm(2,i)
3280         dz_normi=dc_norm(3,i)
3281         xmedi=c(1,i)+0.5d0*dxi
3282         ymedi=c(2,i)+0.5d0*dyi
3283         zmedi=c(3,i)+0.5d0*dzi
3284           xmedi=mod(xmedi,boxxsize)
3285           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3286           ymedi=mod(ymedi,boxysize)
3287           if (ymedi.lt.0) ymedi=ymedi+boxysize
3288           zmedi=mod(zmedi,boxzsize)
3289           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3290         num_conti=0
3291         call eelecij(i,i+2,ees,evdw1,eel_loc)
3292         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3293         num_cont_hb(i)=num_conti
3294       enddo
3295       do i=iturn4_start,iturn4_end
3296         if (i.le.1) cycle
3297         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3298      &    .or. itype(i+3).eq.ntyp1
3299      &    .or. itype(i+4).eq.ntyp1
3300      &    .or. itype(i+5).eq.ntyp1
3301      &    .or. itype(i).eq.ntyp1
3302      &    .or. itype(i-1).eq.ntyp1
3303      &                             ) cycle
3304         dxi=dc(1,i)
3305         dyi=dc(2,i)
3306         dzi=dc(3,i)
3307         dx_normi=dc_norm(1,i)
3308         dy_normi=dc_norm(2,i)
3309         dz_normi=dc_norm(3,i)
3310         xmedi=c(1,i)+0.5d0*dxi
3311         ymedi=c(2,i)+0.5d0*dyi
3312         zmedi=c(3,i)+0.5d0*dzi
3313 C Return atom into box, boxxsize is size of box in x dimension
3314 c  194   continue
3315 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3316 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3317 C Condition for being inside the proper box
3318 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3319 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3320 c        go to 194
3321 c        endif
3322 c  195   continue
3323 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3324 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3325 C Condition for being inside the proper box
3326 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3327 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3328 c        go to 195
3329 c        endif
3330 c  196   continue
3331 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3332 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3333 C Condition for being inside the proper box
3334 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3335 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3336 c        go to 196
3337 c        endif
3338           xmedi=mod(xmedi,boxxsize)
3339           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3340           ymedi=mod(ymedi,boxysize)
3341           if (ymedi.lt.0) ymedi=ymedi+boxysize
3342           zmedi=mod(zmedi,boxzsize)
3343           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3344
3345         num_conti=num_cont_hb(i)
3346 c        write(iout,*) "JESTEM W PETLI"
3347         call eelecij(i,i+3,ees,evdw1,eel_loc)
3348         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3349      &   call eturn4(i,eello_turn4)
3350         num_cont_hb(i)=num_conti
3351       enddo   ! i
3352 C Loop over all neighbouring boxes
3353 C      do xshift=-1,1
3354 C      do yshift=-1,1
3355 C      do zshift=-1,1
3356 c
3357 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3358 c
3359       do i=iatel_s,iatel_e
3360         if (i.le.1) cycle
3361         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3362      &  .or. itype(i+2).eq.ntyp1
3363      &  .or. itype(i-1).eq.ntyp1
3364      &                ) cycle
3365         dxi=dc(1,i)
3366         dyi=dc(2,i)
3367         dzi=dc(3,i)
3368         dx_normi=dc_norm(1,i)
3369         dy_normi=dc_norm(2,i)
3370         dz_normi=dc_norm(3,i)
3371         xmedi=c(1,i)+0.5d0*dxi
3372         ymedi=c(2,i)+0.5d0*dyi
3373         zmedi=c(3,i)+0.5d0*dzi
3374           xmedi=mod(xmedi,boxxsize)
3375           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3376           ymedi=mod(ymedi,boxysize)
3377           if (ymedi.lt.0) ymedi=ymedi+boxysize
3378           zmedi=mod(zmedi,boxzsize)
3379           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3380 C          xmedi=xmedi+xshift*boxxsize
3381 C          ymedi=ymedi+yshift*boxysize
3382 C          zmedi=zmedi+zshift*boxzsize
3383
3384 C Return tom into box, boxxsize is size of box in x dimension
3385 c  164   continue
3386 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3387 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3388 C Condition for being inside the proper box
3389 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3390 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3391 c        go to 164
3392 c        endif
3393 c  165   continue
3394 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3395 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3396 C Condition for being inside the proper box
3397 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3398 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3399 c        go to 165
3400 c        endif
3401 c  166   continue
3402 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3403 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3404 cC Condition for being inside the proper box
3405 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3406 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3407 c        go to 166
3408 c        endif
3409
3410 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3411         num_conti=num_cont_hb(i)
3412         do j=ielstart(i),ielend(i)
3413 C          write (iout,*) i,j
3414          if (j.le.1) cycle
3415           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3416      & .or.itype(j+2).eq.ntyp1
3417      & .or.itype(j-1).eq.ntyp1
3418      &) cycle
3419           call eelecij(i,j,ees,evdw1,eel_loc)
3420         enddo ! j
3421         num_cont_hb(i)=num_conti
3422       enddo   ! i
3423 C     enddo   ! zshift
3424 C      enddo   ! yshift
3425 C      enddo   ! xshift
3426
3427 c      write (iout,*) "Number of loop steps in EELEC:",ind
3428 cd      do i=1,nres
3429 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3430 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3431 cd      enddo
3432 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3433 ccc      eel_loc=eel_loc+eello_turn3
3434 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3435       return
3436       end
3437 C-------------------------------------------------------------------------------
3438       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3439       implicit real*8 (a-h,o-z)
3440       include 'DIMENSIONS'
3441 #ifdef MPI
3442       include "mpif.h"
3443 #endif
3444       include 'COMMON.CONTROL'
3445       include 'COMMON.IOUNITS'
3446       include 'COMMON.GEO'
3447       include 'COMMON.VAR'
3448       include 'COMMON.LOCAL'
3449       include 'COMMON.CHAIN'
3450       include 'COMMON.DERIV'
3451       include 'COMMON.INTERACT'
3452       include 'COMMON.CONTACTS'
3453       include 'COMMON.TORSION'
3454       include 'COMMON.VECTORS'
3455       include 'COMMON.FFIELD'
3456       include 'COMMON.TIME1'
3457       include 'COMMON.SPLITELE'
3458       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3459      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3460       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3461      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3462      &    gmuij2(4),gmuji2(4)
3463       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3464      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3465      &    num_conti,j1,j2
3466 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3467 #ifdef MOMENT
3468       double precision scal_el /1.0d0/
3469 #else
3470       double precision scal_el /0.5d0/
3471 #endif
3472 C 12/13/98
3473 C 13-go grudnia roku pamietnego...
3474       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3475      &                   0.0d0,1.0d0,0.0d0,
3476      &                   0.0d0,0.0d0,1.0d0/
3477 c          time00=MPI_Wtime()
3478 cd      write (iout,*) "eelecij",i,j
3479 c          ind=ind+1
3480           iteli=itel(i)
3481           itelj=itel(j)
3482           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3483           aaa=app(iteli,itelj)
3484           bbb=bpp(iteli,itelj)
3485           ael6i=ael6(iteli,itelj)
3486           ael3i=ael3(iteli,itelj)
3487           dxj=dc(1,j)
3488           dyj=dc(2,j)
3489           dzj=dc(3,j)
3490           dx_normj=dc_norm(1,j)
3491           dy_normj=dc_norm(2,j)
3492           dz_normj=dc_norm(3,j)
3493 C          xj=c(1,j)+0.5D0*dxj-xmedi
3494 C          yj=c(2,j)+0.5D0*dyj-ymedi
3495 C          zj=c(3,j)+0.5D0*dzj-zmedi
3496           xj=c(1,j)+0.5D0*dxj
3497           yj=c(2,j)+0.5D0*dyj
3498           zj=c(3,j)+0.5D0*dzj
3499           xj=mod(xj,boxxsize)
3500           if (xj.lt.0) xj=xj+boxxsize
3501           yj=mod(yj,boxysize)
3502           if (yj.lt.0) yj=yj+boxysize
3503           zj=mod(zj,boxzsize)
3504           if (zj.lt.0) zj=zj+boxzsize
3505           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3506       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3507       xj_safe=xj
3508       yj_safe=yj
3509       zj_safe=zj
3510       isubchap=0
3511       do xshift=-1,1
3512       do yshift=-1,1
3513       do zshift=-1,1
3514           xj=xj_safe+xshift*boxxsize
3515           yj=yj_safe+yshift*boxysize
3516           zj=zj_safe+zshift*boxzsize
3517           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3518           if(dist_temp.lt.dist_init) then
3519             dist_init=dist_temp
3520             xj_temp=xj
3521             yj_temp=yj
3522             zj_temp=zj
3523             isubchap=1
3524           endif
3525        enddo
3526        enddo
3527        enddo
3528        if (isubchap.eq.1) then
3529           xj=xj_temp-xmedi
3530           yj=yj_temp-ymedi
3531           zj=zj_temp-zmedi
3532        else
3533           xj=xj_safe-xmedi
3534           yj=yj_safe-ymedi
3535           zj=zj_safe-zmedi
3536        endif
3537 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3538 c  174   continue
3539 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3540 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3541 C Condition for being inside the proper box
3542 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3543 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3544 c        go to 174
3545 c        endif
3546 c  175   continue
3547 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3548 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3549 C Condition for being inside the proper box
3550 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3551 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3552 c        go to 175
3553 c        endif
3554 c  176   continue
3555 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3556 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3557 C Condition for being inside the proper box
3558 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3559 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3560 c        go to 176
3561 c        endif
3562 C        endif !endPBC condintion
3563 C        xj=xj-xmedi
3564 C        yj=yj-ymedi
3565 C        zj=zj-zmedi
3566           rij=xj*xj+yj*yj+zj*zj
3567
3568             sss=sscale(sqrt(rij))
3569             sssgrad=sscagrad(sqrt(rij))
3570 c            if (sss.gt.0.0d0) then
3571           rrmij=1.0D0/rij
3572           rij=dsqrt(rij)
3573           rmij=1.0D0/rij
3574           r3ij=rrmij*rmij
3575           r6ij=r3ij*r3ij
3576           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3577           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3578           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3579           fac=cosa-3.0D0*cosb*cosg
3580           ev1=aaa*r6ij*r6ij
3581 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3582           if (j.eq.i+2) ev1=scal_el*ev1
3583           ev2=bbb*r6ij
3584           fac3=ael6i*r6ij
3585           fac4=ael3i*r3ij
3586           evdwij=(ev1+ev2)
3587           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3588           el2=fac4*fac
3589 C MARYSIA
3590           eesij=(el1+el2)
3591 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3592           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3593           ees=ees+eesij
3594           evdw1=evdw1+evdwij*sss
3595 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3596 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3597 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3598 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3599
3600           if (energy_dec) then
3601               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3602      &'evdw1',i,j,evdwij
3603      &,iteli,itelj,aaa,evdw1
3604               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3605           endif
3606
3607 C
3608 C Calculate contributions to the Cartesian gradient.
3609 C
3610 #ifdef SPLITELE
3611           facvdw=-6*rrmij*(ev1+evdwij)*sss
3612           facel=-3*rrmij*(el1+eesij)
3613           fac1=fac
3614           erij(1)=xj*rmij
3615           erij(2)=yj*rmij
3616           erij(3)=zj*rmij
3617 *
3618 * Radial derivatives. First process both termini of the fragment (i,j)
3619 *
3620           ggg(1)=facel*xj
3621           ggg(2)=facel*yj
3622           ggg(3)=facel*zj
3623 c          do k=1,3
3624 c            ghalf=0.5D0*ggg(k)
3625 c            gelc(k,i)=gelc(k,i)+ghalf
3626 c            gelc(k,j)=gelc(k,j)+ghalf
3627 c          enddo
3628 c 9/28/08 AL Gradient compotents will be summed only at the end
3629           do k=1,3
3630             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3631             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3632           enddo
3633 *
3634 * Loop over residues i+1 thru j-1.
3635 *
3636 cgrad          do k=i+1,j-1
3637 cgrad            do l=1,3
3638 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3639 cgrad            enddo
3640 cgrad          enddo
3641           if (sss.gt.0.0) then
3642           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3643           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3644           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3645           else
3646           ggg(1)=0.0
3647           ggg(2)=0.0
3648           ggg(3)=0.0
3649           endif
3650 c          do k=1,3
3651 c            ghalf=0.5D0*ggg(k)
3652 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3653 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3654 c          enddo
3655 c 9/28/08 AL Gradient compotents will be summed only at the end
3656           do k=1,3
3657             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3658             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3659           enddo
3660 *
3661 * Loop over residues i+1 thru j-1.
3662 *
3663 cgrad          do k=i+1,j-1
3664 cgrad            do l=1,3
3665 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3666 cgrad            enddo
3667 cgrad          enddo
3668 #else
3669 C MARYSIA
3670           facvdw=(ev1+evdwij)*sss
3671           facel=(el1+eesij)
3672           fac1=fac
3673           fac=-3*rrmij*(facvdw+facvdw+facel)
3674           erij(1)=xj*rmij
3675           erij(2)=yj*rmij
3676           erij(3)=zj*rmij
3677 *
3678 * Radial derivatives. First process both termini of the fragment (i,j)
3679 *
3680           ggg(1)=fac*xj
3681           ggg(2)=fac*yj
3682           ggg(3)=fac*zj
3683 c          do k=1,3
3684 c            ghalf=0.5D0*ggg(k)
3685 c            gelc(k,i)=gelc(k,i)+ghalf
3686 c            gelc(k,j)=gelc(k,j)+ghalf
3687 c          enddo
3688 c 9/28/08 AL Gradient compotents will be summed only at the end
3689           do k=1,3
3690             gelc_long(k,j)=gelc(k,j)+ggg(k)
3691             gelc_long(k,i)=gelc(k,i)-ggg(k)
3692           enddo
3693 *
3694 * Loop over residues i+1 thru j-1.
3695 *
3696 cgrad          do k=i+1,j-1
3697 cgrad            do l=1,3
3698 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3699 cgrad            enddo
3700 cgrad          enddo
3701 c 9/28/08 AL Gradient compotents will be summed only at the end
3702           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3703           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3704           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3705           do k=1,3
3706             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3707             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3708           enddo
3709 #endif
3710 *
3711 * Angular part
3712 *
3713           ecosa=2.0D0*fac3*fac1+fac4
3714           fac4=-3.0D0*fac4
3715           fac3=-6.0D0*fac3
3716           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3717           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3718           do k=1,3
3719             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3720             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3721           enddo
3722 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3723 cd   &          (dcosg(k),k=1,3)
3724           do k=1,3
3725             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3726           enddo
3727 c          do k=1,3
3728 c            ghalf=0.5D0*ggg(k)
3729 c            gelc(k,i)=gelc(k,i)+ghalf
3730 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3731 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3732 c            gelc(k,j)=gelc(k,j)+ghalf
3733 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3734 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3735 c          enddo
3736 cgrad          do k=i+1,j-1
3737 cgrad            do l=1,3
3738 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3739 cgrad            enddo
3740 cgrad          enddo
3741           do k=1,3
3742             gelc(k,i)=gelc(k,i)
3743      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3744      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3745             gelc(k,j)=gelc(k,j)
3746      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3747      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3748             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3749             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3750           enddo
3751 C MARYSIA
3752 c          endif !sscale
3753           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3754      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3755      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3756 C
3757 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3758 C   energy of a peptide unit is assumed in the form of a second-order
3759 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3760 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3761 C   are computed for EVERY pair of non-contiguous peptide groups.
3762 C
3763
3764           if (j.lt.nres-1) then
3765             j1=j+1
3766             j2=j-1
3767           else
3768             j1=j-1
3769             j2=j-2
3770           endif
3771           kkk=0
3772           lll=0
3773           do k=1,2
3774             do l=1,2
3775               kkk=kkk+1
3776               muij(kkk)=mu(k,i)*mu(l,j)
3777 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3778 #ifdef NEWCORR
3779              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3780 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3781              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3782              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3783 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3784              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3785 #endif
3786             enddo
3787           enddo
3788 cd         write (iout,*) 'EELEC: i',i,' j',j
3789 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3790 cd          write(iout,*) 'muij',muij
3791           ury=scalar(uy(1,i),erij)
3792           urz=scalar(uz(1,i),erij)
3793           vry=scalar(uy(1,j),erij)
3794           vrz=scalar(uz(1,j),erij)
3795           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3796           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3797           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3798           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3799           fac=dsqrt(-ael6i)*r3ij
3800           a22=a22*fac
3801           a23=a23*fac
3802           a32=a32*fac
3803           a33=a33*fac
3804 cd          write (iout,'(4i5,4f10.5)')
3805 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3806 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3807 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3808 cd     &      uy(:,j),uz(:,j)
3809 cd          write (iout,'(4f10.5)')
3810 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3811 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3812 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3813 cd           write (iout,'(9f10.5/)')
3814 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3815 C Derivatives of the elements of A in virtual-bond vectors
3816           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3817           do k=1,3
3818             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3819             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3820             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3821             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3822             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3823             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3824             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3825             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3826             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3827             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3828             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3829             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3830           enddo
3831 C Compute radial contributions to the gradient
3832           facr=-3.0d0*rrmij
3833           a22der=a22*facr
3834           a23der=a23*facr
3835           a32der=a32*facr
3836           a33der=a33*facr
3837           agg(1,1)=a22der*xj
3838           agg(2,1)=a22der*yj
3839           agg(3,1)=a22der*zj
3840           agg(1,2)=a23der*xj
3841           agg(2,2)=a23der*yj
3842           agg(3,2)=a23der*zj
3843           agg(1,3)=a32der*xj
3844           agg(2,3)=a32der*yj
3845           agg(3,3)=a32der*zj
3846           agg(1,4)=a33der*xj
3847           agg(2,4)=a33der*yj
3848           agg(3,4)=a33der*zj
3849 C Add the contributions coming from er
3850           fac3=-3.0d0*fac
3851           do k=1,3
3852             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3853             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3854             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3855             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3856           enddo
3857           do k=1,3
3858 C Derivatives in DC(i)
3859 cgrad            ghalf1=0.5d0*agg(k,1)
3860 cgrad            ghalf2=0.5d0*agg(k,2)
3861 cgrad            ghalf3=0.5d0*agg(k,3)
3862 cgrad            ghalf4=0.5d0*agg(k,4)
3863             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3864      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3865             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3866      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3867             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3868      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3869             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3870      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3871 C Derivatives in DC(i+1)
3872             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3873      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3874             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3875      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3876             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3877      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3878             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3879      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3880 C Derivatives in DC(j)
3881             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3882      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3883             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3884      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3885             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3886      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3887             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3888      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3889 C Derivatives in DC(j+1) or DC(nres-1)
3890             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3891      &      -3.0d0*vryg(k,3)*ury)
3892             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3893      &      -3.0d0*vrzg(k,3)*ury)
3894             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3895      &      -3.0d0*vryg(k,3)*urz)
3896             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3897      &      -3.0d0*vrzg(k,3)*urz)
3898 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3899 cgrad              do l=1,4
3900 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3901 cgrad              enddo
3902 cgrad            endif
3903           enddo
3904           acipa(1,1)=a22
3905           acipa(1,2)=a23
3906           acipa(2,1)=a32
3907           acipa(2,2)=a33
3908           a22=-a22
3909           a23=-a23
3910           do l=1,2
3911             do k=1,3
3912               agg(k,l)=-agg(k,l)
3913               aggi(k,l)=-aggi(k,l)
3914               aggi1(k,l)=-aggi1(k,l)
3915               aggj(k,l)=-aggj(k,l)
3916               aggj1(k,l)=-aggj1(k,l)
3917             enddo
3918           enddo
3919           if (j.lt.nres-1) then
3920             a22=-a22
3921             a32=-a32
3922             do l=1,3,2
3923               do k=1,3
3924                 agg(k,l)=-agg(k,l)
3925                 aggi(k,l)=-aggi(k,l)
3926                 aggi1(k,l)=-aggi1(k,l)
3927                 aggj(k,l)=-aggj(k,l)
3928                 aggj1(k,l)=-aggj1(k,l)
3929               enddo
3930             enddo
3931           else
3932             a22=-a22
3933             a23=-a23
3934             a32=-a32
3935             a33=-a33
3936             do l=1,4
3937               do k=1,3
3938                 agg(k,l)=-agg(k,l)
3939                 aggi(k,l)=-aggi(k,l)
3940                 aggi1(k,l)=-aggi1(k,l)
3941                 aggj(k,l)=-aggj(k,l)
3942                 aggj1(k,l)=-aggj1(k,l)
3943               enddo
3944             enddo
3945           endif
3946           ENDIF ! WCORR
3947           IF (wel_loc.gt.0.0d0) THEN
3948 C Contribution to the local-electrostatic energy coming from the i-j pair
3949           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3950      &     +a33*muij(4)
3951 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3952 c     &                     ' eel_loc_ij',eel_loc_ij
3953 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3954 C Calculate patrial derivative for theta angle
3955 #ifdef NEWCORR
3956          geel_loc_ij=a22*gmuij1(1)
3957      &     +a23*gmuij1(2)
3958      &     +a32*gmuij1(3)
3959      &     +a33*gmuij1(4)
3960 c         write(iout,*) "derivative over thatai"
3961 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3962 c     &   a33*gmuij1(4)
3963          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3964      &      geel_loc_ij*wel_loc
3965 c         write(iout,*) "derivative over thatai-1"
3966 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3967 c     &   a33*gmuij2(4)
3968          geel_loc_ij=
3969      &     a22*gmuij2(1)
3970      &     +a23*gmuij2(2)
3971      &     +a32*gmuij2(3)
3972      &     +a33*gmuij2(4)
3973          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3974      &      geel_loc_ij*wel_loc
3975 c  Derivative over j residue
3976          geel_loc_ji=a22*gmuji1(1)
3977      &     +a23*gmuji1(2)
3978      &     +a32*gmuji1(3)
3979      &     +a33*gmuji1(4)
3980 c         write(iout,*) "derivative over thataj"
3981 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3982 c     &   a33*gmuji1(4)
3983
3984         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3985      &      geel_loc_ji*wel_loc
3986          geel_loc_ji=
3987      &     +a22*gmuji2(1)
3988      &     +a23*gmuji2(2)
3989      &     +a32*gmuji2(3)
3990      &     +a33*gmuji2(4)
3991 c         write(iout,*) "derivative over thataj-1"
3992 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3993 c     &   a33*gmuji2(4)
3994          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3995      &      geel_loc_ji*wel_loc
3996 #endif
3997 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3998
3999           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4000      &            'eelloc',i,j,eel_loc_ij
4001 c           if (eel_loc_ij.ne.0)
4002 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4003 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4004
4005           eel_loc=eel_loc+eel_loc_ij
4006 C Partial derivatives in virtual-bond dihedral angles gamma
4007           if (i.gt.1)
4008      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4009      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4010      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4011           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4012      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4013      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4014 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4015           do l=1,3
4016             ggg(l)=agg(l,1)*muij(1)+
4017      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4018             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4019             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4020 cgrad            ghalf=0.5d0*ggg(l)
4021 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4022 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4023           enddo
4024 cgrad          do k=i+1,j2
4025 cgrad            do l=1,3
4026 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4027 cgrad            enddo
4028 cgrad          enddo
4029 C Remaining derivatives of eello
4030           do l=1,3
4031             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4032      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4033             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4034      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4035             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4036      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4037             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4038      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4039           enddo
4040           ENDIF
4041 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4042 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4043           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4044      &       .and. num_conti.le.maxconts) then
4045 c            write (iout,*) i,j," entered corr"
4046 C
4047 C Calculate the contact function. The ith column of the array JCONT will
4048 C contain the numbers of atoms that make contacts with the atom I (of numbers
4049 C greater than I). The arrays FACONT and GACONT will contain the values of
4050 C the contact function and its derivative.
4051 c           r0ij=1.02D0*rpp(iteli,itelj)
4052 c           r0ij=1.11D0*rpp(iteli,itelj)
4053             r0ij=2.20D0*rpp(iteli,itelj)
4054 c           r0ij=1.55D0*rpp(iteli,itelj)
4055             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4056             if (fcont.gt.0.0D0) then
4057               num_conti=num_conti+1
4058               if (num_conti.gt.maxconts) then
4059                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4060      &                         ' will skip next contacts for this conf.'
4061               else
4062                 jcont_hb(num_conti,i)=j
4063 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4064 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4065                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4066      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4067 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4068 C  terms.
4069                 d_cont(num_conti,i)=rij
4070 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4071 C     --- Electrostatic-interaction matrix ---
4072                 a_chuj(1,1,num_conti,i)=a22
4073                 a_chuj(1,2,num_conti,i)=a23
4074                 a_chuj(2,1,num_conti,i)=a32
4075                 a_chuj(2,2,num_conti,i)=a33
4076 C     --- Gradient of rij
4077                 do kkk=1,3
4078                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4079                 enddo
4080                 kkll=0
4081                 do k=1,2
4082                   do l=1,2
4083                     kkll=kkll+1
4084                     do m=1,3
4085                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4086                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4087                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4088                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4089                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4090                     enddo
4091                   enddo
4092                 enddo
4093                 ENDIF
4094                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4095 C Calculate contact energies
4096                 cosa4=4.0D0*cosa
4097                 wij=cosa-3.0D0*cosb*cosg
4098                 cosbg1=cosb+cosg
4099                 cosbg2=cosb-cosg
4100 c               fac3=dsqrt(-ael6i)/r0ij**3
4101                 fac3=dsqrt(-ael6i)*r3ij
4102 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4103                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4104                 if (ees0tmp.gt.0) then
4105                   ees0pij=dsqrt(ees0tmp)
4106                 else
4107                   ees0pij=0
4108                 endif
4109 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4110                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4111                 if (ees0tmp.gt.0) then
4112                   ees0mij=dsqrt(ees0tmp)
4113                 else
4114                   ees0mij=0
4115                 endif
4116 c               ees0mij=0.0D0
4117                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4118                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4119 C Diagnostics. Comment out or remove after debugging!
4120 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4121 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4122 c               ees0m(num_conti,i)=0.0D0
4123 C End diagnostics.
4124 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4125 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4126 C Angular derivatives of the contact function
4127                 ees0pij1=fac3/ees0pij
4128                 ees0mij1=fac3/ees0mij
4129                 fac3p=-3.0D0*fac3*rrmij
4130                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4131                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4132 c               ees0mij1=0.0D0
4133                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4134                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4135                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4136                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4137                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4138                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4139                 ecosap=ecosa1+ecosa2
4140                 ecosbp=ecosb1+ecosb2
4141                 ecosgp=ecosg1+ecosg2
4142                 ecosam=ecosa1-ecosa2
4143                 ecosbm=ecosb1-ecosb2
4144                 ecosgm=ecosg1-ecosg2
4145 C Diagnostics
4146 c               ecosap=ecosa1
4147 c               ecosbp=ecosb1
4148 c               ecosgp=ecosg1
4149 c               ecosam=0.0D0
4150 c               ecosbm=0.0D0
4151 c               ecosgm=0.0D0
4152 C End diagnostics
4153                 facont_hb(num_conti,i)=fcont
4154                 fprimcont=fprimcont/rij
4155 cd              facont_hb(num_conti,i)=1.0D0
4156 C Following line is for diagnostics.
4157 cd              fprimcont=0.0D0
4158                 do k=1,3
4159                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4160                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4161                 enddo
4162                 do k=1,3
4163                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4164                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4165                 enddo
4166                 gggp(1)=gggp(1)+ees0pijp*xj
4167                 gggp(2)=gggp(2)+ees0pijp*yj
4168                 gggp(3)=gggp(3)+ees0pijp*zj
4169                 gggm(1)=gggm(1)+ees0mijp*xj
4170                 gggm(2)=gggm(2)+ees0mijp*yj
4171                 gggm(3)=gggm(3)+ees0mijp*zj
4172 C Derivatives due to the contact function
4173                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4174                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4175                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4176                 do k=1,3
4177 c
4178 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4179 c          following the change of gradient-summation algorithm.
4180 c
4181 cgrad                  ghalfp=0.5D0*gggp(k)
4182 cgrad                  ghalfm=0.5D0*gggm(k)
4183                   gacontp_hb1(k,num_conti,i)=!ghalfp
4184      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4185      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4186                   gacontp_hb2(k,num_conti,i)=!ghalfp
4187      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4188      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4189                   gacontp_hb3(k,num_conti,i)=gggp(k)
4190                   gacontm_hb1(k,num_conti,i)=!ghalfm
4191      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4192      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4193                   gacontm_hb2(k,num_conti,i)=!ghalfm
4194      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4195      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4196                   gacontm_hb3(k,num_conti,i)=gggm(k)
4197                 enddo
4198 C Diagnostics. Comment out or remove after debugging!
4199 cdiag           do k=1,3
4200 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4201 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4202 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4203 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4204 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4205 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4206 cdiag           enddo
4207               ENDIF ! wcorr
4208               endif  ! num_conti.le.maxconts
4209             endif  ! fcont.gt.0
4210           endif    ! j.gt.i+1
4211           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4212             do k=1,4
4213               do l=1,3
4214                 ghalf=0.5d0*agg(l,k)
4215                 aggi(l,k)=aggi(l,k)+ghalf
4216                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4217                 aggj(l,k)=aggj(l,k)+ghalf
4218               enddo
4219             enddo
4220             if (j.eq.nres-1 .and. i.lt.j-2) then
4221               do k=1,4
4222                 do l=1,3
4223                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4224                 enddo
4225               enddo
4226             endif
4227           endif
4228 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4229       return
4230       end
4231 C-----------------------------------------------------------------------------
4232       subroutine eturn3(i,eello_turn3)
4233 C Third- and fourth-order contributions from turns
4234       implicit real*8 (a-h,o-z)
4235       include 'DIMENSIONS'
4236       include 'COMMON.IOUNITS'
4237       include 'COMMON.GEO'
4238       include 'COMMON.VAR'
4239       include 'COMMON.LOCAL'
4240       include 'COMMON.CHAIN'
4241       include 'COMMON.DERIV'
4242       include 'COMMON.INTERACT'
4243       include 'COMMON.CONTACTS'
4244       include 'COMMON.TORSION'
4245       include 'COMMON.VECTORS'
4246       include 'COMMON.FFIELD'
4247       include 'COMMON.CONTROL'
4248       dimension ggg(3)
4249       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4250      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4251      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4252      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4253      &  auxgmat2(2,2),auxgmatt2(2,2)
4254       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4255      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4256       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4257      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4258      &    num_conti,j1,j2
4259       j=i+2
4260 c      write (iout,*) "eturn3",i,j,j1,j2
4261       a_temp(1,1)=a22
4262       a_temp(1,2)=a23
4263       a_temp(2,1)=a32
4264       a_temp(2,2)=a33
4265 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4266 C
4267 C               Third-order contributions
4268 C
4269 C                 (i+2)o----(i+3)
4270 C                      | |
4271 C                      | |
4272 C                 (i+1)o----i
4273 C
4274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4275 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4276         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4277 c auxalary matices for theta gradient
4278 c auxalary matrix for i+1 and constant i+2
4279         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4280 c auxalary matrix for i+2 and constant i+1
4281         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4282         call transpose2(auxmat(1,1),auxmat1(1,1))
4283         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4284         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4285         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4286         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4287         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4288         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4289 C Derivatives in theta
4290         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4291      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4292         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4293      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4294
4295         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4296      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4297 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4298 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4299 cd     &    ' eello_turn3_num',4*eello_turn3_num
4300 C Derivatives in gamma(i)
4301         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4302         call transpose2(auxmat2(1,1),auxmat3(1,1))
4303         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4304         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4305 C Derivatives in gamma(i+1)
4306         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4307         call transpose2(auxmat2(1,1),auxmat3(1,1))
4308         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4309         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4310      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4311 C Cartesian derivatives
4312         do l=1,3
4313 c            ghalf1=0.5d0*agg(l,1)
4314 c            ghalf2=0.5d0*agg(l,2)
4315 c            ghalf3=0.5d0*agg(l,3)
4316 c            ghalf4=0.5d0*agg(l,4)
4317           a_temp(1,1)=aggi(l,1)!+ghalf1
4318           a_temp(1,2)=aggi(l,2)!+ghalf2
4319           a_temp(2,1)=aggi(l,3)!+ghalf3
4320           a_temp(2,2)=aggi(l,4)!+ghalf4
4321           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4322           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4323      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4324           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4325           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4326           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4327           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4328           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4329           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4330      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4331           a_temp(1,1)=aggj(l,1)!+ghalf1
4332           a_temp(1,2)=aggj(l,2)!+ghalf2
4333           a_temp(2,1)=aggj(l,3)!+ghalf3
4334           a_temp(2,2)=aggj(l,4)!+ghalf4
4335           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4336           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4337      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4338           a_temp(1,1)=aggj1(l,1)
4339           a_temp(1,2)=aggj1(l,2)
4340           a_temp(2,1)=aggj1(l,3)
4341           a_temp(2,2)=aggj1(l,4)
4342           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4343           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4344      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4345         enddo
4346       return
4347       end
4348 C-------------------------------------------------------------------------------
4349       subroutine eturn4(i,eello_turn4)
4350 C Third- and fourth-order contributions from turns
4351       implicit real*8 (a-h,o-z)
4352       include 'DIMENSIONS'
4353       include 'COMMON.IOUNITS'
4354       include 'COMMON.GEO'
4355       include 'COMMON.VAR'
4356       include 'COMMON.LOCAL'
4357       include 'COMMON.CHAIN'
4358       include 'COMMON.DERIV'
4359       include 'COMMON.INTERACT'
4360       include 'COMMON.CONTACTS'
4361       include 'COMMON.TORSION'
4362       include 'COMMON.VECTORS'
4363       include 'COMMON.FFIELD'
4364       include 'COMMON.CONTROL'
4365       dimension ggg(3)
4366       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4367      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4368      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4369      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4370      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4371      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4372      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4373       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4374      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4375       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4376      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4377      &    num_conti,j1,j2
4378       j=i+3
4379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4380 C
4381 C               Fourth-order contributions
4382 C
4383 C                 (i+3)o----(i+4)
4384 C                     /  |
4385 C               (i+2)o   |
4386 C                     \  |
4387 C                 (i+1)o----i
4388 C
4389 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4390 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4391 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4392 c        write(iout,*)"WCHODZE W PROGRAM"
4393         a_temp(1,1)=a22
4394         a_temp(1,2)=a23
4395         a_temp(2,1)=a32
4396         a_temp(2,2)=a33
4397         iti1=itortyp(itype(i+1))
4398         iti2=itortyp(itype(i+2))
4399         iti3=itortyp(itype(i+3))
4400 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4401         call transpose2(EUg(1,1,i+1),e1t(1,1))
4402         call transpose2(Eug(1,1,i+2),e2t(1,1))
4403         call transpose2(Eug(1,1,i+3),e3t(1,1))
4404 C Ematrix derivative in theta
4405         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4406         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4407         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4408         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4409 c       eta1 in derivative theta
4410         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4411         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4412 c       auxgvec is derivative of Ub2 so i+3 theta
4413         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4414 c       auxalary matrix of E i+1
4415         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4416 c        s1=0.0
4417 c        gs1=0.0
4418         s1=scalar2(b1(1,i+2),auxvec(1))
4419 c derivative of theta i+2 with constant i+3
4420         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4421 c derivative of theta i+2 with constant i+2
4422         gs32=scalar2(b1(1,i+2),auxgvec(1))
4423 c derivative of E matix in theta of i+1
4424         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4425
4426         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4427 c       ea31 in derivative theta
4428         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4429         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4430 c auxilary matrix auxgvec of Ub2 with constant E matirx
4431         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4432 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4433         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4434
4435 c        s2=0.0
4436 c        gs2=0.0
4437         s2=scalar2(b1(1,i+1),auxvec(1))
4438 c derivative of theta i+1 with constant i+3
4439         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4440 c derivative of theta i+2 with constant i+1
4441         gs21=scalar2(b1(1,i+1),auxgvec(1))
4442 c derivative of theta i+3 with constant i+1
4443         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4444 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4445 c     &  gtb1(1,i+1)
4446         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4447 c two derivatives over diffetent matrices
4448 c gtae3e2 is derivative over i+3
4449         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4450 c ae3gte2 is derivative over i+2
4451         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4452         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4453 c three possible derivative over theta E matices
4454 c i+1
4455         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4456 c i+2
4457         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4458 c i+3
4459         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4460         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4461
4462         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4463         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4464         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4465
4466         eello_turn4=eello_turn4-(s1+s2+s3)
4467 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4468         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4469      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4470 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4471 cd     &    ' eello_turn4_num',8*eello_turn4_num
4472 #ifdef NEWCORR
4473         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4474      &                  -(gs13+gsE13+gsEE1)*wturn4
4475         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4476      &                    -(gs23+gs21+gsEE2)*wturn4
4477         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4478      &                    -(gs32+gsE31+gsEE3)*wturn4
4479 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4480 c     &   gs2
4481 #endif
4482         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4483      &      'eturn4',i,j,-(s1+s2+s3)
4484 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4485 c     &    ' eello_turn4_num',8*eello_turn4_num
4486 C Derivatives in gamma(i)
4487         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4488         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4489         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4490         s1=scalar2(b1(1,i+2),auxvec(1))
4491         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4492         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4493         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4494 C Derivatives in gamma(i+1)
4495         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4496         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4497         s2=scalar2(b1(1,i+1),auxvec(1))
4498         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4499         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4500         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4501         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4502 C Derivatives in gamma(i+2)
4503         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4504         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4505         s1=scalar2(b1(1,i+2),auxvec(1))
4506         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4507         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4508         s2=scalar2(b1(1,i+1),auxvec(1))
4509         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4510         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4511         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4512         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4513 C Cartesian derivatives
4514 C Derivatives of this turn contributions in DC(i+2)
4515         if (j.lt.nres-1) then
4516           do l=1,3
4517             a_temp(1,1)=agg(l,1)
4518             a_temp(1,2)=agg(l,2)
4519             a_temp(2,1)=agg(l,3)
4520             a_temp(2,2)=agg(l,4)
4521             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4522             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4523             s1=scalar2(b1(1,i+2),auxvec(1))
4524             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4525             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4526             s2=scalar2(b1(1,i+1),auxvec(1))
4527             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4528             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4529             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4530             ggg(l)=-(s1+s2+s3)
4531             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4532           enddo
4533         endif
4534 C Remaining derivatives of this turn contribution
4535         do l=1,3
4536           a_temp(1,1)=aggi(l,1)
4537           a_temp(1,2)=aggi(l,2)
4538           a_temp(2,1)=aggi(l,3)
4539           a_temp(2,2)=aggi(l,4)
4540           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4541           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4542           s1=scalar2(b1(1,i+2),auxvec(1))
4543           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4544           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4545           s2=scalar2(b1(1,i+1),auxvec(1))
4546           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4547           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4548           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4549           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4550           a_temp(1,1)=aggi1(l,1)
4551           a_temp(1,2)=aggi1(l,2)
4552           a_temp(2,1)=aggi1(l,3)
4553           a_temp(2,2)=aggi1(l,4)
4554           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4555           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4556           s1=scalar2(b1(1,i+2),auxvec(1))
4557           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4558           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4559           s2=scalar2(b1(1,i+1),auxvec(1))
4560           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4561           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4562           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4563           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4564           a_temp(1,1)=aggj(l,1)
4565           a_temp(1,2)=aggj(l,2)
4566           a_temp(2,1)=aggj(l,3)
4567           a_temp(2,2)=aggj(l,4)
4568           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4569           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4570           s1=scalar2(b1(1,i+2),auxvec(1))
4571           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4572           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4573           s2=scalar2(b1(1,i+1),auxvec(1))
4574           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4575           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4576           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4577           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4578           a_temp(1,1)=aggj1(l,1)
4579           a_temp(1,2)=aggj1(l,2)
4580           a_temp(2,1)=aggj1(l,3)
4581           a_temp(2,2)=aggj1(l,4)
4582           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4583           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4584           s1=scalar2(b1(1,i+2),auxvec(1))
4585           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4586           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4587           s2=scalar2(b1(1,i+1),auxvec(1))
4588           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4589           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4590           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4591 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4592           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4593         enddo
4594       return
4595       end
4596 C-----------------------------------------------------------------------------
4597       subroutine vecpr(u,v,w)
4598       implicit real*8(a-h,o-z)
4599       dimension u(3),v(3),w(3)
4600       w(1)=u(2)*v(3)-u(3)*v(2)
4601       w(2)=-u(1)*v(3)+u(3)*v(1)
4602       w(3)=u(1)*v(2)-u(2)*v(1)
4603       return
4604       end
4605 C-----------------------------------------------------------------------------
4606       subroutine unormderiv(u,ugrad,unorm,ungrad)
4607 C This subroutine computes the derivatives of a normalized vector u, given
4608 C the derivatives computed without normalization conditions, ugrad. Returns
4609 C ungrad.
4610       implicit none
4611       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4612       double precision vec(3)
4613       double precision scalar
4614       integer i,j
4615 c      write (2,*) 'ugrad',ugrad
4616 c      write (2,*) 'u',u
4617       do i=1,3
4618         vec(i)=scalar(ugrad(1,i),u(1))
4619       enddo
4620 c      write (2,*) 'vec',vec
4621       do i=1,3
4622         do j=1,3
4623           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4624         enddo
4625       enddo
4626 c      write (2,*) 'ungrad',ungrad
4627       return
4628       end
4629 C-----------------------------------------------------------------------------
4630       subroutine escp_soft_sphere(evdw2,evdw2_14)
4631 C
4632 C This subroutine calculates the excluded-volume interaction energy between
4633 C peptide-group centers and side chains and its gradient in virtual-bond and
4634 C side-chain vectors.
4635 C
4636       implicit real*8 (a-h,o-z)
4637       include 'DIMENSIONS'
4638       include 'COMMON.GEO'
4639       include 'COMMON.VAR'
4640       include 'COMMON.LOCAL'
4641       include 'COMMON.CHAIN'
4642       include 'COMMON.DERIV'
4643       include 'COMMON.INTERACT'
4644       include 'COMMON.FFIELD'
4645       include 'COMMON.IOUNITS'
4646       include 'COMMON.CONTROL'
4647       dimension ggg(3)
4648       evdw2=0.0D0
4649       evdw2_14=0.0d0
4650       r0_scp=4.5d0
4651 cd    print '(a)','Enter ESCP'
4652 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4653 C      do xshift=-1,1
4654 C      do yshift=-1,1
4655 C      do zshift=-1,1
4656       do i=iatscp_s,iatscp_e
4657         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4658         iteli=itel(i)
4659         xi=0.5D0*(c(1,i)+c(1,i+1))
4660         yi=0.5D0*(c(2,i)+c(2,i+1))
4661         zi=0.5D0*(c(3,i)+c(3,i+1))
4662 C Return atom into box, boxxsize is size of box in x dimension
4663 c  134   continue
4664 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4665 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4666 C Condition for being inside the proper box
4667 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4668 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4669 c        go to 134
4670 c        endif
4671 c  135   continue
4672 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4673 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4674 C Condition for being inside the proper box
4675 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4676 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4677 c        go to 135
4678 c c       endif
4679 c  136   continue
4680 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4681 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4682 cC Condition for being inside the proper box
4683 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4684 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4685 c        go to 136
4686 c        endif
4687           xi=mod(xi,boxxsize)
4688           if (xi.lt.0) xi=xi+boxxsize
4689           yi=mod(yi,boxysize)
4690           if (yi.lt.0) yi=yi+boxysize
4691           zi=mod(zi,boxzsize)
4692           if (zi.lt.0) zi=zi+boxzsize
4693 C          xi=xi+xshift*boxxsize
4694 C          yi=yi+yshift*boxysize
4695 C          zi=zi+zshift*boxzsize
4696         do iint=1,nscp_gr(i)
4697
4698         do j=iscpstart(i,iint),iscpend(i,iint)
4699           if (itype(j).eq.ntyp1) cycle
4700           itypj=iabs(itype(j))
4701 C Uncomment following three lines for SC-p interactions
4702 c         xj=c(1,nres+j)-xi
4703 c         yj=c(2,nres+j)-yi
4704 c         zj=c(3,nres+j)-zi
4705 C Uncomment following three lines for Ca-p interactions
4706           xj=c(1,j)
4707           yj=c(2,j)
4708           zj=c(3,j)
4709 c  174   continue
4710 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4711 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4712 C Condition for being inside the proper box
4713 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4714 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4715 c        go to 174
4716 c        endif
4717 c  175   continue
4718 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4719 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4720 cC Condition for being inside the proper box
4721 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4722 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4723 c        go to 175
4724 c        endif
4725 c  176   continue
4726 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4727 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4728 C Condition for being inside the proper box
4729 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4730 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4731 c        go to 176
4732           xj=mod(xj,boxxsize)
4733           if (xj.lt.0) xj=xj+boxxsize
4734           yj=mod(yj,boxysize)
4735           if (yj.lt.0) yj=yj+boxysize
4736           zj=mod(zj,boxzsize)
4737           if (zj.lt.0) zj=zj+boxzsize
4738       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4739       xj_safe=xj
4740       yj_safe=yj
4741       zj_safe=zj
4742       subchap=0
4743       do xshift=-1,1
4744       do yshift=-1,1
4745       do zshift=-1,1
4746           xj=xj_safe+xshift*boxxsize
4747           yj=yj_safe+yshift*boxysize
4748           zj=zj_safe+zshift*boxzsize
4749           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4750           if(dist_temp.lt.dist_init) then
4751             dist_init=dist_temp
4752             xj_temp=xj
4753             yj_temp=yj
4754             zj_temp=zj
4755             subchap=1
4756           endif
4757        enddo
4758        enddo
4759        enddo
4760        if (subchap.eq.1) then
4761           xj=xj_temp-xi
4762           yj=yj_temp-yi
4763           zj=zj_temp-zi
4764        else
4765           xj=xj_safe-xi
4766           yj=yj_safe-yi
4767           zj=zj_safe-zi
4768        endif
4769 c c       endif
4770 C          xj=xj-xi
4771 C          yj=yj-yi
4772 C          zj=zj-zi
4773           rij=xj*xj+yj*yj+zj*zj
4774
4775           r0ij=r0_scp
4776           r0ijsq=r0ij*r0ij
4777           if (rij.lt.r0ijsq) then
4778             evdwij=0.25d0*(rij-r0ijsq)**2
4779             fac=rij-r0ijsq
4780           else
4781             evdwij=0.0d0
4782             fac=0.0d0
4783           endif
4784           evdw2=evdw2+evdwij
4785 C
4786 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4787 C
4788           ggg(1)=xj*fac
4789           ggg(2)=yj*fac
4790           ggg(3)=zj*fac
4791 cgrad          if (j.lt.i) then
4792 cd          write (iout,*) 'j<i'
4793 C Uncomment following three lines for SC-p interactions
4794 c           do k=1,3
4795 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4796 c           enddo
4797 cgrad          else
4798 cd          write (iout,*) 'j>i'
4799 cgrad            do k=1,3
4800 cgrad              ggg(k)=-ggg(k)
4801 C Uncomment following line for SC-p interactions
4802 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4803 cgrad            enddo
4804 cgrad          endif
4805 cgrad          do k=1,3
4806 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4807 cgrad          enddo
4808 cgrad          kstart=min0(i+1,j)
4809 cgrad          kend=max0(i-1,j-1)
4810 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4811 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4812 cgrad          do k=kstart,kend
4813 cgrad            do l=1,3
4814 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4815 cgrad            enddo
4816 cgrad          enddo
4817           do k=1,3
4818             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4819             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4820           enddo
4821         enddo
4822
4823         enddo ! iint
4824       enddo ! i
4825 C      enddo !zshift
4826 C      enddo !yshift
4827 C      enddo !xshift
4828       return
4829       end
4830 C-----------------------------------------------------------------------------
4831       subroutine escp(evdw2,evdw2_14)
4832 C
4833 C This subroutine calculates the excluded-volume interaction energy between
4834 C peptide-group centers and side chains and its gradient in virtual-bond and
4835 C side-chain vectors.
4836 C
4837       implicit real*8 (a-h,o-z)
4838       include 'DIMENSIONS'
4839       include 'COMMON.GEO'
4840       include 'COMMON.VAR'
4841       include 'COMMON.LOCAL'
4842       include 'COMMON.CHAIN'
4843       include 'COMMON.DERIV'
4844       include 'COMMON.INTERACT'
4845       include 'COMMON.FFIELD'
4846       include 'COMMON.IOUNITS'
4847       include 'COMMON.CONTROL'
4848       include 'COMMON.SPLITELE'
4849       dimension ggg(3)
4850       evdw2=0.0D0
4851       evdw2_14=0.0d0
4852 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4853 cd    print '(a)','Enter ESCP'
4854 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4855 C      do xshift=-1,1
4856 C      do yshift=-1,1
4857 C      do zshift=-1,1
4858       do i=iatscp_s,iatscp_e
4859         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4860         iteli=itel(i)
4861         xi=0.5D0*(c(1,i)+c(1,i+1))
4862         yi=0.5D0*(c(2,i)+c(2,i+1))
4863         zi=0.5D0*(c(3,i)+c(3,i+1))
4864           xi=mod(xi,boxxsize)
4865           if (xi.lt.0) xi=xi+boxxsize
4866           yi=mod(yi,boxysize)
4867           if (yi.lt.0) yi=yi+boxysize
4868           zi=mod(zi,boxzsize)
4869           if (zi.lt.0) zi=zi+boxzsize
4870 c          xi=xi+xshift*boxxsize
4871 c          yi=yi+yshift*boxysize
4872 c          zi=zi+zshift*boxzsize
4873 c        print *,xi,yi,zi,'polozenie i'
4874 C Return atom into box, boxxsize is size of box in x dimension
4875 c  134   continue
4876 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4877 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4878 C Condition for being inside the proper box
4879 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4880 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4881 c        go to 134
4882 c        endif
4883 c  135   continue
4884 c          print *,xi,boxxsize,"pierwszy"
4885
4886 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4887 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4888 C Condition for being inside the proper box
4889 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4890 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4891 c        go to 135
4892 c        endif
4893 c  136   continue
4894 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4895 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4896 C Condition for being inside the proper box
4897 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4898 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4899 c        go to 136
4900 c        endif
4901         do iint=1,nscp_gr(i)
4902
4903         do j=iscpstart(i,iint),iscpend(i,iint)
4904           itypj=iabs(itype(j))
4905           if (itypj.eq.ntyp1) cycle
4906 C Uncomment following three lines for SC-p interactions
4907 c         xj=c(1,nres+j)-xi
4908 c         yj=c(2,nres+j)-yi
4909 c         zj=c(3,nres+j)-zi
4910 C Uncomment following three lines for Ca-p interactions
4911           xj=c(1,j)
4912           yj=c(2,j)
4913           zj=c(3,j)
4914           xj=mod(xj,boxxsize)
4915           if (xj.lt.0) xj=xj+boxxsize
4916           yj=mod(yj,boxysize)
4917           if (yj.lt.0) yj=yj+boxysize
4918           zj=mod(zj,boxzsize)
4919           if (zj.lt.0) zj=zj+boxzsize
4920 c  174   continue
4921 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4922 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4923 C Condition for being inside the proper box
4924 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4925 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4926 c        go to 174
4927 c        endif
4928 c  175   continue
4929 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4930 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4931 cC Condition for being inside the proper box
4932 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4933 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4934 c        go to 175
4935 c        endif
4936 c  176   continue
4937 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4938 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4939 C Condition for being inside the proper box
4940 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4941 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4942 c        go to 176
4943 c        endif
4944 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4945       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4946       xj_safe=xj
4947       yj_safe=yj
4948       zj_safe=zj
4949       subchap=0
4950       do xshift=-1,1
4951       do yshift=-1,1
4952       do zshift=-1,1
4953           xj=xj_safe+xshift*boxxsize
4954           yj=yj_safe+yshift*boxysize
4955           zj=zj_safe+zshift*boxzsize
4956           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4957           if(dist_temp.lt.dist_init) then
4958             dist_init=dist_temp
4959             xj_temp=xj
4960             yj_temp=yj
4961             zj_temp=zj
4962             subchap=1
4963           endif
4964        enddo
4965        enddo
4966        enddo
4967        if (subchap.eq.1) then
4968           xj=xj_temp-xi
4969           yj=yj_temp-yi
4970           zj=zj_temp-zi
4971        else
4972           xj=xj_safe-xi
4973           yj=yj_safe-yi
4974           zj=zj_safe-zi
4975        endif
4976 c          print *,xj,yj,zj,'polozenie j'
4977           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4978 c          print *,rrij
4979           sss=sscale(1.0d0/(dsqrt(rrij)))
4980 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4981 c          if (sss.eq.0) print *,'czasem jest OK'
4982           if (sss.le.0.0d0) cycle
4983           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4984           fac=rrij**expon2
4985           e1=fac*fac*aad(itypj,iteli)
4986           e2=fac*bad(itypj,iteli)
4987           if (iabs(j-i) .le. 2) then
4988             e1=scal14*e1
4989             e2=scal14*e2
4990             evdw2_14=evdw2_14+(e1+e2)*sss
4991           endif
4992           evdwij=e1+e2
4993           evdw2=evdw2+evdwij*sss
4994           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4995      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4996      &       bad(itypj,iteli)
4997 C
4998 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4999 C
5000           fac=-(evdwij+e1)*rrij*sss
5001           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5002           ggg(1)=xj*fac
5003           ggg(2)=yj*fac
5004           ggg(3)=zj*fac
5005 cgrad          if (j.lt.i) then
5006 cd          write (iout,*) 'j<i'
5007 C Uncomment following three lines for SC-p interactions
5008 c           do k=1,3
5009 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5010 c           enddo
5011 cgrad          else
5012 cd          write (iout,*) 'j>i'
5013 cgrad            do k=1,3
5014 cgrad              ggg(k)=-ggg(k)
5015 C Uncomment following line for SC-p interactions
5016 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5017 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5018 cgrad            enddo
5019 cgrad          endif
5020 cgrad          do k=1,3
5021 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5022 cgrad          enddo
5023 cgrad          kstart=min0(i+1,j)
5024 cgrad          kend=max0(i-1,j-1)
5025 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5026 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5027 cgrad          do k=kstart,kend
5028 cgrad            do l=1,3
5029 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5030 cgrad            enddo
5031 cgrad          enddo
5032           do k=1,3
5033             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5034             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5035           enddo
5036 c        endif !endif for sscale cutoff
5037         enddo ! j
5038
5039         enddo ! iint
5040       enddo ! i
5041 c      enddo !zshift
5042 c      enddo !yshift
5043 c      enddo !xshift
5044       do i=1,nct
5045         do j=1,3
5046           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5047           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5048           gradx_scp(j,i)=expon*gradx_scp(j,i)
5049         enddo
5050       enddo
5051 C******************************************************************************
5052 C
5053 C                              N O T E !!!
5054 C
5055 C To save time the factor EXPON has been extracted from ALL components
5056 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5057 C use!
5058 C
5059 C******************************************************************************
5060       return
5061       end
5062 C--------------------------------------------------------------------------
5063       subroutine edis(ehpb)
5064 C
5065 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5066 C
5067       implicit real*8 (a-h,o-z)
5068       include 'DIMENSIONS'
5069       include 'COMMON.SBRIDGE'
5070       include 'COMMON.CHAIN'
5071       include 'COMMON.DERIV'
5072       include 'COMMON.VAR'
5073       include 'COMMON.INTERACT'
5074       include 'COMMON.IOUNITS'
5075       dimension ggg(3)
5076       ehpb=0.0D0
5077 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5078 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5079       if (link_end.eq.0) return
5080       do i=link_start,link_end
5081 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5082 C CA-CA distance used in regularization of structure.
5083         ii=ihpb(i)
5084         jj=jhpb(i)
5085 C iii and jjj point to the residues for which the distance is assigned.
5086         if (ii.gt.nres) then
5087           iii=ii-nres
5088           jjj=jj-nres
5089         else
5090           iii=ii
5091           jjj=jj
5092         endif
5093 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5094 c     &    dhpb(i),dhpb1(i),forcon(i)
5095 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5096 C    distance and angle dependent SS bond potential.
5097 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5098 C     & iabs(itype(jjj)).eq.1) then
5099 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5100 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5101         if (.not.dyn_ss .and. i.le.nss) then
5102 C 15/02/13 CC dynamic SSbond - additional check
5103          if (ii.gt.nres
5104      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5105           call ssbond_ene(iii,jjj,eij)
5106           ehpb=ehpb+2*eij
5107          endif
5108 cd          write (iout,*) "eij",eij
5109         else
5110 C Calculate the distance between the two points and its difference from the
5111 C target distance.
5112           dd=dist(ii,jj)
5113             rdis=dd-dhpb(i)
5114 C Get the force constant corresponding to this distance.
5115             waga=forcon(i)
5116 C Calculate the contribution to energy.
5117             ehpb=ehpb+waga*rdis*rdis
5118 C
5119 C Evaluate gradient.
5120 C
5121             fac=waga*rdis/dd
5122 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5123 cd   &   ' waga=',waga,' fac=',fac
5124             do j=1,3
5125               ggg(j)=fac*(c(j,jj)-c(j,ii))
5126             enddo
5127 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5128 C If this is a SC-SC distance, we need to calculate the contributions to the
5129 C Cartesian gradient in the SC vectors (ghpbx).
5130           if (iii.lt.ii) then
5131           do j=1,3
5132             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5133             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5134           enddo
5135           endif
5136 cgrad        do j=iii,jjj-1
5137 cgrad          do k=1,3
5138 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5139 cgrad          enddo
5140 cgrad        enddo
5141           do k=1,3
5142             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5143             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5144           enddo
5145         endif
5146        endif
5147       enddo
5148       ehpb=0.5D0*ehpb
5149       return
5150       end
5151 C--------------------------------------------------------------------------
5152       subroutine ssbond_ene(i,j,eij)
5153 C
5154 C Calculate the distance and angle dependent SS-bond potential energy
5155 C using a free-energy function derived based on RHF/6-31G** ab initio
5156 C calculations of diethyl disulfide.
5157 C
5158 C A. Liwo and U. Kozlowska, 11/24/03
5159 C
5160       implicit real*8 (a-h,o-z)
5161       include 'DIMENSIONS'
5162       include 'COMMON.SBRIDGE'
5163       include 'COMMON.CHAIN'
5164       include 'COMMON.DERIV'
5165       include 'COMMON.LOCAL'
5166       include 'COMMON.INTERACT'
5167       include 'COMMON.VAR'
5168       include 'COMMON.IOUNITS'
5169       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5170       itypi=iabs(itype(i))
5171       xi=c(1,nres+i)
5172       yi=c(2,nres+i)
5173       zi=c(3,nres+i)
5174       dxi=dc_norm(1,nres+i)
5175       dyi=dc_norm(2,nres+i)
5176       dzi=dc_norm(3,nres+i)
5177 c      dsci_inv=dsc_inv(itypi)
5178       dsci_inv=vbld_inv(nres+i)
5179       itypj=iabs(itype(j))
5180 c      dscj_inv=dsc_inv(itypj)
5181       dscj_inv=vbld_inv(nres+j)
5182       xj=c(1,nres+j)-xi
5183       yj=c(2,nres+j)-yi
5184       zj=c(3,nres+j)-zi
5185       dxj=dc_norm(1,nres+j)
5186       dyj=dc_norm(2,nres+j)
5187       dzj=dc_norm(3,nres+j)
5188       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5189       rij=dsqrt(rrij)
5190       erij(1)=xj*rij
5191       erij(2)=yj*rij
5192       erij(3)=zj*rij
5193       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5194       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5195       om12=dxi*dxj+dyi*dyj+dzi*dzj
5196       do k=1,3
5197         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5198         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5199       enddo
5200       rij=1.0d0/rij
5201       deltad=rij-d0cm
5202       deltat1=1.0d0-om1
5203       deltat2=1.0d0+om2
5204       deltat12=om2-om1+2.0d0
5205       cosphi=om12-om1*om2
5206       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5207      &  +akct*deltad*deltat12
5208      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5209 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5210 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5211 c     &  " deltat12",deltat12," eij",eij
5212       ed=2*akcm*deltad+akct*deltat12
5213       pom1=akct*deltad
5214       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5215       eom1=-2*akth*deltat1-pom1-om2*pom2
5216       eom2= 2*akth*deltat2+pom1-om1*pom2
5217       eom12=pom2
5218       do k=1,3
5219         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5220         ghpbx(k,i)=ghpbx(k,i)-ggk
5221      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5222      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5223         ghpbx(k,j)=ghpbx(k,j)+ggk
5224      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5225      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5226         ghpbc(k,i)=ghpbc(k,i)-ggk
5227         ghpbc(k,j)=ghpbc(k,j)+ggk
5228       enddo
5229 C
5230 C Calculate the components of the gradient in DC and X
5231 C
5232 cgrad      do k=i,j-1
5233 cgrad        do l=1,3
5234 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5235 cgrad        enddo
5236 cgrad      enddo
5237       return
5238       end
5239 C--------------------------------------------------------------------------
5240       subroutine ebond(estr)
5241 c
5242 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5243 c
5244       implicit real*8 (a-h,o-z)
5245       include 'DIMENSIONS'
5246       include 'COMMON.LOCAL'
5247       include 'COMMON.GEO'
5248       include 'COMMON.INTERACT'
5249       include 'COMMON.DERIV'
5250       include 'COMMON.VAR'
5251       include 'COMMON.CHAIN'
5252       include 'COMMON.IOUNITS'
5253       include 'COMMON.NAMES'
5254       include 'COMMON.FFIELD'
5255       include 'COMMON.CONTROL'
5256       include 'COMMON.SETUP'
5257       double precision u(3),ud(3)
5258       estr=0.0d0
5259       estr1=0.0d0
5260       do i=ibondp_start,ibondp_end
5261         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5262 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5263 c          do j=1,3
5264 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5265 c     &      *dc(j,i-1)/vbld(i)
5266 c          enddo
5267 c          if (energy_dec) write(iout,*)
5268 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5269 c        else
5270 C       Checking if it involves dummy (NH3+ or COO-) group
5271          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5272 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5273         diff = vbld(i)-vbldpDUM
5274          else
5275 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5276         diff = vbld(i)-vbldp0
5277          endif
5278         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5279      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5280         estr=estr+diff*diff
5281         do j=1,3
5282           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5283         enddo
5284 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5285 c        endif
5286       enddo
5287       estr=0.5d0*AKP*estr+estr1
5288 c
5289 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5290 c
5291       do i=ibond_start,ibond_end
5292         iti=iabs(itype(i))
5293         if (iti.ne.10 .and. iti.ne.ntyp1) then
5294           nbi=nbondterm(iti)
5295           if (nbi.eq.1) then
5296             diff=vbld(i+nres)-vbldsc0(1,iti)
5297             if (energy_dec)  write (iout,*)
5298      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5299      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5300             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5301             do j=1,3
5302               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5303             enddo
5304           else
5305             do j=1,nbi
5306               diff=vbld(i+nres)-vbldsc0(j,iti)
5307               ud(j)=aksc(j,iti)*diff
5308               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5309             enddo
5310             uprod=u(1)
5311             do j=2,nbi
5312               uprod=uprod*u(j)
5313             enddo
5314             usum=0.0d0
5315             usumsqder=0.0d0
5316             do j=1,nbi
5317               uprod1=1.0d0
5318               uprod2=1.0d0
5319               do k=1,nbi
5320                 if (k.ne.j) then
5321                   uprod1=uprod1*u(k)
5322                   uprod2=uprod2*u(k)*u(k)
5323                 endif
5324               enddo
5325               usum=usum+uprod1
5326               usumsqder=usumsqder+ud(j)*uprod2
5327             enddo
5328             estr=estr+uprod/usum
5329             do j=1,3
5330              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5331             enddo
5332           endif
5333         endif
5334       enddo
5335       return
5336       end
5337 #ifdef CRYST_THETA
5338 C--------------------------------------------------------------------------
5339       subroutine ebend(etheta)
5340 C
5341 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5342 C angles gamma and its derivatives in consecutive thetas and gammas.
5343 C
5344       implicit real*8 (a-h,o-z)
5345       include 'DIMENSIONS'
5346       include 'COMMON.LOCAL'
5347       include 'COMMON.GEO'
5348       include 'COMMON.INTERACT'
5349       include 'COMMON.DERIV'
5350       include 'COMMON.VAR'
5351       include 'COMMON.CHAIN'
5352       include 'COMMON.IOUNITS'
5353       include 'COMMON.NAMES'
5354       include 'COMMON.FFIELD'
5355       include 'COMMON.CONTROL'
5356       common /calcthet/ term1,term2,termm,diffak,ratak,
5357      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5358      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5359       double precision y(2),z(2)
5360       delta=0.02d0*pi
5361 c      time11=dexp(-2*time)
5362 c      time12=1.0d0
5363       etheta=0.0D0
5364 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5365       do i=ithet_start,ithet_end
5366         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5367      &  .or.itype(i).eq.ntyp1) cycle
5368 C Zero the energy function and its derivative at 0 or pi.
5369         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5370         it=itype(i-1)
5371         ichir1=isign(1,itype(i-2))
5372         ichir2=isign(1,itype(i))
5373          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5374          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5375          if (itype(i-1).eq.10) then
5376           itype1=isign(10,itype(i-2))
5377           ichir11=isign(1,itype(i-2))
5378           ichir12=isign(1,itype(i-2))
5379           itype2=isign(10,itype(i))
5380           ichir21=isign(1,itype(i))
5381           ichir22=isign(1,itype(i))
5382          endif
5383
5384         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5385 #ifdef OSF
5386           phii=phi(i)
5387           if (phii.ne.phii) phii=150.0
5388 #else
5389           phii=phi(i)
5390 #endif
5391           y(1)=dcos(phii)
5392           y(2)=dsin(phii)
5393         else
5394           y(1)=0.0D0
5395           y(2)=0.0D0
5396         endif
5397         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5398 #ifdef OSF
5399           phii1=phi(i+1)
5400           if (phii1.ne.phii1) phii1=150.0
5401           phii1=pinorm(phii1)
5402           z(1)=cos(phii1)
5403 #else
5404           phii1=phi(i+1)
5405 #endif
5406           z(1)=dcos(phii1)
5407           z(2)=dsin(phii1)
5408         else
5409           z(1)=0.0D0
5410           z(2)=0.0D0
5411         endif
5412 C Calculate the "mean" value of theta from the part of the distribution
5413 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5414 C In following comments this theta will be referred to as t_c.
5415         thet_pred_mean=0.0d0
5416         do k=1,2
5417             athetk=athet(k,it,ichir1,ichir2)
5418             bthetk=bthet(k,it,ichir1,ichir2)
5419           if (it.eq.10) then
5420              athetk=athet(k,itype1,ichir11,ichir12)
5421              bthetk=bthet(k,itype2,ichir21,ichir22)
5422           endif
5423          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5424 c         write(iout,*) 'chuj tu', y(k),z(k)
5425         enddo
5426         dthett=thet_pred_mean*ssd
5427         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5428 C Derivatives of the "mean" values in gamma1 and gamma2.
5429         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5430      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5431          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5432      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5433          if (it.eq.10) then
5434       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5435      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5436         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5437      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5438          endif
5439         if (theta(i).gt.pi-delta) then
5440           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5441      &         E_tc0)
5442           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5443           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5444           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5445      &        E_theta)
5446           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5447      &        E_tc)
5448         else if (theta(i).lt.delta) then
5449           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5450           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5451           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5452      &        E_theta)
5453           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5454           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5455      &        E_tc)
5456         else
5457           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5458      &        E_theta,E_tc)
5459         endif
5460         etheta=etheta+ethetai
5461         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5462      &      'ebend',i,ethetai,theta(i),itype(i)
5463         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5464         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5465         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5466       enddo
5467 C Ufff.... We've done all this!!!
5468       return
5469       end
5470 C---------------------------------------------------------------------------
5471       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5472      &     E_tc)
5473       implicit real*8 (a-h,o-z)
5474       include 'DIMENSIONS'
5475       include 'COMMON.LOCAL'
5476       include 'COMMON.IOUNITS'
5477       common /calcthet/ term1,term2,termm,diffak,ratak,
5478      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5479      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5480 C Calculate the contributions to both Gaussian lobes.
5481 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5482 C The "polynomial part" of the "standard deviation" of this part of
5483 C the distributioni.
5484 ccc        write (iout,*) thetai,thet_pred_mean
5485         sig=polthet(3,it)
5486         do j=2,0,-1
5487           sig=sig*thet_pred_mean+polthet(j,it)
5488         enddo
5489 C Derivative of the "interior part" of the "standard deviation of the"
5490 C gamma-dependent Gaussian lobe in t_c.
5491         sigtc=3*polthet(3,it)
5492         do j=2,1,-1
5493           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5494         enddo
5495         sigtc=sig*sigtc
5496 C Set the parameters of both Gaussian lobes of the distribution.
5497 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5498         fac=sig*sig+sigc0(it)
5499         sigcsq=fac+fac
5500         sigc=1.0D0/sigcsq
5501 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5502         sigsqtc=-4.0D0*sigcsq*sigtc
5503 c       print *,i,sig,sigtc,sigsqtc
5504 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5505         sigtc=-sigtc/(fac*fac)
5506 C Following variable is sigma(t_c)**(-2)
5507         sigcsq=sigcsq*sigcsq
5508         sig0i=sig0(it)
5509         sig0inv=1.0D0/sig0i**2
5510         delthec=thetai-thet_pred_mean
5511         delthe0=thetai-theta0i
5512         term1=-0.5D0*sigcsq*delthec*delthec
5513         term2=-0.5D0*sig0inv*delthe0*delthe0
5514 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5515 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5516 C NaNs in taking the logarithm. We extract the largest exponent which is added
5517 C to the energy (this being the log of the distribution) at the end of energy
5518 C term evaluation for this virtual-bond angle.
5519         if (term1.gt.term2) then
5520           termm=term1
5521           term2=dexp(term2-termm)
5522           term1=1.0d0
5523         else
5524           termm=term2
5525           term1=dexp(term1-termm)
5526           term2=1.0d0
5527         endif
5528 C The ratio between the gamma-independent and gamma-dependent lobes of
5529 C the distribution is a Gaussian function of thet_pred_mean too.
5530         diffak=gthet(2,it)-thet_pred_mean
5531         ratak=diffak/gthet(3,it)**2
5532         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5533 C Let's differentiate it in thet_pred_mean NOW.
5534         aktc=ak*ratak
5535 C Now put together the distribution terms to make complete distribution.
5536         termexp=term1+ak*term2
5537         termpre=sigc+ak*sig0i
5538 C Contribution of the bending energy from this theta is just the -log of
5539 C the sum of the contributions from the two lobes and the pre-exponential
5540 C factor. Simple enough, isn't it?
5541         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5542 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5543 C NOW the derivatives!!!
5544 C 6/6/97 Take into account the deformation.
5545         E_theta=(delthec*sigcsq*term1
5546      &       +ak*delthe0*sig0inv*term2)/termexp
5547         E_tc=((sigtc+aktc*sig0i)/termpre
5548      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5549      &       aktc*term2)/termexp)
5550       return
5551       end
5552 c-----------------------------------------------------------------------------
5553       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5554       implicit real*8 (a-h,o-z)
5555       include 'DIMENSIONS'
5556       include 'COMMON.LOCAL'
5557       include 'COMMON.IOUNITS'
5558       common /calcthet/ term1,term2,termm,diffak,ratak,
5559      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5560      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5561       delthec=thetai-thet_pred_mean
5562       delthe0=thetai-theta0i
5563 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5564       t3 = thetai-thet_pred_mean
5565       t6 = t3**2
5566       t9 = term1
5567       t12 = t3*sigcsq
5568       t14 = t12+t6*sigsqtc
5569       t16 = 1.0d0
5570       t21 = thetai-theta0i
5571       t23 = t21**2
5572       t26 = term2
5573       t27 = t21*t26
5574       t32 = termexp
5575       t40 = t32**2
5576       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5577      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5578      & *(-t12*t9-ak*sig0inv*t27)
5579       return
5580       end
5581 #else
5582 C--------------------------------------------------------------------------
5583       subroutine ebend(etheta)
5584 C
5585 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5586 C angles gamma and its derivatives in consecutive thetas and gammas.
5587 C ab initio-derived potentials from
5588 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5589 C
5590       implicit real*8 (a-h,o-z)
5591       include 'DIMENSIONS'
5592       include 'COMMON.LOCAL'
5593       include 'COMMON.GEO'
5594       include 'COMMON.INTERACT'
5595       include 'COMMON.DERIV'
5596       include 'COMMON.VAR'
5597       include 'COMMON.CHAIN'
5598       include 'COMMON.IOUNITS'
5599       include 'COMMON.NAMES'
5600       include 'COMMON.FFIELD'
5601       include 'COMMON.CONTROL'
5602       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5603      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5604      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5605      & sinph1ph2(maxdouble,maxdouble)
5606       logical lprn /.false./, lprn1 /.false./
5607       etheta=0.0D0
5608       do i=ithet_start,ithet_end
5609 c        print *,i,itype(i-1),itype(i),itype(i-2)
5610         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5611      &  .or.itype(i).eq.ntyp1) cycle
5612 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5613
5614         if (iabs(itype(i+1)).eq.20) iblock=2
5615         if (iabs(itype(i+1)).ne.20) iblock=1
5616         dethetai=0.0d0
5617         dephii=0.0d0
5618         dephii1=0.0d0
5619         theti2=0.5d0*theta(i)
5620         ityp2=ithetyp((itype(i-1)))
5621         do k=1,nntheterm
5622           coskt(k)=dcos(k*theti2)
5623           sinkt(k)=dsin(k*theti2)
5624         enddo
5625         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5626 #ifdef OSF
5627           phii=phi(i)
5628           if (phii.ne.phii) phii=150.0
5629 #else
5630           phii=phi(i)
5631 #endif
5632           ityp1=ithetyp((itype(i-2)))
5633 C propagation of chirality for glycine type
5634           do k=1,nsingle
5635             cosph1(k)=dcos(k*phii)
5636             sinph1(k)=dsin(k*phii)
5637           enddo
5638         else
5639           phii=0.0d0
5640           ityp1=nthetyp+1
5641           do k=1,nsingle
5642             cosph1(k)=0.0d0
5643             sinph1(k)=0.0d0
5644           enddo
5645         endif
5646         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5647 #ifdef OSF
5648           phii1=phi(i+1)
5649           if (phii1.ne.phii1) phii1=150.0
5650           phii1=pinorm(phii1)
5651 #else
5652           phii1=phi(i+1)
5653 #endif
5654           ityp3=ithetyp((itype(i)))
5655           do k=1,nsingle
5656             cosph2(k)=dcos(k*phii1)
5657             sinph2(k)=dsin(k*phii1)
5658           enddo
5659         else
5660           phii1=0.0d0
5661           ityp3=nthetyp+1
5662           do k=1,nsingle
5663             cosph2(k)=0.0d0
5664             sinph2(k)=0.0d0
5665           enddo
5666         endif
5667         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5668         do k=1,ndouble
5669           do l=1,k-1
5670             ccl=cosph1(l)*cosph2(k-l)
5671             ssl=sinph1(l)*sinph2(k-l)
5672             scl=sinph1(l)*cosph2(k-l)
5673             csl=cosph1(l)*sinph2(k-l)
5674             cosph1ph2(l,k)=ccl-ssl
5675             cosph1ph2(k,l)=ccl+ssl
5676             sinph1ph2(l,k)=scl+csl
5677             sinph1ph2(k,l)=scl-csl
5678           enddo
5679         enddo
5680         if (lprn) then
5681         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5682      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5683         write (iout,*) "coskt and sinkt"
5684         do k=1,nntheterm
5685           write (iout,*) k,coskt(k),sinkt(k)
5686         enddo
5687         endif
5688         do k=1,ntheterm
5689           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5690           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5691      &      *coskt(k)
5692           if (lprn)
5693      &    write (iout,*) "k",k,"
5694      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5695      &     " ethetai",ethetai
5696         enddo
5697         if (lprn) then
5698         write (iout,*) "cosph and sinph"
5699         do k=1,nsingle
5700           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5701         enddo
5702         write (iout,*) "cosph1ph2 and sinph2ph2"
5703         do k=2,ndouble
5704           do l=1,k-1
5705             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5706      &         sinph1ph2(l,k),sinph1ph2(k,l)
5707           enddo
5708         enddo
5709         write(iout,*) "ethetai",ethetai
5710         endif
5711         do m=1,ntheterm2
5712           do k=1,nsingle
5713             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5714      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5715      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5716      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5717             ethetai=ethetai+sinkt(m)*aux
5718             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5719             dephii=dephii+k*sinkt(m)*(
5720      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5721      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5722             dephii1=dephii1+k*sinkt(m)*(
5723      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5724      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5725             if (lprn)
5726      &      write (iout,*) "m",m," k",k," bbthet",
5727      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5728      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5729      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5730      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5731           enddo
5732         enddo
5733         if (lprn)
5734      &  write(iout,*) "ethetai",ethetai
5735         do m=1,ntheterm3
5736           do k=2,ndouble
5737             do l=1,k-1
5738               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5739      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5740      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5741      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5742               ethetai=ethetai+sinkt(m)*aux
5743               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5744               dephii=dephii+l*sinkt(m)*(
5745      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5746      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5747      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5748      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5749               dephii1=dephii1+(k-l)*sinkt(m)*(
5750      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5751      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5752      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5753      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5754               if (lprn) then
5755               write (iout,*) "m",m," k",k," l",l," ffthet",
5756      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5757      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5758      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5759      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5760      &            " ethetai",ethetai
5761               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5762      &            cosph1ph2(k,l)*sinkt(m),
5763      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5764               endif
5765             enddo
5766           enddo
5767         enddo
5768 10      continue
5769 c        lprn1=.true.
5770         if (lprn1)
5771      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5772      &   i,theta(i)*rad2deg,phii*rad2deg,
5773      &   phii1*rad2deg,ethetai
5774 c        lprn1=.false.
5775         etheta=etheta+ethetai
5776         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5777         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5778         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5779       enddo
5780       return
5781       end
5782 #endif
5783 #ifdef CRYST_SC
5784 c-----------------------------------------------------------------------------
5785       subroutine esc(escloc)
5786 C Calculate the local energy of a side chain and its derivatives in the
5787 C corresponding virtual-bond valence angles THETA and the spherical angles
5788 C ALPHA and OMEGA.
5789       implicit real*8 (a-h,o-z)
5790       include 'DIMENSIONS'
5791       include 'COMMON.GEO'
5792       include 'COMMON.LOCAL'
5793       include 'COMMON.VAR'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.DERIV'
5796       include 'COMMON.CHAIN'
5797       include 'COMMON.IOUNITS'
5798       include 'COMMON.NAMES'
5799       include 'COMMON.FFIELD'
5800       include 'COMMON.CONTROL'
5801       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5802      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5803       common /sccalc/ time11,time12,time112,theti,it,nlobit
5804       delta=0.02d0*pi
5805       escloc=0.0D0
5806 c     write (iout,'(a)') 'ESC'
5807       do i=loc_start,loc_end
5808         it=itype(i)
5809         if (it.eq.ntyp1) cycle
5810         if (it.eq.10) goto 1
5811         nlobit=nlob(iabs(it))
5812 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5813 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5814         theti=theta(i+1)-pipol
5815         x(1)=dtan(theti)
5816         x(2)=alph(i)
5817         x(3)=omeg(i)
5818
5819         if (x(2).gt.pi-delta) then
5820           xtemp(1)=x(1)
5821           xtemp(2)=pi-delta
5822           xtemp(3)=x(3)
5823           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5824           xtemp(2)=pi
5825           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5826           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5827      &        escloci,dersc(2))
5828           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5829      &        ddersc0(1),dersc(1))
5830           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5831      &        ddersc0(3),dersc(3))
5832           xtemp(2)=pi-delta
5833           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5834           xtemp(2)=pi
5835           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5836           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5837      &            dersc0(2),esclocbi,dersc02)
5838           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5839      &            dersc12,dersc01)
5840           call splinthet(x(2),0.5d0*delta,ss,ssd)
5841           dersc0(1)=dersc01
5842           dersc0(2)=dersc02
5843           dersc0(3)=0.0d0
5844           do k=1,3
5845             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5846           enddo
5847           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5848 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5849 c    &             esclocbi,ss,ssd
5850           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5851 c         escloci=esclocbi
5852 c         write (iout,*) escloci
5853         else if (x(2).lt.delta) then
5854           xtemp(1)=x(1)
5855           xtemp(2)=delta
5856           xtemp(3)=x(3)
5857           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5858           xtemp(2)=0.0d0
5859           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5860           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5861      &        escloci,dersc(2))
5862           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5863      &        ddersc0(1),dersc(1))
5864           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5865      &        ddersc0(3),dersc(3))
5866           xtemp(2)=delta
5867           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5868           xtemp(2)=0.0d0
5869           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5870           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5871      &            dersc0(2),esclocbi,dersc02)
5872           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5873      &            dersc12,dersc01)
5874           dersc0(1)=dersc01
5875           dersc0(2)=dersc02
5876           dersc0(3)=0.0d0
5877           call splinthet(x(2),0.5d0*delta,ss,ssd)
5878           do k=1,3
5879             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5880           enddo
5881           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5882 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5883 c    &             esclocbi,ss,ssd
5884           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5885 c         write (iout,*) escloci
5886         else
5887           call enesc(x,escloci,dersc,ddummy,.false.)
5888         endif
5889
5890         escloc=escloc+escloci
5891         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5892      &     'escloc',i,escloci
5893 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5894
5895         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5896      &   wscloc*dersc(1)
5897         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5898         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5899     1   continue
5900       enddo
5901       return
5902       end
5903 C---------------------------------------------------------------------------
5904       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5905       implicit real*8 (a-h,o-z)
5906       include 'DIMENSIONS'
5907       include 'COMMON.GEO'
5908       include 'COMMON.LOCAL'
5909       include 'COMMON.IOUNITS'
5910       common /sccalc/ time11,time12,time112,theti,it,nlobit
5911       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5912       double precision contr(maxlob,-1:1)
5913       logical mixed
5914 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5915         escloc_i=0.0D0
5916         do j=1,3
5917           dersc(j)=0.0D0
5918           if (mixed) ddersc(j)=0.0d0
5919         enddo
5920         x3=x(3)
5921
5922 C Because of periodicity of the dependence of the SC energy in omega we have
5923 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5924 C To avoid underflows, first compute & store the exponents.
5925
5926         do iii=-1,1
5927
5928           x(3)=x3+iii*dwapi
5929
5930           do j=1,nlobit
5931             do k=1,3
5932               z(k)=x(k)-censc(k,j,it)
5933             enddo
5934             do k=1,3
5935               Axk=0.0D0
5936               do l=1,3
5937                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5938               enddo
5939               Ax(k,j,iii)=Axk
5940             enddo
5941             expfac=0.0D0
5942             do k=1,3
5943               expfac=expfac+Ax(k,j,iii)*z(k)
5944             enddo
5945             contr(j,iii)=expfac
5946           enddo ! j
5947
5948         enddo ! iii
5949
5950         x(3)=x3
5951 C As in the case of ebend, we want to avoid underflows in exponentiation and
5952 C subsequent NaNs and INFs in energy calculation.
5953 C Find the largest exponent
5954         emin=contr(1,-1)
5955         do iii=-1,1
5956           do j=1,nlobit
5957             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5958           enddo
5959         enddo
5960         emin=0.5D0*emin
5961 cd      print *,'it=',it,' emin=',emin
5962
5963 C Compute the contribution to SC energy and derivatives
5964         do iii=-1,1
5965
5966           do j=1,nlobit
5967 #ifdef OSF
5968             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5969             if(adexp.ne.adexp) adexp=1.0
5970             expfac=dexp(adexp)
5971 #else
5972             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5973 #endif
5974 cd          print *,'j=',j,' expfac=',expfac
5975             escloc_i=escloc_i+expfac
5976             do k=1,3
5977               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5978             enddo
5979             if (mixed) then
5980               do k=1,3,2
5981                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5982      &            +gaussc(k,2,j,it))*expfac
5983               enddo
5984             endif
5985           enddo
5986
5987         enddo ! iii
5988
5989         dersc(1)=dersc(1)/cos(theti)**2
5990         ddersc(1)=ddersc(1)/cos(theti)**2
5991         ddersc(3)=ddersc(3)
5992
5993         escloci=-(dlog(escloc_i)-emin)
5994         do j=1,3
5995           dersc(j)=dersc(j)/escloc_i
5996         enddo
5997         if (mixed) then
5998           do j=1,3,2
5999             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6000           enddo
6001         endif
6002       return
6003       end
6004 C------------------------------------------------------------------------------
6005       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6006       implicit real*8 (a-h,o-z)
6007       include 'DIMENSIONS'
6008       include 'COMMON.GEO'
6009       include 'COMMON.LOCAL'
6010       include 'COMMON.IOUNITS'
6011       common /sccalc/ time11,time12,time112,theti,it,nlobit
6012       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6013       double precision contr(maxlob)
6014       logical mixed
6015
6016       escloc_i=0.0D0
6017
6018       do j=1,3
6019         dersc(j)=0.0D0
6020       enddo
6021
6022       do j=1,nlobit
6023         do k=1,2
6024           z(k)=x(k)-censc(k,j,it)
6025         enddo
6026         z(3)=dwapi
6027         do k=1,3
6028           Axk=0.0D0
6029           do l=1,3
6030             Axk=Axk+gaussc(l,k,j,it)*z(l)
6031           enddo
6032           Ax(k,j)=Axk
6033         enddo
6034         expfac=0.0D0
6035         do k=1,3
6036           expfac=expfac+Ax(k,j)*z(k)
6037         enddo
6038         contr(j)=expfac
6039       enddo ! j
6040
6041 C As in the case of ebend, we want to avoid underflows in exponentiation and
6042 C subsequent NaNs and INFs in energy calculation.
6043 C Find the largest exponent
6044       emin=contr(1)
6045       do j=1,nlobit
6046         if (emin.gt.contr(j)) emin=contr(j)
6047       enddo
6048       emin=0.5D0*emin
6049
6050 C Compute the contribution to SC energy and derivatives
6051
6052       dersc12=0.0d0
6053       do j=1,nlobit
6054         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6055         escloc_i=escloc_i+expfac
6056         do k=1,2
6057           dersc(k)=dersc(k)+Ax(k,j)*expfac
6058         enddo
6059         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6060      &            +gaussc(1,2,j,it))*expfac
6061         dersc(3)=0.0d0
6062       enddo
6063
6064       dersc(1)=dersc(1)/cos(theti)**2
6065       dersc12=dersc12/cos(theti)**2
6066       escloci=-(dlog(escloc_i)-emin)
6067       do j=1,2
6068         dersc(j)=dersc(j)/escloc_i
6069       enddo
6070       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6071       return
6072       end
6073 #else
6074 c----------------------------------------------------------------------------------
6075       subroutine esc(escloc)
6076 C Calculate the local energy of a side chain and its derivatives in the
6077 C corresponding virtual-bond valence angles THETA and the spherical angles
6078 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6079 C added by Urszula Kozlowska. 07/11/2007
6080 C
6081       implicit real*8 (a-h,o-z)
6082       include 'DIMENSIONS'
6083       include 'COMMON.GEO'
6084       include 'COMMON.LOCAL'
6085       include 'COMMON.VAR'
6086       include 'COMMON.SCROT'
6087       include 'COMMON.INTERACT'
6088       include 'COMMON.DERIV'
6089       include 'COMMON.CHAIN'
6090       include 'COMMON.IOUNITS'
6091       include 'COMMON.NAMES'
6092       include 'COMMON.FFIELD'
6093       include 'COMMON.CONTROL'
6094       include 'COMMON.VECTORS'
6095       double precision x_prime(3),y_prime(3),z_prime(3)
6096      &    , sumene,dsc_i,dp2_i,x(65),
6097      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6098      &    de_dxx,de_dyy,de_dzz,de_dt
6099       double precision s1_t,s1_6_t,s2_t,s2_6_t
6100       double precision
6101      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6102      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6103      & dt_dCi(3),dt_dCi1(3)
6104       common /sccalc/ time11,time12,time112,theti,it,nlobit
6105       delta=0.02d0*pi
6106       escloc=0.0D0
6107       do i=loc_start,loc_end
6108         if (itype(i).eq.ntyp1) cycle
6109         costtab(i+1) =dcos(theta(i+1))
6110         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6111         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6112         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6113         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6114         cosfac=dsqrt(cosfac2)
6115         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6116         sinfac=dsqrt(sinfac2)
6117         it=iabs(itype(i))
6118         if (it.eq.10) goto 1
6119 c
6120 C  Compute the axes of tghe local cartesian coordinates system; store in
6121 c   x_prime, y_prime and z_prime
6122 c
6123         do j=1,3
6124           x_prime(j) = 0.00
6125           y_prime(j) = 0.00
6126           z_prime(j) = 0.00
6127         enddo
6128 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6129 C     &   dc_norm(3,i+nres)
6130         do j = 1,3
6131           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6132           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6133         enddo
6134         do j = 1,3
6135           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6136         enddo
6137 c       write (2,*) "i",i
6138 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6139 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6140 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6141 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6142 c      & " xy",scalar(x_prime(1),y_prime(1)),
6143 c      & " xz",scalar(x_prime(1),z_prime(1)),
6144 c      & " yy",scalar(y_prime(1),y_prime(1)),
6145 c      & " yz",scalar(y_prime(1),z_prime(1)),
6146 c      & " zz",scalar(z_prime(1),z_prime(1))
6147 c
6148 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6149 C to local coordinate system. Store in xx, yy, zz.
6150 c
6151         xx=0.0d0
6152         yy=0.0d0
6153         zz=0.0d0
6154         do j = 1,3
6155           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6156           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6157           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6158         enddo
6159
6160         xxtab(i)=xx
6161         yytab(i)=yy
6162         zztab(i)=zz
6163 C
6164 C Compute the energy of the ith side cbain
6165 C
6166 c        write (2,*) "xx",xx," yy",yy," zz",zz
6167         it=iabs(itype(i))
6168         do j = 1,65
6169           x(j) = sc_parmin(j,it)
6170         enddo
6171 #ifdef CHECK_COORD
6172 Cc diagnostics - remove later
6173         xx1 = dcos(alph(2))
6174         yy1 = dsin(alph(2))*dcos(omeg(2))
6175         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6176         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6177      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6178      &    xx1,yy1,zz1
6179 C,"  --- ", xx_w,yy_w,zz_w
6180 c end diagnostics
6181 #endif
6182         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6183      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6184      &   + x(10)*yy*zz
6185         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6186      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6187      & + x(20)*yy*zz
6188         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6189      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6190      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6191      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6192      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6193      &  +x(40)*xx*yy*zz
6194         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6195      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6196      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6197      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6198      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6199      &  +x(60)*xx*yy*zz
6200         dsc_i   = 0.743d0+x(61)
6201         dp2_i   = 1.9d0+x(62)
6202         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6203      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6204         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6205      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6206         s1=(1+x(63))/(0.1d0 + dscp1)
6207         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6208         s2=(1+x(65))/(0.1d0 + dscp2)
6209         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6210         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6211      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6212 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6213 c     &   sumene4,
6214 c     &   dscp1,dscp2,sumene
6215 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6216         escloc = escloc + sumene
6217 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6218 c     & ,zz,xx,yy
6219 c#define DEBUG
6220 #ifdef DEBUG
6221 C
6222 C This section to check the numerical derivatives of the energy of ith side
6223 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6224 C #define DEBUG in the code to turn it on.
6225 C
6226         write (2,*) "sumene               =",sumene
6227         aincr=1.0d-7
6228         xxsave=xx
6229         xx=xx+aincr
6230         write (2,*) xx,yy,zz
6231         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6232         de_dxx_num=(sumenep-sumene)/aincr
6233         xx=xxsave
6234         write (2,*) "xx+ sumene from enesc=",sumenep
6235         yysave=yy
6236         yy=yy+aincr
6237         write (2,*) xx,yy,zz
6238         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6239         de_dyy_num=(sumenep-sumene)/aincr
6240         yy=yysave
6241         write (2,*) "yy+ sumene from enesc=",sumenep
6242         zzsave=zz
6243         zz=zz+aincr
6244         write (2,*) xx,yy,zz
6245         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6246         de_dzz_num=(sumenep-sumene)/aincr
6247         zz=zzsave
6248         write (2,*) "zz+ sumene from enesc=",sumenep
6249         costsave=cost2tab(i+1)
6250         sintsave=sint2tab(i+1)
6251         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6252         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6253         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6254         de_dt_num=(sumenep-sumene)/aincr
6255         write (2,*) " t+ sumene from enesc=",sumenep
6256         cost2tab(i+1)=costsave
6257         sint2tab(i+1)=sintsave
6258 C End of diagnostics section.
6259 #endif
6260 C
6261 C Compute the gradient of esc
6262 C
6263 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6264         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6265         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6266         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6267         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6268         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6269         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6270         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6271         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6272         pom1=(sumene3*sint2tab(i+1)+sumene1)
6273      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6274         pom2=(sumene4*cost2tab(i+1)+sumene2)
6275      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6276         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6277         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6278      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6279      &  +x(40)*yy*zz
6280         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6281         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6282      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6283      &  +x(60)*yy*zz
6284         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6285      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6286      &        +(pom1+pom2)*pom_dx
6287 #ifdef DEBUG
6288         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6289 #endif
6290 C
6291         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6292         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6293      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6294      &  +x(40)*xx*zz
6295         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6296         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6297      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6298      &  +x(59)*zz**2 +x(60)*xx*zz
6299         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6300      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6301      &        +(pom1-pom2)*pom_dy
6302 #ifdef DEBUG
6303         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6304 #endif
6305 C
6306         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6307      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6308      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6309      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6310      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6311      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6312      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6313      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6314 #ifdef DEBUG
6315         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6316 #endif
6317 C
6318         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6319      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6320      &  +pom1*pom_dt1+pom2*pom_dt2
6321 #ifdef DEBUG
6322         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6323 #endif
6324 c#undef DEBUG
6325 c
6326 C
6327        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6328        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6329        cosfac2xx=cosfac2*xx
6330        sinfac2yy=sinfac2*yy
6331        do k = 1,3
6332          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6333      &      vbld_inv(i+1)
6334          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6335      &      vbld_inv(i)
6336          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6337          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6338 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6339 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6340 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6341 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6342          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6343          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6344          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6345          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6346          dZZ_Ci1(k)=0.0d0
6347          dZZ_Ci(k)=0.0d0
6348          do j=1,3
6349            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6350      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6351            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6352      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6353          enddo
6354
6355          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6356          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6357          dZZ_XYZ(k)=vbld_inv(i+nres)*
6358      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6359 c
6360          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6361          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6362        enddo
6363
6364        do k=1,3
6365          dXX_Ctab(k,i)=dXX_Ci(k)
6366          dXX_C1tab(k,i)=dXX_Ci1(k)
6367          dYY_Ctab(k,i)=dYY_Ci(k)
6368          dYY_C1tab(k,i)=dYY_Ci1(k)
6369          dZZ_Ctab(k,i)=dZZ_Ci(k)
6370          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6371          dXX_XYZtab(k,i)=dXX_XYZ(k)
6372          dYY_XYZtab(k,i)=dYY_XYZ(k)
6373          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6374        enddo
6375
6376        do k = 1,3
6377 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6378 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6379 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6380 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6381 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6382 c     &    dt_dci(k)
6383 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6384 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6385          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6386      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6387          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6388      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6389          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6390      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6391        enddo
6392 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6393 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6394
6395 C to check gradient call subroutine check_grad
6396
6397     1 continue
6398       enddo
6399       return
6400       end
6401 c------------------------------------------------------------------------------
6402       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6403       implicit none
6404       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6405      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6406       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6407      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6408      &   + x(10)*yy*zz
6409       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6410      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6411      & + x(20)*yy*zz
6412       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6413      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6414      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6415      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6416      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6417      &  +x(40)*xx*yy*zz
6418       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6419      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6420      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6421      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6422      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6423      &  +x(60)*xx*yy*zz
6424       dsc_i   = 0.743d0+x(61)
6425       dp2_i   = 1.9d0+x(62)
6426       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6427      &          *(xx*cost2+yy*sint2))
6428       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6429      &          *(xx*cost2-yy*sint2))
6430       s1=(1+x(63))/(0.1d0 + dscp1)
6431       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6432       s2=(1+x(65))/(0.1d0 + dscp2)
6433       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6434       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6435      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6436       enesc=sumene
6437       return
6438       end
6439 #endif
6440 c------------------------------------------------------------------------------
6441       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6442 C
6443 C This procedure calculates two-body contact function g(rij) and its derivative:
6444 C
6445 C           eps0ij                                     !       x < -1
6446 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6447 C            0                                         !       x > 1
6448 C
6449 C where x=(rij-r0ij)/delta
6450 C
6451 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6452 C
6453       implicit none
6454       double precision rij,r0ij,eps0ij,fcont,fprimcont
6455       double precision x,x2,x4,delta
6456 c     delta=0.02D0*r0ij
6457 c      delta=0.2D0*r0ij
6458       x=(rij-r0ij)/delta
6459       if (x.lt.-1.0D0) then
6460         fcont=eps0ij
6461         fprimcont=0.0D0
6462       else if (x.le.1.0D0) then
6463         x2=x*x
6464         x4=x2*x2
6465         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6466         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6467       else
6468         fcont=0.0D0
6469         fprimcont=0.0D0
6470       endif
6471       return
6472       end
6473 c------------------------------------------------------------------------------
6474       subroutine splinthet(theti,delta,ss,ssder)
6475       implicit real*8 (a-h,o-z)
6476       include 'DIMENSIONS'
6477       include 'COMMON.VAR'
6478       include 'COMMON.GEO'
6479       thetup=pi-delta
6480       thetlow=delta
6481       if (theti.gt.pipol) then
6482         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6483       else
6484         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6485         ssder=-ssder
6486       endif
6487       return
6488       end
6489 c------------------------------------------------------------------------------
6490       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6491       implicit none
6492       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6493       double precision ksi,ksi2,ksi3,a1,a2,a3
6494       a1=fprim0*delta/(f1-f0)
6495       a2=3.0d0-2.0d0*a1
6496       a3=a1-2.0d0
6497       ksi=(x-x0)/delta
6498       ksi2=ksi*ksi
6499       ksi3=ksi2*ksi
6500       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6501       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6502       return
6503       end
6504 c------------------------------------------------------------------------------
6505       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6506       implicit none
6507       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6508       double precision ksi,ksi2,ksi3,a1,a2,a3
6509       ksi=(x-x0)/delta
6510       ksi2=ksi*ksi
6511       ksi3=ksi2*ksi
6512       a1=fprim0x*delta
6513       a2=3*(f1x-f0x)-2*fprim0x*delta
6514       a3=fprim0x*delta-2*(f1x-f0x)
6515       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6516       return
6517       end
6518 C-----------------------------------------------------------------------------
6519 #ifdef CRYST_TOR
6520 C-----------------------------------------------------------------------------
6521       subroutine etor(etors,edihcnstr)
6522       implicit real*8 (a-h,o-z)
6523       include 'DIMENSIONS'
6524       include 'COMMON.VAR'
6525       include 'COMMON.GEO'
6526       include 'COMMON.LOCAL'
6527       include 'COMMON.TORSION'
6528       include 'COMMON.INTERACT'
6529       include 'COMMON.DERIV'
6530       include 'COMMON.CHAIN'
6531       include 'COMMON.NAMES'
6532       include 'COMMON.IOUNITS'
6533       include 'COMMON.FFIELD'
6534       include 'COMMON.TORCNSTR'
6535       include 'COMMON.CONTROL'
6536       logical lprn
6537 C Set lprn=.true. for debugging
6538       lprn=.false.
6539 c      lprn=.true.
6540       etors=0.0D0
6541       do i=iphi_start,iphi_end
6542       etors_ii=0.0D0
6543         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6544      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6545         itori=itortyp(itype(i-2))
6546         itori1=itortyp(itype(i-1))
6547         phii=phi(i)
6548         gloci=0.0D0
6549 C Proline-Proline pair is a special case...
6550         if (itori.eq.3 .and. itori1.eq.3) then
6551           if (phii.gt.-dwapi3) then
6552             cosphi=dcos(3*phii)
6553             fac=1.0D0/(1.0D0-cosphi)
6554             etorsi=v1(1,3,3)*fac
6555             etorsi=etorsi+etorsi
6556             etors=etors+etorsi-v1(1,3,3)
6557             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6558             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6559           endif
6560           do j=1,3
6561             v1ij=v1(j+1,itori,itori1)
6562             v2ij=v2(j+1,itori,itori1)
6563             cosphi=dcos(j*phii)
6564             sinphi=dsin(j*phii)
6565             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6566             if (energy_dec) etors_ii=etors_ii+
6567      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6568             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6569           enddo
6570         else
6571           do j=1,nterm_old
6572             v1ij=v1(j,itori,itori1)
6573             v2ij=v2(j,itori,itori1)
6574             cosphi=dcos(j*phii)
6575             sinphi=dsin(j*phii)
6576             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6577             if (energy_dec) etors_ii=etors_ii+
6578      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6579             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6580           enddo
6581         endif
6582         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6583              'etor',i,etors_ii
6584         if (lprn)
6585      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6586      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6587      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6588         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6589 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6590       enddo
6591 ! 6/20/98 - dihedral angle constraints
6592       edihcnstr=0.0d0
6593       do i=1,ndih_constr
6594         itori=idih_constr(i)
6595         phii=phi(itori)
6596         difi=phii-phi0(i)
6597         if (difi.gt.drange(i)) then
6598           difi=difi-drange(i)
6599           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6600           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6601         else if (difi.lt.-drange(i)) then
6602           difi=difi+drange(i)
6603           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6604           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6605         endif
6606 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6607 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6608       enddo
6609 !      write (iout,*) 'edihcnstr',edihcnstr
6610       return
6611       end
6612 c------------------------------------------------------------------------------
6613       subroutine etor_d(etors_d)
6614       etors_d=0.0d0
6615       return
6616       end
6617 c----------------------------------------------------------------------------
6618 #else
6619       subroutine etor(etors,edihcnstr)
6620       implicit real*8 (a-h,o-z)
6621       include 'DIMENSIONS'
6622       include 'COMMON.VAR'
6623       include 'COMMON.GEO'
6624       include 'COMMON.LOCAL'
6625       include 'COMMON.TORSION'
6626       include 'COMMON.INTERACT'
6627       include 'COMMON.DERIV'
6628       include 'COMMON.CHAIN'
6629       include 'COMMON.NAMES'
6630       include 'COMMON.IOUNITS'
6631       include 'COMMON.FFIELD'
6632       include 'COMMON.TORCNSTR'
6633       include 'COMMON.CONTROL'
6634       logical lprn
6635 C Set lprn=.true. for debugging
6636       lprn=.false.
6637 c     lprn=.true.
6638       etors=0.0D0
6639       do i=iphi_start,iphi_end
6640 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6641 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6642 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6643 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6644         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6645      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6646 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6647 C For introducing the NH3+ and COO- group please check the etor_d for reference
6648 C and guidance
6649         etors_ii=0.0D0
6650          if (iabs(itype(i)).eq.20) then
6651          iblock=2
6652          else
6653          iblock=1
6654          endif
6655         itori=itortyp(itype(i-2))
6656         itori1=itortyp(itype(i-1))
6657         phii=phi(i)
6658         gloci=0.0D0
6659 C Regular cosine and sine terms
6660         do j=1,nterm(itori,itori1,iblock)
6661           v1ij=v1(j,itori,itori1,iblock)
6662           v2ij=v2(j,itori,itori1,iblock)
6663           cosphi=dcos(j*phii)
6664           sinphi=dsin(j*phii)
6665           etors=etors+v1ij*cosphi+v2ij*sinphi
6666           if (energy_dec) etors_ii=etors_ii+
6667      &                v1ij*cosphi+v2ij*sinphi
6668           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6669         enddo
6670 C Lorentz terms
6671 C                         v1
6672 C  E = SUM ----------------------------------- - v1
6673 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6674 C
6675         cosphi=dcos(0.5d0*phii)
6676         sinphi=dsin(0.5d0*phii)
6677         do j=1,nlor(itori,itori1,iblock)
6678           vl1ij=vlor1(j,itori,itori1)
6679           vl2ij=vlor2(j,itori,itori1)
6680           vl3ij=vlor3(j,itori,itori1)
6681           pom=vl2ij*cosphi+vl3ij*sinphi
6682           pom1=1.0d0/(pom*pom+1.0d0)
6683           etors=etors+vl1ij*pom1
6684           if (energy_dec) etors_ii=etors_ii+
6685      &                vl1ij*pom1
6686           pom=-pom*pom1*pom1
6687           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6688         enddo
6689 C Subtract the constant term
6690         etors=etors-v0(itori,itori1,iblock)
6691           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6692      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6693         if (lprn)
6694      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6695      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6696      &  (v1(j,itori,itori1,iblock),j=1,6),
6697      &  (v2(j,itori,itori1,iblock),j=1,6)
6698         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6699 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6700       enddo
6701 ! 6/20/98 - dihedral angle constraints
6702       edihcnstr=0.0d0
6703 c      do i=1,ndih_constr
6704       do i=idihconstr_start,idihconstr_end
6705         itori=idih_constr(i)
6706         phii=phi(itori)
6707         difi=pinorm(phii-phi0(i))
6708         if (difi.gt.drange(i)) then
6709           difi=difi-drange(i)
6710           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6711           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6712         else if (difi.lt.-drange(i)) then
6713           difi=difi+drange(i)
6714           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6715           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6716         else
6717           difi=0.0
6718         endif
6719 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6720 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6721 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6722       enddo
6723 cd       write (iout,*) 'edihcnstr',edihcnstr
6724       return
6725       end
6726 c----------------------------------------------------------------------------
6727       subroutine etor_d(etors_d)
6728 C 6/23/01 Compute double torsional energy
6729       implicit real*8 (a-h,o-z)
6730       include 'DIMENSIONS'
6731       include 'COMMON.VAR'
6732       include 'COMMON.GEO'
6733       include 'COMMON.LOCAL'
6734       include 'COMMON.TORSION'
6735       include 'COMMON.INTERACT'
6736       include 'COMMON.DERIV'
6737       include 'COMMON.CHAIN'
6738       include 'COMMON.NAMES'
6739       include 'COMMON.IOUNITS'
6740       include 'COMMON.FFIELD'
6741       include 'COMMON.TORCNSTR'
6742       logical lprn
6743 C Set lprn=.true. for debugging
6744       lprn=.false.
6745 c     lprn=.true.
6746       etors_d=0.0D0
6747 c      write(iout,*) "a tu??"
6748       do i=iphid_start,iphid_end
6749 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6750 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6751 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6752 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6753 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6754          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6755      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6756      &  (itype(i+1).eq.ntyp1)) cycle
6757 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6758         itori=itortyp(itype(i-2))
6759         itori1=itortyp(itype(i-1))
6760         itori2=itortyp(itype(i))
6761         phii=phi(i)
6762         phii1=phi(i+1)
6763         gloci1=0.0D0
6764         gloci2=0.0D0
6765         iblock=1
6766         if (iabs(itype(i+1)).eq.20) iblock=2
6767 C Iblock=2 Proline type
6768 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6769 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6770 C        if (itype(i+1).eq.ntyp1) iblock=3
6771 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6772 C IS or IS NOT need for this
6773 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6774 C        is (itype(i-3).eq.ntyp1) ntblock=2
6775 C        ntblock is N-terminal blocking group
6776
6777 C Regular cosine and sine terms
6778         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6779 C Example of changes for NH3+ blocking group
6780 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6781 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6782           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6783           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6784           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6785           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6786           cosphi1=dcos(j*phii)
6787           sinphi1=dsin(j*phii)
6788           cosphi2=dcos(j*phii1)
6789           sinphi2=dsin(j*phii1)
6790           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6791      &     v2cij*cosphi2+v2sij*sinphi2
6792           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6793           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6794         enddo
6795         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6796           do l=1,k-1
6797             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6798             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6799             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6800             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6801             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6802             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6803             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6804             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6805             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6806      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6807             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6808      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6809             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6810      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6811           enddo
6812         enddo
6813         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6814         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6815       enddo
6816       return
6817       end
6818 #endif
6819 c------------------------------------------------------------------------------
6820       subroutine eback_sc_corr(esccor)
6821 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6822 c        conformational states; temporarily implemented as differences
6823 c        between UNRES torsional potentials (dependent on three types of
6824 c        residues) and the torsional potentials dependent on all 20 types
6825 c        of residues computed from AM1  energy surfaces of terminally-blocked
6826 c        amino-acid residues.
6827       implicit real*8 (a-h,o-z)
6828       include 'DIMENSIONS'
6829       include 'COMMON.VAR'
6830       include 'COMMON.GEO'
6831       include 'COMMON.LOCAL'
6832       include 'COMMON.TORSION'
6833       include 'COMMON.SCCOR'
6834       include 'COMMON.INTERACT'
6835       include 'COMMON.DERIV'
6836       include 'COMMON.CHAIN'
6837       include 'COMMON.NAMES'
6838       include 'COMMON.IOUNITS'
6839       include 'COMMON.FFIELD'
6840       include 'COMMON.CONTROL'
6841       logical lprn
6842 C Set lprn=.true. for debugging
6843       lprn=.false.
6844 c      lprn=.true.
6845 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6846       esccor=0.0D0
6847       do i=itau_start,itau_end
6848         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6849         esccor_ii=0.0D0
6850         isccori=isccortyp(itype(i-2))
6851         isccori1=isccortyp(itype(i-1))
6852 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6853         phii=phi(i)
6854         do intertyp=1,3 !intertyp
6855 cc Added 09 May 2012 (Adasko)
6856 cc  Intertyp means interaction type of backbone mainchain correlation:
6857 c   1 = SC...Ca...Ca...Ca
6858 c   2 = Ca...Ca...Ca...SC
6859 c   3 = SC...Ca...Ca...SCi
6860         gloci=0.0D0
6861         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6862      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6863      &      (itype(i-1).eq.ntyp1)))
6864      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6865      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6866      &     .or.(itype(i).eq.ntyp1)))
6867      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6868      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6869      &      (itype(i-3).eq.ntyp1)))) cycle
6870         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6871         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6872      & cycle
6873        do j=1,nterm_sccor(isccori,isccori1)
6874           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6875           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6876           cosphi=dcos(j*tauangle(intertyp,i))
6877           sinphi=dsin(j*tauangle(intertyp,i))
6878           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6879           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6880         enddo
6881 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6882         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6883         if (lprn)
6884      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6885      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6886      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6887      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6888         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6889        enddo !intertyp
6890       enddo
6891
6892       return
6893       end
6894 c----------------------------------------------------------------------------
6895       subroutine multibody(ecorr)
6896 C This subroutine calculates multi-body contributions to energy following
6897 C the idea of Skolnick et al. If side chains I and J make a contact and
6898 C at the same time side chains I+1 and J+1 make a contact, an extra
6899 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6900       implicit real*8 (a-h,o-z)
6901       include 'DIMENSIONS'
6902       include 'COMMON.IOUNITS'
6903       include 'COMMON.DERIV'
6904       include 'COMMON.INTERACT'
6905       include 'COMMON.CONTACTS'
6906       double precision gx(3),gx1(3)
6907       logical lprn
6908
6909 C Set lprn=.true. for debugging
6910       lprn=.false.
6911
6912       if (lprn) then
6913         write (iout,'(a)') 'Contact function values:'
6914         do i=nnt,nct-2
6915           write (iout,'(i2,20(1x,i2,f10.5))')
6916      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6917         enddo
6918       endif
6919       ecorr=0.0D0
6920       do i=nnt,nct
6921         do j=1,3
6922           gradcorr(j,i)=0.0D0
6923           gradxorr(j,i)=0.0D0
6924         enddo
6925       enddo
6926       do i=nnt,nct-2
6927
6928         DO ISHIFT = 3,4
6929
6930         i1=i+ishift
6931         num_conti=num_cont(i)
6932         num_conti1=num_cont(i1)
6933         do jj=1,num_conti
6934           j=jcont(jj,i)
6935           do kk=1,num_conti1
6936             j1=jcont(kk,i1)
6937             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6938 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6939 cd   &                   ' ishift=',ishift
6940 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6941 C The system gains extra energy.
6942               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6943             endif   ! j1==j+-ishift
6944           enddo     ! kk
6945         enddo       ! jj
6946
6947         ENDDO ! ISHIFT
6948
6949       enddo         ! i
6950       return
6951       end
6952 c------------------------------------------------------------------------------
6953       double precision function esccorr(i,j,k,l,jj,kk)
6954       implicit real*8 (a-h,o-z)
6955       include 'DIMENSIONS'
6956       include 'COMMON.IOUNITS'
6957       include 'COMMON.DERIV'
6958       include 'COMMON.INTERACT'
6959       include 'COMMON.CONTACTS'
6960       double precision gx(3),gx1(3)
6961       logical lprn
6962       lprn=.false.
6963       eij=facont(jj,i)
6964       ekl=facont(kk,k)
6965 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6966 C Calculate the multi-body contribution to energy.
6967 C Calculate multi-body contributions to the gradient.
6968 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6969 cd   & k,l,(gacont(m,kk,k),m=1,3)
6970       do m=1,3
6971         gx(m) =ekl*gacont(m,jj,i)
6972         gx1(m)=eij*gacont(m,kk,k)
6973         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6974         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6975         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6976         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6977       enddo
6978       do m=i,j-1
6979         do ll=1,3
6980           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6981         enddo
6982       enddo
6983       do m=k,l-1
6984         do ll=1,3
6985           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6986         enddo
6987       enddo
6988       esccorr=-eij*ekl
6989       return
6990       end
6991 c------------------------------------------------------------------------------
6992       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6993 C This subroutine calculates multi-body contributions to hydrogen-bonding
6994       implicit real*8 (a-h,o-z)
6995       include 'DIMENSIONS'
6996       include 'COMMON.IOUNITS'
6997 #ifdef MPI
6998       include "mpif.h"
6999       parameter (max_cont=maxconts)
7000       parameter (max_dim=26)
7001       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7002       double precision zapas(max_dim,maxconts,max_fg_procs),
7003      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7004       common /przechowalnia/ zapas
7005       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7006      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7007 #endif
7008       include 'COMMON.SETUP'
7009       include 'COMMON.FFIELD'
7010       include 'COMMON.DERIV'
7011       include 'COMMON.INTERACT'
7012       include 'COMMON.CONTACTS'
7013       include 'COMMON.CONTROL'
7014       include 'COMMON.LOCAL'
7015       double precision gx(3),gx1(3),time00
7016       logical lprn,ldone
7017
7018 C Set lprn=.true. for debugging
7019       lprn=.false.
7020 #ifdef MPI
7021       n_corr=0
7022       n_corr1=0
7023       if (nfgtasks.le.1) goto 30
7024       if (lprn) then
7025         write (iout,'(a)') 'Contact function values before RECEIVE:'
7026         do i=nnt,nct-2
7027           write (iout,'(2i3,50(1x,i2,f5.2))')
7028      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7029      &    j=1,num_cont_hb(i))
7030         enddo
7031       endif
7032       call flush(iout)
7033       do i=1,ntask_cont_from
7034         ncont_recv(i)=0
7035       enddo
7036       do i=1,ntask_cont_to
7037         ncont_sent(i)=0
7038       enddo
7039 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7040 c     & ntask_cont_to
7041 C Make the list of contacts to send to send to other procesors
7042 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7043 c      call flush(iout)
7044       do i=iturn3_start,iturn3_end
7045 c        write (iout,*) "make contact list turn3",i," num_cont",
7046 c     &    num_cont_hb(i)
7047         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7048       enddo
7049       do i=iturn4_start,iturn4_end
7050 c        write (iout,*) "make contact list turn4",i," num_cont",
7051 c     &   num_cont_hb(i)
7052         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7053       enddo
7054       do ii=1,nat_sent
7055         i=iat_sent(ii)
7056 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7057 c     &    num_cont_hb(i)
7058         do j=1,num_cont_hb(i)
7059         do k=1,4
7060           jjc=jcont_hb(j,i)
7061           iproc=iint_sent_local(k,jjc,ii)
7062 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7063           if (iproc.gt.0) then
7064             ncont_sent(iproc)=ncont_sent(iproc)+1
7065             nn=ncont_sent(iproc)
7066             zapas(1,nn,iproc)=i
7067             zapas(2,nn,iproc)=jjc
7068             zapas(3,nn,iproc)=facont_hb(j,i)
7069             zapas(4,nn,iproc)=ees0p(j,i)
7070             zapas(5,nn,iproc)=ees0m(j,i)
7071             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7072             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7073             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7074             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7075             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7076             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7077             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7078             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7079             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7080             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7081             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7082             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7083             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7084             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7085             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7086             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7087             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7088             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7089             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7090             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7091             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7092           endif
7093         enddo
7094         enddo
7095       enddo
7096       if (lprn) then
7097       write (iout,*)
7098      &  "Numbers of contacts to be sent to other processors",
7099      &  (ncont_sent(i),i=1,ntask_cont_to)
7100       write (iout,*) "Contacts sent"
7101       do ii=1,ntask_cont_to
7102         nn=ncont_sent(ii)
7103         iproc=itask_cont_to(ii)
7104         write (iout,*) nn," contacts to processor",iproc,
7105      &   " of CONT_TO_COMM group"
7106         do i=1,nn
7107           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7108         enddo
7109       enddo
7110       call flush(iout)
7111       endif
7112       CorrelType=477
7113       CorrelID=fg_rank+1
7114       CorrelType1=478
7115       CorrelID1=nfgtasks+fg_rank+1
7116       ireq=0
7117 C Receive the numbers of needed contacts from other processors
7118       do ii=1,ntask_cont_from
7119         iproc=itask_cont_from(ii)
7120         ireq=ireq+1
7121         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7122      &    FG_COMM,req(ireq),IERR)
7123       enddo
7124 c      write (iout,*) "IRECV ended"
7125 c      call flush(iout)
7126 C Send the number of contacts needed by other processors
7127       do ii=1,ntask_cont_to
7128         iproc=itask_cont_to(ii)
7129         ireq=ireq+1
7130         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7131      &    FG_COMM,req(ireq),IERR)
7132       enddo
7133 c      write (iout,*) "ISEND ended"
7134 c      write (iout,*) "number of requests (nn)",ireq
7135       call flush(iout)
7136       if (ireq.gt.0)
7137      &  call MPI_Waitall(ireq,req,status_array,ierr)
7138 c      write (iout,*)
7139 c     &  "Numbers of contacts to be received from other processors",
7140 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7141 c      call flush(iout)
7142 C Receive contacts
7143       ireq=0
7144       do ii=1,ntask_cont_from
7145         iproc=itask_cont_from(ii)
7146         nn=ncont_recv(ii)
7147 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7148 c     &   " of CONT_TO_COMM group"
7149         call flush(iout)
7150         if (nn.gt.0) then
7151           ireq=ireq+1
7152           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7153      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7154 c          write (iout,*) "ireq,req",ireq,req(ireq)
7155         endif
7156       enddo
7157 C Send the contacts to processors that need them
7158       do ii=1,ntask_cont_to
7159         iproc=itask_cont_to(ii)
7160         nn=ncont_sent(ii)
7161 c        write (iout,*) nn," contacts to processor",iproc,
7162 c     &   " of CONT_TO_COMM group"
7163         if (nn.gt.0) then
7164           ireq=ireq+1
7165           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7166      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7167 c          write (iout,*) "ireq,req",ireq,req(ireq)
7168 c          do i=1,nn
7169 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7170 c          enddo
7171         endif
7172       enddo
7173 c      write (iout,*) "number of requests (contacts)",ireq
7174 c      write (iout,*) "req",(req(i),i=1,4)
7175 c      call flush(iout)
7176       if (ireq.gt.0)
7177      & call MPI_Waitall(ireq,req,status_array,ierr)
7178       do iii=1,ntask_cont_from
7179         iproc=itask_cont_from(iii)
7180         nn=ncont_recv(iii)
7181         if (lprn) then
7182         write (iout,*) "Received",nn," contacts from processor",iproc,
7183      &   " of CONT_FROM_COMM group"
7184         call flush(iout)
7185         do i=1,nn
7186           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7187         enddo
7188         call flush(iout)
7189         endif
7190         do i=1,nn
7191           ii=zapas_recv(1,i,iii)
7192 c Flag the received contacts to prevent double-counting
7193           jj=-zapas_recv(2,i,iii)
7194 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7195 c          call flush(iout)
7196           nnn=num_cont_hb(ii)+1
7197           num_cont_hb(ii)=nnn
7198           jcont_hb(nnn,ii)=jj
7199           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7200           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7201           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7202           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7203           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7204           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7205           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7206           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7207           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7208           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7209           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7210           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7211           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7212           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7213           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7214           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7215           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7216           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7217           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7218           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7219           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7220           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7221           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7222           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7223         enddo
7224       enddo
7225       call flush(iout)
7226       if (lprn) then
7227         write (iout,'(a)') 'Contact function values after receive:'
7228         do i=nnt,nct-2
7229           write (iout,'(2i3,50(1x,i3,f5.2))')
7230      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7231      &    j=1,num_cont_hb(i))
7232         enddo
7233         call flush(iout)
7234       endif
7235    30 continue
7236 #endif
7237       if (lprn) then
7238         write (iout,'(a)') 'Contact function values:'
7239         do i=nnt,nct-2
7240           write (iout,'(2i3,50(1x,i3,f5.2))')
7241      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7242      &    j=1,num_cont_hb(i))
7243         enddo
7244       endif
7245       ecorr=0.0D0
7246 C Remove the loop below after debugging !!!
7247       do i=nnt,nct
7248         do j=1,3
7249           gradcorr(j,i)=0.0D0
7250           gradxorr(j,i)=0.0D0
7251         enddo
7252       enddo
7253 C Calculate the local-electrostatic correlation terms
7254       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7255         i1=i+1
7256         num_conti=num_cont_hb(i)
7257         num_conti1=num_cont_hb(i+1)
7258         do jj=1,num_conti
7259           j=jcont_hb(jj,i)
7260           jp=iabs(j)
7261           do kk=1,num_conti1
7262             j1=jcont_hb(kk,i1)
7263             jp1=iabs(j1)
7264 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7265 c     &         ' jj=',jj,' kk=',kk
7266             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7267      &          .or. j.lt.0 .and. j1.gt.0) .and.
7268      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7269 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7270 C The system gains extra energy.
7271               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7272               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7273      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7274               n_corr=n_corr+1
7275             else if (j1.eq.j) then
7276 C Contacts I-J and I-(J+1) occur simultaneously.
7277 C The system loses extra energy.
7278 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7279             endif
7280           enddo ! kk
7281           do kk=1,num_conti
7282             j1=jcont_hb(kk,i)
7283 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7284 c    &         ' jj=',jj,' kk=',kk
7285             if (j1.eq.j+1) then
7286 C Contacts I-J and (I+1)-J occur simultaneously.
7287 C The system loses extra energy.
7288 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7289             endif ! j1==j+1
7290           enddo ! kk
7291         enddo ! jj
7292       enddo ! i
7293       return
7294       end
7295 c------------------------------------------------------------------------------
7296       subroutine add_hb_contact(ii,jj,itask)
7297       implicit real*8 (a-h,o-z)
7298       include "DIMENSIONS"
7299       include "COMMON.IOUNITS"
7300       integer max_cont
7301       integer max_dim
7302       parameter (max_cont=maxconts)
7303       parameter (max_dim=26)
7304       include "COMMON.CONTACTS"
7305       double precision zapas(max_dim,maxconts,max_fg_procs),
7306      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7307       common /przechowalnia/ zapas
7308       integer i,j,ii,jj,iproc,itask(4),nn
7309 c      write (iout,*) "itask",itask
7310       do i=1,2
7311         iproc=itask(i)
7312         if (iproc.gt.0) then
7313           do j=1,num_cont_hb(ii)
7314             jjc=jcont_hb(j,ii)
7315 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7316             if (jjc.eq.jj) then
7317               ncont_sent(iproc)=ncont_sent(iproc)+1
7318               nn=ncont_sent(iproc)
7319               zapas(1,nn,iproc)=ii
7320               zapas(2,nn,iproc)=jjc
7321               zapas(3,nn,iproc)=facont_hb(j,ii)
7322               zapas(4,nn,iproc)=ees0p(j,ii)
7323               zapas(5,nn,iproc)=ees0m(j,ii)
7324               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7325               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7326               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7327               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7328               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7329               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7330               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7331               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7332               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7333               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7334               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7335               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7336               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7337               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7338               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7339               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7340               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7341               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7342               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7343               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7344               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7345               exit
7346             endif
7347           enddo
7348         endif
7349       enddo
7350       return
7351       end
7352 c------------------------------------------------------------------------------
7353       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7354      &  n_corr1)
7355 C This subroutine calculates multi-body contributions to hydrogen-bonding
7356       implicit real*8 (a-h,o-z)
7357       include 'DIMENSIONS'
7358       include 'COMMON.IOUNITS'
7359 #ifdef MPI
7360       include "mpif.h"
7361       parameter (max_cont=maxconts)
7362       parameter (max_dim=70)
7363       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7364       double precision zapas(max_dim,maxconts,max_fg_procs),
7365      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7366       common /przechowalnia/ zapas
7367       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7368      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7369 #endif
7370       include 'COMMON.SETUP'
7371       include 'COMMON.FFIELD'
7372       include 'COMMON.DERIV'
7373       include 'COMMON.LOCAL'
7374       include 'COMMON.INTERACT'
7375       include 'COMMON.CONTACTS'
7376       include 'COMMON.CHAIN'
7377       include 'COMMON.CONTROL'
7378       double precision gx(3),gx1(3)
7379       integer num_cont_hb_old(maxres)
7380       logical lprn,ldone
7381       double precision eello4,eello5,eelo6,eello_turn6
7382       external eello4,eello5,eello6,eello_turn6
7383 C Set lprn=.true. for debugging
7384       lprn=.false.
7385       eturn6=0.0d0
7386 #ifdef MPI
7387       do i=1,nres
7388         num_cont_hb_old(i)=num_cont_hb(i)
7389       enddo
7390       n_corr=0
7391       n_corr1=0
7392       if (nfgtasks.le.1) goto 30
7393       if (lprn) then
7394         write (iout,'(a)') 'Contact function values before RECEIVE:'
7395         do i=nnt,nct-2
7396           write (iout,'(2i3,50(1x,i2,f5.2))')
7397      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7398      &    j=1,num_cont_hb(i))
7399         enddo
7400       endif
7401       call flush(iout)
7402       do i=1,ntask_cont_from
7403         ncont_recv(i)=0
7404       enddo
7405       do i=1,ntask_cont_to
7406         ncont_sent(i)=0
7407       enddo
7408 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7409 c     & ntask_cont_to
7410 C Make the list of contacts to send to send to other procesors
7411       do i=iturn3_start,iturn3_end
7412 c        write (iout,*) "make contact list turn3",i," num_cont",
7413 c     &    num_cont_hb(i)
7414         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7415       enddo
7416       do i=iturn4_start,iturn4_end
7417 c        write (iout,*) "make contact list turn4",i," num_cont",
7418 c     &   num_cont_hb(i)
7419         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7420       enddo
7421       do ii=1,nat_sent
7422         i=iat_sent(ii)
7423 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7424 c     &    num_cont_hb(i)
7425         do j=1,num_cont_hb(i)
7426         do k=1,4
7427           jjc=jcont_hb(j,i)
7428           iproc=iint_sent_local(k,jjc,ii)
7429 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7430           if (iproc.ne.0) then
7431             ncont_sent(iproc)=ncont_sent(iproc)+1
7432             nn=ncont_sent(iproc)
7433             zapas(1,nn,iproc)=i
7434             zapas(2,nn,iproc)=jjc
7435             zapas(3,nn,iproc)=d_cont(j,i)
7436             ind=3
7437             do kk=1,3
7438               ind=ind+1
7439               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7440             enddo
7441             do kk=1,2
7442               do ll=1,2
7443                 ind=ind+1
7444                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7445               enddo
7446             enddo
7447             do jj=1,5
7448               do kk=1,3
7449                 do ll=1,2
7450                   do mm=1,2
7451                     ind=ind+1
7452                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7453                   enddo
7454                 enddo
7455               enddo
7456             enddo
7457           endif
7458         enddo
7459         enddo
7460       enddo
7461       if (lprn) then
7462       write (iout,*)
7463      &  "Numbers of contacts to be sent to other processors",
7464      &  (ncont_sent(i),i=1,ntask_cont_to)
7465       write (iout,*) "Contacts sent"
7466       do ii=1,ntask_cont_to
7467         nn=ncont_sent(ii)
7468         iproc=itask_cont_to(ii)
7469         write (iout,*) nn," contacts to processor",iproc,
7470      &   " of CONT_TO_COMM group"
7471         do i=1,nn
7472           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7473         enddo
7474       enddo
7475       call flush(iout)
7476       endif
7477       CorrelType=477
7478       CorrelID=fg_rank+1
7479       CorrelType1=478
7480       CorrelID1=nfgtasks+fg_rank+1
7481       ireq=0
7482 C Receive the numbers of needed contacts from other processors
7483       do ii=1,ntask_cont_from
7484         iproc=itask_cont_from(ii)
7485         ireq=ireq+1
7486         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7487      &    FG_COMM,req(ireq),IERR)
7488       enddo
7489 c      write (iout,*) "IRECV ended"
7490 c      call flush(iout)
7491 C Send the number of contacts needed by other processors
7492       do ii=1,ntask_cont_to
7493         iproc=itask_cont_to(ii)
7494         ireq=ireq+1
7495         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7496      &    FG_COMM,req(ireq),IERR)
7497       enddo
7498 c      write (iout,*) "ISEND ended"
7499 c      write (iout,*) "number of requests (nn)",ireq
7500       call flush(iout)
7501       if (ireq.gt.0)
7502      &  call MPI_Waitall(ireq,req,status_array,ierr)
7503 c      write (iout,*)
7504 c     &  "Numbers of contacts to be received from other processors",
7505 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7506 c      call flush(iout)
7507 C Receive contacts
7508       ireq=0
7509       do ii=1,ntask_cont_from
7510         iproc=itask_cont_from(ii)
7511         nn=ncont_recv(ii)
7512 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7513 c     &   " of CONT_TO_COMM group"
7514         call flush(iout)
7515         if (nn.gt.0) then
7516           ireq=ireq+1
7517           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7518      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7519 c          write (iout,*) "ireq,req",ireq,req(ireq)
7520         endif
7521       enddo
7522 C Send the contacts to processors that need them
7523       do ii=1,ntask_cont_to
7524         iproc=itask_cont_to(ii)
7525         nn=ncont_sent(ii)
7526 c        write (iout,*) nn," contacts to processor",iproc,
7527 c     &   " of CONT_TO_COMM group"
7528         if (nn.gt.0) then
7529           ireq=ireq+1
7530           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7531      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7532 c          write (iout,*) "ireq,req",ireq,req(ireq)
7533 c          do i=1,nn
7534 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7535 c          enddo
7536         endif
7537       enddo
7538 c      write (iout,*) "number of requests (contacts)",ireq
7539 c      write (iout,*) "req",(req(i),i=1,4)
7540 c      call flush(iout)
7541       if (ireq.gt.0)
7542      & call MPI_Waitall(ireq,req,status_array,ierr)
7543       do iii=1,ntask_cont_from
7544         iproc=itask_cont_from(iii)
7545         nn=ncont_recv(iii)
7546         if (lprn) then
7547         write (iout,*) "Received",nn," contacts from processor",iproc,
7548      &   " of CONT_FROM_COMM group"
7549         call flush(iout)
7550         do i=1,nn
7551           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7552         enddo
7553         call flush(iout)
7554         endif
7555         do i=1,nn
7556           ii=zapas_recv(1,i,iii)
7557 c Flag the received contacts to prevent double-counting
7558           jj=-zapas_recv(2,i,iii)
7559 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7560 c          call flush(iout)
7561           nnn=num_cont_hb(ii)+1
7562           num_cont_hb(ii)=nnn
7563           jcont_hb(nnn,ii)=jj
7564           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7565           ind=3
7566           do kk=1,3
7567             ind=ind+1
7568             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7569           enddo
7570           do kk=1,2
7571             do ll=1,2
7572               ind=ind+1
7573               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7574             enddo
7575           enddo
7576           do jj=1,5
7577             do kk=1,3
7578               do ll=1,2
7579                 do mm=1,2
7580                   ind=ind+1
7581                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7582                 enddo
7583               enddo
7584             enddo
7585           enddo
7586         enddo
7587       enddo
7588       call flush(iout)
7589       if (lprn) then
7590         write (iout,'(a)') 'Contact function values after receive:'
7591         do i=nnt,nct-2
7592           write (iout,'(2i3,50(1x,i3,5f6.3))')
7593      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7594      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7595         enddo
7596         call flush(iout)
7597       endif
7598    30 continue
7599 #endif
7600       if (lprn) then
7601         write (iout,'(a)') 'Contact function values:'
7602         do i=nnt,nct-2
7603           write (iout,'(2i3,50(1x,i2,5f6.3))')
7604      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7605      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7606         enddo
7607       endif
7608       ecorr=0.0D0
7609       ecorr5=0.0d0
7610       ecorr6=0.0d0
7611 C Remove the loop below after debugging !!!
7612       do i=nnt,nct
7613         do j=1,3
7614           gradcorr(j,i)=0.0D0
7615           gradxorr(j,i)=0.0D0
7616         enddo
7617       enddo
7618 C Calculate the dipole-dipole interaction energies
7619       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7620       do i=iatel_s,iatel_e+1
7621         num_conti=num_cont_hb(i)
7622         do jj=1,num_conti
7623           j=jcont_hb(jj,i)
7624 #ifdef MOMENT
7625           call dipole(i,j,jj)
7626 #endif
7627         enddo
7628       enddo
7629       endif
7630 C Calculate the local-electrostatic correlation terms
7631 c                write (iout,*) "gradcorr5 in eello5 before loop"
7632 c                do iii=1,nres
7633 c                  write (iout,'(i5,3f10.5)')
7634 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7635 c                enddo
7636       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7637 c        write (iout,*) "corr loop i",i
7638         i1=i+1
7639         num_conti=num_cont_hb(i)
7640         num_conti1=num_cont_hb(i+1)
7641         do jj=1,num_conti
7642           j=jcont_hb(jj,i)
7643           jp=iabs(j)
7644           do kk=1,num_conti1
7645             j1=jcont_hb(kk,i1)
7646             jp1=iabs(j1)
7647 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7648 c     &         ' jj=',jj,' kk=',kk
7649 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7650             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7651      &          .or. j.lt.0 .and. j1.gt.0) .and.
7652      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7653 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7654 C The system gains extra energy.
7655               n_corr=n_corr+1
7656               sqd1=dsqrt(d_cont(jj,i))
7657               sqd2=dsqrt(d_cont(kk,i1))
7658               sred_geom = sqd1*sqd2
7659               IF (sred_geom.lt.cutoff_corr) THEN
7660                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7661      &            ekont,fprimcont)
7662 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7663 cd     &         ' jj=',jj,' kk=',kk
7664                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7665                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7666                 do l=1,3
7667                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7668                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7669                 enddo
7670                 n_corr1=n_corr1+1
7671 cd               write (iout,*) 'sred_geom=',sred_geom,
7672 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7673 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7674 cd               write (iout,*) "g_contij",g_contij
7675 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7676 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7677                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7678                 if (wcorr4.gt.0.0d0)
7679      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7680                   if (energy_dec.and.wcorr4.gt.0.0d0)
7681      1                 write (iout,'(a6,4i5,0pf7.3)')
7682      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7683 c                write (iout,*) "gradcorr5 before eello5"
7684 c                do iii=1,nres
7685 c                  write (iout,'(i5,3f10.5)')
7686 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7687 c                enddo
7688                 if (wcorr5.gt.0.0d0)
7689      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7690 c                write (iout,*) "gradcorr5 after eello5"
7691 c                do iii=1,nres
7692 c                  write (iout,'(i5,3f10.5)')
7693 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7694 c                enddo
7695                   if (energy_dec.and.wcorr5.gt.0.0d0)
7696      1                 write (iout,'(a6,4i5,0pf7.3)')
7697      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7698 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7699 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7700                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7701      &               .or. wturn6.eq.0.0d0))then
7702 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7703                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7704                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7705      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7706 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7707 cd     &            'ecorr6=',ecorr6
7708 cd                write (iout,'(4e15.5)') sred_geom,
7709 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7710 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7711 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7712                 else if (wturn6.gt.0.0d0
7713      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7714 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7715                   eturn6=eturn6+eello_turn6(i,jj,kk)
7716                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7717      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7718 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7719                 endif
7720               ENDIF
7721 1111          continue
7722             endif
7723           enddo ! kk
7724         enddo ! jj
7725       enddo ! i
7726       do i=1,nres
7727         num_cont_hb(i)=num_cont_hb_old(i)
7728       enddo
7729 c                write (iout,*) "gradcorr5 in eello5"
7730 c                do iii=1,nres
7731 c                  write (iout,'(i5,3f10.5)')
7732 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7733 c                enddo
7734       return
7735       end
7736 c------------------------------------------------------------------------------
7737       subroutine add_hb_contact_eello(ii,jj,itask)
7738       implicit real*8 (a-h,o-z)
7739       include "DIMENSIONS"
7740       include "COMMON.IOUNITS"
7741       integer max_cont
7742       integer max_dim
7743       parameter (max_cont=maxconts)
7744       parameter (max_dim=70)
7745       include "COMMON.CONTACTS"
7746       double precision zapas(max_dim,maxconts,max_fg_procs),
7747      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7748       common /przechowalnia/ zapas
7749       integer i,j,ii,jj,iproc,itask(4),nn
7750 c      write (iout,*) "itask",itask
7751       do i=1,2
7752         iproc=itask(i)
7753         if (iproc.gt.0) then
7754           do j=1,num_cont_hb(ii)
7755             jjc=jcont_hb(j,ii)
7756 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7757             if (jjc.eq.jj) then
7758               ncont_sent(iproc)=ncont_sent(iproc)+1
7759               nn=ncont_sent(iproc)
7760               zapas(1,nn,iproc)=ii
7761               zapas(2,nn,iproc)=jjc
7762               zapas(3,nn,iproc)=d_cont(j,ii)
7763               ind=3
7764               do kk=1,3
7765                 ind=ind+1
7766                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7767               enddo
7768               do kk=1,2
7769                 do ll=1,2
7770                   ind=ind+1
7771                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7772                 enddo
7773               enddo
7774               do jj=1,5
7775                 do kk=1,3
7776                   do ll=1,2
7777                     do mm=1,2
7778                       ind=ind+1
7779                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7780                     enddo
7781                   enddo
7782                 enddo
7783               enddo
7784               exit
7785             endif
7786           enddo
7787         endif
7788       enddo
7789       return
7790       end
7791 c------------------------------------------------------------------------------
7792       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7793       implicit real*8 (a-h,o-z)
7794       include 'DIMENSIONS'
7795       include 'COMMON.IOUNITS'
7796       include 'COMMON.DERIV'
7797       include 'COMMON.INTERACT'
7798       include 'COMMON.CONTACTS'
7799       double precision gx(3),gx1(3)
7800       logical lprn
7801       lprn=.false.
7802       eij=facont_hb(jj,i)
7803       ekl=facont_hb(kk,k)
7804       ees0pij=ees0p(jj,i)
7805       ees0pkl=ees0p(kk,k)
7806       ees0mij=ees0m(jj,i)
7807       ees0mkl=ees0m(kk,k)
7808       ekont=eij*ekl
7809       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7810 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7811 C Following 4 lines for diagnostics.
7812 cd    ees0pkl=0.0D0
7813 cd    ees0pij=1.0D0
7814 cd    ees0mkl=0.0D0
7815 cd    ees0mij=1.0D0
7816 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7817 c     & 'Contacts ',i,j,
7818 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7819 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7820 c     & 'gradcorr_long'
7821 C Calculate the multi-body contribution to energy.
7822 c      ecorr=ecorr+ekont*ees
7823 C Calculate multi-body contributions to the gradient.
7824       coeffpees0pij=coeffp*ees0pij
7825       coeffmees0mij=coeffm*ees0mij
7826       coeffpees0pkl=coeffp*ees0pkl
7827       coeffmees0mkl=coeffm*ees0mkl
7828       do ll=1,3
7829 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7830         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7831      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7832      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7833         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7834      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7835      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7836 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7837         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7838      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7839      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7840         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7841      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7842      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7843         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7844      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7845      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7846         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7847         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7848         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7849      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7850      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7851         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7852         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7853 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7854       enddo
7855 c      write (iout,*)
7856 cgrad      do m=i+1,j-1
7857 cgrad        do ll=1,3
7858 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7859 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7860 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7861 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7862 cgrad        enddo
7863 cgrad      enddo
7864 cgrad      do m=k+1,l-1
7865 cgrad        do ll=1,3
7866 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7867 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7868 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7869 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7870 cgrad        enddo
7871 cgrad      enddo
7872 c      write (iout,*) "ehbcorr",ekont*ees
7873       ehbcorr=ekont*ees
7874       return
7875       end
7876 #ifdef MOMENT
7877 C---------------------------------------------------------------------------
7878       subroutine dipole(i,j,jj)
7879       implicit real*8 (a-h,o-z)
7880       include 'DIMENSIONS'
7881       include 'COMMON.IOUNITS'
7882       include 'COMMON.CHAIN'
7883       include 'COMMON.FFIELD'
7884       include 'COMMON.DERIV'
7885       include 'COMMON.INTERACT'
7886       include 'COMMON.CONTACTS'
7887       include 'COMMON.TORSION'
7888       include 'COMMON.VAR'
7889       include 'COMMON.GEO'
7890       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7891      &  auxmat(2,2)
7892       iti1 = itortyp(itype(i+1))
7893       if (j.lt.nres-1) then
7894         itj1 = itortyp(itype(j+1))
7895       else
7896         itj1=ntortyp
7897       endif
7898       do iii=1,2
7899         dipi(iii,1)=Ub2(iii,i)
7900         dipderi(iii)=Ub2der(iii,i)
7901         dipi(iii,2)=b1(iii,i+1)
7902         dipj(iii,1)=Ub2(iii,j)
7903         dipderj(iii)=Ub2der(iii,j)
7904         dipj(iii,2)=b1(iii,j+1)
7905       enddo
7906       kkk=0
7907       do iii=1,2
7908         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7909         do jjj=1,2
7910           kkk=kkk+1
7911           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7912         enddo
7913       enddo
7914       do kkk=1,5
7915         do lll=1,3
7916           mmm=0
7917           do iii=1,2
7918             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7919      &        auxvec(1))
7920             do jjj=1,2
7921               mmm=mmm+1
7922               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7923             enddo
7924           enddo
7925         enddo
7926       enddo
7927       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7928       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7929       do iii=1,2
7930         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7931       enddo
7932       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7933       do iii=1,2
7934         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7935       enddo
7936       return
7937       end
7938 #endif
7939 C---------------------------------------------------------------------------
7940       subroutine calc_eello(i,j,k,l,jj,kk)
7941 C
7942 C This subroutine computes matrices and vectors needed to calculate
7943 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7944 C
7945       implicit real*8 (a-h,o-z)
7946       include 'DIMENSIONS'
7947       include 'COMMON.IOUNITS'
7948       include 'COMMON.CHAIN'
7949       include 'COMMON.DERIV'
7950       include 'COMMON.INTERACT'
7951       include 'COMMON.CONTACTS'
7952       include 'COMMON.TORSION'
7953       include 'COMMON.VAR'
7954       include 'COMMON.GEO'
7955       include 'COMMON.FFIELD'
7956       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7957      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7958       logical lprn
7959       common /kutas/ lprn
7960 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7961 cd     & ' jj=',jj,' kk=',kk
7962 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7963 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7964 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7965       do iii=1,2
7966         do jjj=1,2
7967           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7968           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7969         enddo
7970       enddo
7971       call transpose2(aa1(1,1),aa1t(1,1))
7972       call transpose2(aa2(1,1),aa2t(1,1))
7973       do kkk=1,5
7974         do lll=1,3
7975           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7976      &      aa1tder(1,1,lll,kkk))
7977           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7978      &      aa2tder(1,1,lll,kkk))
7979         enddo
7980       enddo
7981       if (l.eq.j+1) then
7982 C parallel orientation of the two CA-CA-CA frames.
7983         if (i.gt.1) then
7984           iti=itortyp(itype(i))
7985         else
7986           iti=ntortyp
7987         endif
7988         itk1=itortyp(itype(k+1))
7989         itj=itortyp(itype(j))
7990         if (l.lt.nres-1) then
7991           itl1=itortyp(itype(l+1))
7992         else
7993           itl1=ntortyp
7994         endif
7995 C A1 kernel(j+1) A2T
7996 cd        do iii=1,2
7997 cd          write (iout,'(3f10.5,5x,3f10.5)')
7998 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7999 cd        enddo
8000         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8001      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8002      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8003 C Following matrices are needed only for 6-th order cumulants
8004         IF (wcorr6.gt.0.0d0) THEN
8005         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8006      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8007      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8008         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8009      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8010      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8011      &   ADtEAderx(1,1,1,1,1,1))
8012         lprn=.false.
8013         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8014      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8015      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8016      &   ADtEA1derx(1,1,1,1,1,1))
8017         ENDIF
8018 C End 6-th order cumulants
8019 cd        lprn=.false.
8020 cd        if (lprn) then
8021 cd        write (2,*) 'In calc_eello6'
8022 cd        do iii=1,2
8023 cd          write (2,*) 'iii=',iii
8024 cd          do kkk=1,5
8025 cd            write (2,*) 'kkk=',kkk
8026 cd            do jjj=1,2
8027 cd              write (2,'(3(2f10.5),5x)')
8028 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8029 cd            enddo
8030 cd          enddo
8031 cd        enddo
8032 cd        endif
8033         call transpose2(EUgder(1,1,k),auxmat(1,1))
8034         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8035         call transpose2(EUg(1,1,k),auxmat(1,1))
8036         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8037         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8038         do iii=1,2
8039           do kkk=1,5
8040             do lll=1,3
8041               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8042      &          EAEAderx(1,1,lll,kkk,iii,1))
8043             enddo
8044           enddo
8045         enddo
8046 C A1T kernel(i+1) A2
8047         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8048      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8049      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8050 C Following matrices are needed only for 6-th order cumulants
8051         IF (wcorr6.gt.0.0d0) THEN
8052         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8053      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8054      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8055         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8056      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8057      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8058      &   ADtEAderx(1,1,1,1,1,2))
8059         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8060      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8061      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8062      &   ADtEA1derx(1,1,1,1,1,2))
8063         ENDIF
8064 C End 6-th order cumulants
8065         call transpose2(EUgder(1,1,l),auxmat(1,1))
8066         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8067         call transpose2(EUg(1,1,l),auxmat(1,1))
8068         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8069         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8070         do iii=1,2
8071           do kkk=1,5
8072             do lll=1,3
8073               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8074      &          EAEAderx(1,1,lll,kkk,iii,2))
8075             enddo
8076           enddo
8077         enddo
8078 C AEAb1 and AEAb2
8079 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8080 C They are needed only when the fifth- or the sixth-order cumulants are
8081 C indluded.
8082         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8083         call transpose2(AEA(1,1,1),auxmat(1,1))
8084         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8085         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8086         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8087         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8088         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8089         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8090         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8091         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8092         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8093         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8094         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8095         call transpose2(AEA(1,1,2),auxmat(1,1))
8096         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8097         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8098         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8099         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8100         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8101         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8102         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8103         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8104         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8105         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8106         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8107 C Calculate the Cartesian derivatives of the vectors.
8108         do iii=1,2
8109           do kkk=1,5
8110             do lll=1,3
8111               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8112               call matvec2(auxmat(1,1),b1(1,i),
8113      &          AEAb1derx(1,lll,kkk,iii,1,1))
8114               call matvec2(auxmat(1,1),Ub2(1,i),
8115      &          AEAb2derx(1,lll,kkk,iii,1,1))
8116               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8117      &          AEAb1derx(1,lll,kkk,iii,2,1))
8118               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8119      &          AEAb2derx(1,lll,kkk,iii,2,1))
8120               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8121               call matvec2(auxmat(1,1),b1(1,j),
8122      &          AEAb1derx(1,lll,kkk,iii,1,2))
8123               call matvec2(auxmat(1,1),Ub2(1,j),
8124      &          AEAb2derx(1,lll,kkk,iii,1,2))
8125               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8126      &          AEAb1derx(1,lll,kkk,iii,2,2))
8127               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8128      &          AEAb2derx(1,lll,kkk,iii,2,2))
8129             enddo
8130           enddo
8131         enddo
8132         ENDIF
8133 C End vectors
8134       else
8135 C Antiparallel orientation of the two CA-CA-CA frames.
8136         if (i.gt.1) then
8137           iti=itortyp(itype(i))
8138         else
8139           iti=ntortyp
8140         endif
8141         itk1=itortyp(itype(k+1))
8142         itl=itortyp(itype(l))
8143         itj=itortyp(itype(j))
8144         if (j.lt.nres-1) then
8145           itj1=itortyp(itype(j+1))
8146         else
8147           itj1=ntortyp
8148         endif
8149 C A2 kernel(j-1)T A1T
8150         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8151      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8152      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8153 C Following matrices are needed only for 6-th order cumulants
8154         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8155      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8156         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8157      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8158      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8159         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8160      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8161      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8162      &   ADtEAderx(1,1,1,1,1,1))
8163         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8164      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8165      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8166      &   ADtEA1derx(1,1,1,1,1,1))
8167         ENDIF
8168 C End 6-th order cumulants
8169         call transpose2(EUgder(1,1,k),auxmat(1,1))
8170         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8171         call transpose2(EUg(1,1,k),auxmat(1,1))
8172         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8173         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8174         do iii=1,2
8175           do kkk=1,5
8176             do lll=1,3
8177               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8178      &          EAEAderx(1,1,lll,kkk,iii,1))
8179             enddo
8180           enddo
8181         enddo
8182 C A2T kernel(i+1)T A1
8183         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8184      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8185      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8186 C Following matrices are needed only for 6-th order cumulants
8187         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8188      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8189         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8190      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8191      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8192         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8193      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8194      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8195      &   ADtEAderx(1,1,1,1,1,2))
8196         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8197      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8198      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8199      &   ADtEA1derx(1,1,1,1,1,2))
8200         ENDIF
8201 C End 6-th order cumulants
8202         call transpose2(EUgder(1,1,j),auxmat(1,1))
8203         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8204         call transpose2(EUg(1,1,j),auxmat(1,1))
8205         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8206         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8207         do iii=1,2
8208           do kkk=1,5
8209             do lll=1,3
8210               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8211      &          EAEAderx(1,1,lll,kkk,iii,2))
8212             enddo
8213           enddo
8214         enddo
8215 C AEAb1 and AEAb2
8216 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8217 C They are needed only when the fifth- or the sixth-order cumulants are
8218 C indluded.
8219         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8220      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8221         call transpose2(AEA(1,1,1),auxmat(1,1))
8222         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8223         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8224         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8225         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8226         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8227         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8228         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8229         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8230         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8231         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8232         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8233         call transpose2(AEA(1,1,2),auxmat(1,1))
8234         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8235         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8236         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8237         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8238         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8239         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8240         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8241         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8242         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8243         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8244         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8245 C Calculate the Cartesian derivatives of the vectors.
8246         do iii=1,2
8247           do kkk=1,5
8248             do lll=1,3
8249               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8250               call matvec2(auxmat(1,1),b1(1,i),
8251      &          AEAb1derx(1,lll,kkk,iii,1,1))
8252               call matvec2(auxmat(1,1),Ub2(1,i),
8253      &          AEAb2derx(1,lll,kkk,iii,1,1))
8254               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8255      &          AEAb1derx(1,lll,kkk,iii,2,1))
8256               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8257      &          AEAb2derx(1,lll,kkk,iii,2,1))
8258               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8259               call matvec2(auxmat(1,1),b1(1,l),
8260      &          AEAb1derx(1,lll,kkk,iii,1,2))
8261               call matvec2(auxmat(1,1),Ub2(1,l),
8262      &          AEAb2derx(1,lll,kkk,iii,1,2))
8263               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8264      &          AEAb1derx(1,lll,kkk,iii,2,2))
8265               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8266      &          AEAb2derx(1,lll,kkk,iii,2,2))
8267             enddo
8268           enddo
8269         enddo
8270         ENDIF
8271 C End vectors
8272       endif
8273       return
8274       end
8275 C---------------------------------------------------------------------------
8276       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8277      &  KK,KKderg,AKA,AKAderg,AKAderx)
8278       implicit none
8279       integer nderg
8280       logical transp
8281       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8282      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8283      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8284       integer iii,kkk,lll
8285       integer jjj,mmm
8286       logical lprn
8287       common /kutas/ lprn
8288       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8289       do iii=1,nderg
8290         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8291      &    AKAderg(1,1,iii))
8292       enddo
8293 cd      if (lprn) write (2,*) 'In kernel'
8294       do kkk=1,5
8295 cd        if (lprn) write (2,*) 'kkk=',kkk
8296         do lll=1,3
8297           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8298      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8299 cd          if (lprn) then
8300 cd            write (2,*) 'lll=',lll
8301 cd            write (2,*) 'iii=1'
8302 cd            do jjj=1,2
8303 cd              write (2,'(3(2f10.5),5x)')
8304 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8305 cd            enddo
8306 cd          endif
8307           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8308      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8309 cd          if (lprn) then
8310 cd            write (2,*) 'lll=',lll
8311 cd            write (2,*) 'iii=2'
8312 cd            do jjj=1,2
8313 cd              write (2,'(3(2f10.5),5x)')
8314 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8315 cd            enddo
8316 cd          endif
8317         enddo
8318       enddo
8319       return
8320       end
8321 C---------------------------------------------------------------------------
8322       double precision function eello4(i,j,k,l,jj,kk)
8323       implicit real*8 (a-h,o-z)
8324       include 'DIMENSIONS'
8325       include 'COMMON.IOUNITS'
8326       include 'COMMON.CHAIN'
8327       include 'COMMON.DERIV'
8328       include 'COMMON.INTERACT'
8329       include 'COMMON.CONTACTS'
8330       include 'COMMON.TORSION'
8331       include 'COMMON.VAR'
8332       include 'COMMON.GEO'
8333       double precision pizda(2,2),ggg1(3),ggg2(3)
8334 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8335 cd        eello4=0.0d0
8336 cd        return
8337 cd      endif
8338 cd      print *,'eello4:',i,j,k,l,jj,kk
8339 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8340 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8341 cold      eij=facont_hb(jj,i)
8342 cold      ekl=facont_hb(kk,k)
8343 cold      ekont=eij*ekl
8344       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8345 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8346       gcorr_loc(k-1)=gcorr_loc(k-1)
8347      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8348       if (l.eq.j+1) then
8349         gcorr_loc(l-1)=gcorr_loc(l-1)
8350      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8351       else
8352         gcorr_loc(j-1)=gcorr_loc(j-1)
8353      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8354       endif
8355       do iii=1,2
8356         do kkk=1,5
8357           do lll=1,3
8358             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8359      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8360 cd            derx(lll,kkk,iii)=0.0d0
8361           enddo
8362         enddo
8363       enddo
8364 cd      gcorr_loc(l-1)=0.0d0
8365 cd      gcorr_loc(j-1)=0.0d0
8366 cd      gcorr_loc(k-1)=0.0d0
8367 cd      eel4=1.0d0
8368 cd      write (iout,*)'Contacts have occurred for peptide groups',
8369 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8370 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8371       if (j.lt.nres-1) then
8372         j1=j+1
8373         j2=j-1
8374       else
8375         j1=j-1
8376         j2=j-2
8377       endif
8378       if (l.lt.nres-1) then
8379         l1=l+1
8380         l2=l-1
8381       else
8382         l1=l-1
8383         l2=l-2
8384       endif
8385       do ll=1,3
8386 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8387 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8388         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8389         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8390 cgrad        ghalf=0.5d0*ggg1(ll)
8391         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8392         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8393         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8394         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8395         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8396         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8397 cgrad        ghalf=0.5d0*ggg2(ll)
8398         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8399         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8400         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8401         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8402         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8403         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8404       enddo
8405 cgrad      do m=i+1,j-1
8406 cgrad        do ll=1,3
8407 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8408 cgrad        enddo
8409 cgrad      enddo
8410 cgrad      do m=k+1,l-1
8411 cgrad        do ll=1,3
8412 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8413 cgrad        enddo
8414 cgrad      enddo
8415 cgrad      do m=i+2,j2
8416 cgrad        do ll=1,3
8417 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8418 cgrad        enddo
8419 cgrad      enddo
8420 cgrad      do m=k+2,l2
8421 cgrad        do ll=1,3
8422 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8423 cgrad        enddo
8424 cgrad      enddo
8425 cd      do iii=1,nres-3
8426 cd        write (2,*) iii,gcorr_loc(iii)
8427 cd      enddo
8428       eello4=ekont*eel4
8429 cd      write (2,*) 'ekont',ekont
8430 cd      write (iout,*) 'eello4',ekont*eel4
8431       return
8432       end
8433 C---------------------------------------------------------------------------
8434       double precision function eello5(i,j,k,l,jj,kk)
8435       implicit real*8 (a-h,o-z)
8436       include 'DIMENSIONS'
8437       include 'COMMON.IOUNITS'
8438       include 'COMMON.CHAIN'
8439       include 'COMMON.DERIV'
8440       include 'COMMON.INTERACT'
8441       include 'COMMON.CONTACTS'
8442       include 'COMMON.TORSION'
8443       include 'COMMON.VAR'
8444       include 'COMMON.GEO'
8445       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8446       double precision ggg1(3),ggg2(3)
8447 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8448 C                                                                              C
8449 C                            Parallel chains                                   C
8450 C                                                                              C
8451 C          o             o                   o             o                   C
8452 C         /l\           / \             \   / \           / \   /              C
8453 C        /   \         /   \             \ /   \         /   \ /               C
8454 C       j| o |l1       | o |              o| o |         | o |o                C
8455 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8456 C      \i/   \         /   \ /             /   \         /   \                 C
8457 C       o    k1             o                                                  C
8458 C         (I)          (II)                (III)          (IV)                 C
8459 C                                                                              C
8460 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8461 C                                                                              C
8462 C                            Antiparallel chains                               C
8463 C                                                                              C
8464 C          o             o                   o             o                   C
8465 C         /j\           / \             \   / \           / \   /              C
8466 C        /   \         /   \             \ /   \         /   \ /               C
8467 C      j1| o |l        | o |              o| o |         | o |o                C
8468 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8469 C      \i/   \         /   \ /             /   \         /   \                 C
8470 C       o     k1            o                                                  C
8471 C         (I)          (II)                (III)          (IV)                 C
8472 C                                                                              C
8473 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8474 C                                                                              C
8475 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8476 C                                                                              C
8477 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8478 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8479 cd        eello5=0.0d0
8480 cd        return
8481 cd      endif
8482 cd      write (iout,*)
8483 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8484 cd     &   ' and',k,l
8485       itk=itortyp(itype(k))
8486       itl=itortyp(itype(l))
8487       itj=itortyp(itype(j))
8488       eello5_1=0.0d0
8489       eello5_2=0.0d0
8490       eello5_3=0.0d0
8491       eello5_4=0.0d0
8492 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8493 cd     &   eel5_3_num,eel5_4_num)
8494       do iii=1,2
8495         do kkk=1,5
8496           do lll=1,3
8497             derx(lll,kkk,iii)=0.0d0
8498           enddo
8499         enddo
8500       enddo
8501 cd      eij=facont_hb(jj,i)
8502 cd      ekl=facont_hb(kk,k)
8503 cd      ekont=eij*ekl
8504 cd      write (iout,*)'Contacts have occurred for peptide groups',
8505 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8506 cd      goto 1111
8507 C Contribution from the graph I.
8508 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8509 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8510       call transpose2(EUg(1,1,k),auxmat(1,1))
8511       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8512       vv(1)=pizda(1,1)-pizda(2,2)
8513       vv(2)=pizda(1,2)+pizda(2,1)
8514       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8515      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8516 C Explicit gradient in virtual-dihedral angles.
8517       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8518      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8519      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8520       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8521       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8522       vv(1)=pizda(1,1)-pizda(2,2)
8523       vv(2)=pizda(1,2)+pizda(2,1)
8524       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8525      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8526      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8527       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8528       vv(1)=pizda(1,1)-pizda(2,2)
8529       vv(2)=pizda(1,2)+pizda(2,1)
8530       if (l.eq.j+1) then
8531         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8532      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8533      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8534       else
8535         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8536      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8537      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8538       endif
8539 C Cartesian gradient
8540       do iii=1,2
8541         do kkk=1,5
8542           do lll=1,3
8543             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8544      &        pizda(1,1))
8545             vv(1)=pizda(1,1)-pizda(2,2)
8546             vv(2)=pizda(1,2)+pizda(2,1)
8547             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8548      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8549      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8550           enddo
8551         enddo
8552       enddo
8553 c      goto 1112
8554 c1111  continue
8555 C Contribution from graph II
8556       call transpose2(EE(1,1,itk),auxmat(1,1))
8557       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8558       vv(1)=pizda(1,1)+pizda(2,2)
8559       vv(2)=pizda(2,1)-pizda(1,2)
8560       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8561      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8562 C Explicit gradient in virtual-dihedral angles.
8563       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8564      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8565       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8566       vv(1)=pizda(1,1)+pizda(2,2)
8567       vv(2)=pizda(2,1)-pizda(1,2)
8568       if (l.eq.j+1) then
8569         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8570      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8571      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8572       else
8573         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8574      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8575      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8576       endif
8577 C Cartesian gradient
8578       do iii=1,2
8579         do kkk=1,5
8580           do lll=1,3
8581             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8582      &        pizda(1,1))
8583             vv(1)=pizda(1,1)+pizda(2,2)
8584             vv(2)=pizda(2,1)-pizda(1,2)
8585             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8586      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8587      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8588           enddo
8589         enddo
8590       enddo
8591 cd      goto 1112
8592 cd1111  continue
8593       if (l.eq.j+1) then
8594 cd        goto 1110
8595 C Parallel orientation
8596 C Contribution from graph III
8597         call transpose2(EUg(1,1,l),auxmat(1,1))
8598         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8599         vv(1)=pizda(1,1)-pizda(2,2)
8600         vv(2)=pizda(1,2)+pizda(2,1)
8601         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8602      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8603 C Explicit gradient in virtual-dihedral angles.
8604         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8605      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8606      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8607         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8608         vv(1)=pizda(1,1)-pizda(2,2)
8609         vv(2)=pizda(1,2)+pizda(2,1)
8610         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8611      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8612      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8613         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8614         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8615         vv(1)=pizda(1,1)-pizda(2,2)
8616         vv(2)=pizda(1,2)+pizda(2,1)
8617         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8618      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8619      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8620 C Cartesian gradient
8621         do iii=1,2
8622           do kkk=1,5
8623             do lll=1,3
8624               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8625      &          pizda(1,1))
8626               vv(1)=pizda(1,1)-pizda(2,2)
8627               vv(2)=pizda(1,2)+pizda(2,1)
8628               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8629      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8630      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8631             enddo
8632           enddo
8633         enddo
8634 cd        goto 1112
8635 C Contribution from graph IV
8636 cd1110    continue
8637         call transpose2(EE(1,1,itl),auxmat(1,1))
8638         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8639         vv(1)=pizda(1,1)+pizda(2,2)
8640         vv(2)=pizda(2,1)-pizda(1,2)
8641         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8642      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8643 C Explicit gradient in virtual-dihedral angles.
8644         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8645      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8646         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8647         vv(1)=pizda(1,1)+pizda(2,2)
8648         vv(2)=pizda(2,1)-pizda(1,2)
8649         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8650      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8651      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8652 C Cartesian gradient
8653         do iii=1,2
8654           do kkk=1,5
8655             do lll=1,3
8656               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8657      &          pizda(1,1))
8658               vv(1)=pizda(1,1)+pizda(2,2)
8659               vv(2)=pizda(2,1)-pizda(1,2)
8660               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8661      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8662      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8663             enddo
8664           enddo
8665         enddo
8666       else
8667 C Antiparallel orientation
8668 C Contribution from graph III
8669 c        goto 1110
8670         call transpose2(EUg(1,1,j),auxmat(1,1))
8671         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8672         vv(1)=pizda(1,1)-pizda(2,2)
8673         vv(2)=pizda(1,2)+pizda(2,1)
8674         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8675      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8676 C Explicit gradient in virtual-dihedral angles.
8677         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8678      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8679      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8680         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8681         vv(1)=pizda(1,1)-pizda(2,2)
8682         vv(2)=pizda(1,2)+pizda(2,1)
8683         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8684      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8685      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8686         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8687         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8688         vv(1)=pizda(1,1)-pizda(2,2)
8689         vv(2)=pizda(1,2)+pizda(2,1)
8690         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8691      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8692      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8693 C Cartesian gradient
8694         do iii=1,2
8695           do kkk=1,5
8696             do lll=1,3
8697               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8698      &          pizda(1,1))
8699               vv(1)=pizda(1,1)-pizda(2,2)
8700               vv(2)=pizda(1,2)+pizda(2,1)
8701               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8702      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8703      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8704             enddo
8705           enddo
8706         enddo
8707 cd        goto 1112
8708 C Contribution from graph IV
8709 1110    continue
8710         call transpose2(EE(1,1,itj),auxmat(1,1))
8711         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8712         vv(1)=pizda(1,1)+pizda(2,2)
8713         vv(2)=pizda(2,1)-pizda(1,2)
8714         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8715      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8716 C Explicit gradient in virtual-dihedral angles.
8717         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8718      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8719         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8720         vv(1)=pizda(1,1)+pizda(2,2)
8721         vv(2)=pizda(2,1)-pizda(1,2)
8722         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8723      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8724      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8725 C Cartesian gradient
8726         do iii=1,2
8727           do kkk=1,5
8728             do lll=1,3
8729               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8730      &          pizda(1,1))
8731               vv(1)=pizda(1,1)+pizda(2,2)
8732               vv(2)=pizda(2,1)-pizda(1,2)
8733               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8734      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8735      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8736             enddo
8737           enddo
8738         enddo
8739       endif
8740 1112  continue
8741       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8742 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8743 cd        write (2,*) 'ijkl',i,j,k,l
8744 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8745 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8746 cd      endif
8747 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8748 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8749 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8750 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8751       if (j.lt.nres-1) then
8752         j1=j+1
8753         j2=j-1
8754       else
8755         j1=j-1
8756         j2=j-2
8757       endif
8758       if (l.lt.nres-1) then
8759         l1=l+1
8760         l2=l-1
8761       else
8762         l1=l-1
8763         l2=l-2
8764       endif
8765 cd      eij=1.0d0
8766 cd      ekl=1.0d0
8767 cd      ekont=1.0d0
8768 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8769 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8770 C        summed up outside the subrouine as for the other subroutines
8771 C        handling long-range interactions. The old code is commented out
8772 C        with "cgrad" to keep track of changes.
8773       do ll=1,3
8774 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8775 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8776         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8777         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8778 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8779 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8780 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8781 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8782 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8783 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8784 c     &   gradcorr5ij,
8785 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8786 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8787 cgrad        ghalf=0.5d0*ggg1(ll)
8788 cd        ghalf=0.0d0
8789         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8790         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8791         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8792         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8793         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8794         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8795 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8796 cgrad        ghalf=0.5d0*ggg2(ll)
8797 cd        ghalf=0.0d0
8798         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8799         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8800         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8801         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8802         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8803         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8804       enddo
8805 cd      goto 1112
8806 cgrad      do m=i+1,j-1
8807 cgrad        do ll=1,3
8808 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8809 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8810 cgrad        enddo
8811 cgrad      enddo
8812 cgrad      do m=k+1,l-1
8813 cgrad        do ll=1,3
8814 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8815 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8816 cgrad        enddo
8817 cgrad      enddo
8818 c1112  continue
8819 cgrad      do m=i+2,j2
8820 cgrad        do ll=1,3
8821 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8822 cgrad        enddo
8823 cgrad      enddo
8824 cgrad      do m=k+2,l2
8825 cgrad        do ll=1,3
8826 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8827 cgrad        enddo
8828 cgrad      enddo
8829 cd      do iii=1,nres-3
8830 cd        write (2,*) iii,g_corr5_loc(iii)
8831 cd      enddo
8832       eello5=ekont*eel5
8833 cd      write (2,*) 'ekont',ekont
8834 cd      write (iout,*) 'eello5',ekont*eel5
8835       return
8836       end
8837 c--------------------------------------------------------------------------
8838       double precision function eello6(i,j,k,l,jj,kk)
8839       implicit real*8 (a-h,o-z)
8840       include 'DIMENSIONS'
8841       include 'COMMON.IOUNITS'
8842       include 'COMMON.CHAIN'
8843       include 'COMMON.DERIV'
8844       include 'COMMON.INTERACT'
8845       include 'COMMON.CONTACTS'
8846       include 'COMMON.TORSION'
8847       include 'COMMON.VAR'
8848       include 'COMMON.GEO'
8849       include 'COMMON.FFIELD'
8850       double precision ggg1(3),ggg2(3)
8851 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8852 cd        eello6=0.0d0
8853 cd        return
8854 cd      endif
8855 cd      write (iout,*)
8856 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8857 cd     &   ' and',k,l
8858       eello6_1=0.0d0
8859       eello6_2=0.0d0
8860       eello6_3=0.0d0
8861       eello6_4=0.0d0
8862       eello6_5=0.0d0
8863       eello6_6=0.0d0
8864 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8865 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8866       do iii=1,2
8867         do kkk=1,5
8868           do lll=1,3
8869             derx(lll,kkk,iii)=0.0d0
8870           enddo
8871         enddo
8872       enddo
8873 cd      eij=facont_hb(jj,i)
8874 cd      ekl=facont_hb(kk,k)
8875 cd      ekont=eij*ekl
8876 cd      eij=1.0d0
8877 cd      ekl=1.0d0
8878 cd      ekont=1.0d0
8879       if (l.eq.j+1) then
8880         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8881         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8882         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8883         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8884         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8885         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8886       else
8887         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8888         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8889         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8890         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8891         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8892           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8893         else
8894           eello6_5=0.0d0
8895         endif
8896         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8897       endif
8898 C If turn contributions are considered, they will be handled separately.
8899       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8900 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8901 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8902 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8903 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8904 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8905 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8906 cd      goto 1112
8907       if (j.lt.nres-1) then
8908         j1=j+1
8909         j2=j-1
8910       else
8911         j1=j-1
8912         j2=j-2
8913       endif
8914       if (l.lt.nres-1) then
8915         l1=l+1
8916         l2=l-1
8917       else
8918         l1=l-1
8919         l2=l-2
8920       endif
8921       do ll=1,3
8922 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8923 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8924 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8925 cgrad        ghalf=0.5d0*ggg1(ll)
8926 cd        ghalf=0.0d0
8927         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8928         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8929         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8930         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8931         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8932         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8933         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8934         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8935 cgrad        ghalf=0.5d0*ggg2(ll)
8936 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8937 cd        ghalf=0.0d0
8938         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8939         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8940         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8941         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8942         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8943         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8944       enddo
8945 cd      goto 1112
8946 cgrad      do m=i+1,j-1
8947 cgrad        do ll=1,3
8948 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8949 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8950 cgrad        enddo
8951 cgrad      enddo
8952 cgrad      do m=k+1,l-1
8953 cgrad        do ll=1,3
8954 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8955 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8956 cgrad        enddo
8957 cgrad      enddo
8958 cgrad1112  continue
8959 cgrad      do m=i+2,j2
8960 cgrad        do ll=1,3
8961 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8962 cgrad        enddo
8963 cgrad      enddo
8964 cgrad      do m=k+2,l2
8965 cgrad        do ll=1,3
8966 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8967 cgrad        enddo
8968 cgrad      enddo
8969 cd      do iii=1,nres-3
8970 cd        write (2,*) iii,g_corr6_loc(iii)
8971 cd      enddo
8972       eello6=ekont*eel6
8973 cd      write (2,*) 'ekont',ekont
8974 cd      write (iout,*) 'eello6',ekont*eel6
8975       return
8976       end
8977 c--------------------------------------------------------------------------
8978       double precision function eello6_graph1(i,j,k,l,imat,swap)
8979       implicit real*8 (a-h,o-z)
8980       include 'DIMENSIONS'
8981       include 'COMMON.IOUNITS'
8982       include 'COMMON.CHAIN'
8983       include 'COMMON.DERIV'
8984       include 'COMMON.INTERACT'
8985       include 'COMMON.CONTACTS'
8986       include 'COMMON.TORSION'
8987       include 'COMMON.VAR'
8988       include 'COMMON.GEO'
8989       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8990       logical swap
8991       logical lprn
8992       common /kutas/ lprn
8993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8994 C                                                                              C
8995 C      Parallel       Antiparallel                                             C
8996 C                                                                              C
8997 C          o             o                                                     C
8998 C         /l\           /j\                                                    C
8999 C        /   \         /   \                                                   C
9000 C       /| o |         | o |\                                                  C
9001 C     \ j|/k\|  /   \  |/k\|l /                                                C
9002 C      \ /   \ /     \ /   \ /                                                 C
9003 C       o     o       o     o                                                  C
9004 C       i             i                                                        C
9005 C                                                                              C
9006 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9007       itk=itortyp(itype(k))
9008       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9009       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9010       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9011       call transpose2(EUgC(1,1,k),auxmat(1,1))
9012       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9013       vv1(1)=pizda1(1,1)-pizda1(2,2)
9014       vv1(2)=pizda1(1,2)+pizda1(2,1)
9015       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9016       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9017       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9018       s5=scalar2(vv(1),Dtobr2(1,i))
9019 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9020       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9021       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9022      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9023      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9024      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9025      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9026      & +scalar2(vv(1),Dtobr2der(1,i)))
9027       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9028       vv1(1)=pizda1(1,1)-pizda1(2,2)
9029       vv1(2)=pizda1(1,2)+pizda1(2,1)
9030       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9031       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9032       if (l.eq.j+1) then
9033         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9034      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9035      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9036      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9037      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9038       else
9039         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9040      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9041      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9042      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9043      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9044       endif
9045       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9046       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9047       vv1(1)=pizda1(1,1)-pizda1(2,2)
9048       vv1(2)=pizda1(1,2)+pizda1(2,1)
9049       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9050      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9051      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9052      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9053       do iii=1,2
9054         if (swap) then
9055           ind=3-iii
9056         else
9057           ind=iii
9058         endif
9059         do kkk=1,5
9060           do lll=1,3
9061             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9062             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9063             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9064             call transpose2(EUgC(1,1,k),auxmat(1,1))
9065             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9066      &        pizda1(1,1))
9067             vv1(1)=pizda1(1,1)-pizda1(2,2)
9068             vv1(2)=pizda1(1,2)+pizda1(2,1)
9069             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9070             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9071      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9072             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9073      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9074             s5=scalar2(vv(1),Dtobr2(1,i))
9075             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9076           enddo
9077         enddo
9078       enddo
9079       return
9080       end
9081 c----------------------------------------------------------------------------
9082       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9083       implicit real*8 (a-h,o-z)
9084       include 'DIMENSIONS'
9085       include 'COMMON.IOUNITS'
9086       include 'COMMON.CHAIN'
9087       include 'COMMON.DERIV'
9088       include 'COMMON.INTERACT'
9089       include 'COMMON.CONTACTS'
9090       include 'COMMON.TORSION'
9091       include 'COMMON.VAR'
9092       include 'COMMON.GEO'
9093       logical swap
9094       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9095      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9096       logical lprn
9097       common /kutas/ lprn
9098 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9099 C                                                                              C
9100 C      Parallel       Antiparallel                                             C
9101 C                                                                              C
9102 C          o             o                                                     C
9103 C     \   /l\           /j\   /                                                C
9104 C      \ /   \         /   \ /                                                 C
9105 C       o| o |         | o |o                                                  C
9106 C     \ j|/k\|      \  |/k\|l                                                  C
9107 C      \ /   \       \ /   \                                                   C
9108 C       o             o                                                        C
9109 C       i             i                                                        C
9110 C                                                                              C
9111 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9112 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9113 C AL 7/4/01 s1 would occur in the sixth-order moment,
9114 C           but not in a cluster cumulant
9115 #ifdef MOMENT
9116       s1=dip(1,jj,i)*dip(1,kk,k)
9117 #endif
9118       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9119       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9120       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9121       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9122       call transpose2(EUg(1,1,k),auxmat(1,1))
9123       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9124       vv(1)=pizda(1,1)-pizda(2,2)
9125       vv(2)=pizda(1,2)+pizda(2,1)
9126       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9127 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9128 #ifdef MOMENT
9129       eello6_graph2=-(s1+s2+s3+s4)
9130 #else
9131       eello6_graph2=-(s2+s3+s4)
9132 #endif
9133 c      eello6_graph2=-s3
9134 C Derivatives in gamma(i-1)
9135       if (i.gt.1) then
9136 #ifdef MOMENT
9137         s1=dipderg(1,jj,i)*dip(1,kk,k)
9138 #endif
9139         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9140         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9141         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9142         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9143 #ifdef MOMENT
9144         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9145 #else
9146         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9147 #endif
9148 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9149       endif
9150 C Derivatives in gamma(k-1)
9151 #ifdef MOMENT
9152       s1=dip(1,jj,i)*dipderg(1,kk,k)
9153 #endif
9154       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9155       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9156       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9157       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9158       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9159       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9160       vv(1)=pizda(1,1)-pizda(2,2)
9161       vv(2)=pizda(1,2)+pizda(2,1)
9162       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9163 #ifdef MOMENT
9164       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9165 #else
9166       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9167 #endif
9168 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9169 C Derivatives in gamma(j-1) or gamma(l-1)
9170       if (j.gt.1) then
9171 #ifdef MOMENT
9172         s1=dipderg(3,jj,i)*dip(1,kk,k)
9173 #endif
9174         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9175         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9176         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9177         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9178         vv(1)=pizda(1,1)-pizda(2,2)
9179         vv(2)=pizda(1,2)+pizda(2,1)
9180         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9181 #ifdef MOMENT
9182         if (swap) then
9183           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9184         else
9185           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9186         endif
9187 #endif
9188         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9189 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9190       endif
9191 C Derivatives in gamma(l-1) or gamma(j-1)
9192       if (l.gt.1) then
9193 #ifdef MOMENT
9194         s1=dip(1,jj,i)*dipderg(3,kk,k)
9195 #endif
9196         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9197         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9198         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9199         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9200         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9201         vv(1)=pizda(1,1)-pizda(2,2)
9202         vv(2)=pizda(1,2)+pizda(2,1)
9203         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9204 #ifdef MOMENT
9205         if (swap) then
9206           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9207         else
9208           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9209         endif
9210 #endif
9211         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9212 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9213       endif
9214 C Cartesian derivatives.
9215       if (lprn) then
9216         write (2,*) 'In eello6_graph2'
9217         do iii=1,2
9218           write (2,*) 'iii=',iii
9219           do kkk=1,5
9220             write (2,*) 'kkk=',kkk
9221             do jjj=1,2
9222               write (2,'(3(2f10.5),5x)')
9223      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9224             enddo
9225           enddo
9226         enddo
9227       endif
9228       do iii=1,2
9229         do kkk=1,5
9230           do lll=1,3
9231 #ifdef MOMENT
9232             if (iii.eq.1) then
9233               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9234             else
9235               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9236             endif
9237 #endif
9238             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9239      &        auxvec(1))
9240             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9241             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9242      &        auxvec(1))
9243             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9244             call transpose2(EUg(1,1,k),auxmat(1,1))
9245             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9246      &        pizda(1,1))
9247             vv(1)=pizda(1,1)-pizda(2,2)
9248             vv(2)=pizda(1,2)+pizda(2,1)
9249             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9250 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9251 #ifdef MOMENT
9252             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9253 #else
9254             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9255 #endif
9256             if (swap) then
9257               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9258             else
9259               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9260             endif
9261           enddo
9262         enddo
9263       enddo
9264       return
9265       end
9266 c----------------------------------------------------------------------------
9267       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9268       implicit real*8 (a-h,o-z)
9269       include 'DIMENSIONS'
9270       include 'COMMON.IOUNITS'
9271       include 'COMMON.CHAIN'
9272       include 'COMMON.DERIV'
9273       include 'COMMON.INTERACT'
9274       include 'COMMON.CONTACTS'
9275       include 'COMMON.TORSION'
9276       include 'COMMON.VAR'
9277       include 'COMMON.GEO'
9278       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9279       logical swap
9280 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9281 C                                                                              C
9282 C      Parallel       Antiparallel                                             C
9283 C                                                                              C
9284 C          o             o                                                     C
9285 C         /l\   /   \   /j\                                                    C
9286 C        /   \ /     \ /   \                                                   C
9287 C       /| o |o       o| o |\                                                  C
9288 C       j|/k\|  /      |/k\|l /                                                C
9289 C        /   \ /       /   \ /                                                 C
9290 C       /     o       /     o                                                  C
9291 C       i             i                                                        C
9292 C                                                                              C
9293 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9294 C
9295 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9296 C           energy moment and not to the cluster cumulant.
9297       iti=itortyp(itype(i))
9298       if (j.lt.nres-1) then
9299         itj1=itortyp(itype(j+1))
9300       else
9301         itj1=ntortyp
9302       endif
9303       itk=itortyp(itype(k))
9304       itk1=itortyp(itype(k+1))
9305       if (l.lt.nres-1) then
9306         itl1=itortyp(itype(l+1))
9307       else
9308         itl1=ntortyp
9309       endif
9310 #ifdef MOMENT
9311       s1=dip(4,jj,i)*dip(4,kk,k)
9312 #endif
9313       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9314       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9315       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9316       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9317       call transpose2(EE(1,1,itk),auxmat(1,1))
9318       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9319       vv(1)=pizda(1,1)+pizda(2,2)
9320       vv(2)=pizda(2,1)-pizda(1,2)
9321       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9322 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9323 cd     & "sum",-(s2+s3+s4)
9324 #ifdef MOMENT
9325       eello6_graph3=-(s1+s2+s3+s4)
9326 #else
9327       eello6_graph3=-(s2+s3+s4)
9328 #endif
9329 c      eello6_graph3=-s4
9330 C Derivatives in gamma(k-1)
9331       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9332       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9333       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9334       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9335 C Derivatives in gamma(l-1)
9336       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9337       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9338       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9339       vv(1)=pizda(1,1)+pizda(2,2)
9340       vv(2)=pizda(2,1)-pizda(1,2)
9341       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9342       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9343 C Cartesian derivatives.
9344       do iii=1,2
9345         do kkk=1,5
9346           do lll=1,3
9347 #ifdef MOMENT
9348             if (iii.eq.1) then
9349               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9350             else
9351               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9352             endif
9353 #endif
9354             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9355      &        auxvec(1))
9356             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9357             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9358      &        auxvec(1))
9359             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9360             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9361      &        pizda(1,1))
9362             vv(1)=pizda(1,1)+pizda(2,2)
9363             vv(2)=pizda(2,1)-pizda(1,2)
9364             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9365 #ifdef MOMENT
9366             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9367 #else
9368             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9369 #endif
9370             if (swap) then
9371               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9372             else
9373               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9374             endif
9375 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9376           enddo
9377         enddo
9378       enddo
9379       return
9380       end
9381 c----------------------------------------------------------------------------
9382       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9383       implicit real*8 (a-h,o-z)
9384       include 'DIMENSIONS'
9385       include 'COMMON.IOUNITS'
9386       include 'COMMON.CHAIN'
9387       include 'COMMON.DERIV'
9388       include 'COMMON.INTERACT'
9389       include 'COMMON.CONTACTS'
9390       include 'COMMON.TORSION'
9391       include 'COMMON.VAR'
9392       include 'COMMON.GEO'
9393       include 'COMMON.FFIELD'
9394       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9395      & auxvec1(2),auxmat1(2,2)
9396       logical swap
9397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9398 C                                                                              C
9399 C      Parallel       Antiparallel                                             C
9400 C                                                                              C
9401 C          o             o                                                     C
9402 C         /l\   /   \   /j\                                                    C
9403 C        /   \ /     \ /   \                                                   C
9404 C       /| o |o       o| o |\                                                  C
9405 C     \ j|/k\|      \  |/k\|l                                                  C
9406 C      \ /   \       \ /   \                                                   C
9407 C       o     \       o     \                                                  C
9408 C       i             i                                                        C
9409 C                                                                              C
9410 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9411 C
9412 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9413 C           energy moment and not to the cluster cumulant.
9414 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9415       iti=itortyp(itype(i))
9416       itj=itortyp(itype(j))
9417       if (j.lt.nres-1) then
9418         itj1=itortyp(itype(j+1))
9419       else
9420         itj1=ntortyp
9421       endif
9422       itk=itortyp(itype(k))
9423       if (k.lt.nres-1) then
9424         itk1=itortyp(itype(k+1))
9425       else
9426         itk1=ntortyp
9427       endif
9428       itl=itortyp(itype(l))
9429       if (l.lt.nres-1) then
9430         itl1=itortyp(itype(l+1))
9431       else
9432         itl1=ntortyp
9433       endif
9434 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9435 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9436 cd     & ' itl',itl,' itl1',itl1
9437 #ifdef MOMENT
9438       if (imat.eq.1) then
9439         s1=dip(3,jj,i)*dip(3,kk,k)
9440       else
9441         s1=dip(2,jj,j)*dip(2,kk,l)
9442       endif
9443 #endif
9444       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9445       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9446       if (j.eq.l+1) then
9447         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9448         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9449       else
9450         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9451         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9452       endif
9453       call transpose2(EUg(1,1,k),auxmat(1,1))
9454       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9455       vv(1)=pizda(1,1)-pizda(2,2)
9456       vv(2)=pizda(2,1)+pizda(1,2)
9457       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9458 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9459 #ifdef MOMENT
9460       eello6_graph4=-(s1+s2+s3+s4)
9461 #else
9462       eello6_graph4=-(s2+s3+s4)
9463 #endif
9464 C Derivatives in gamma(i-1)
9465       if (i.gt.1) then
9466 #ifdef MOMENT
9467         if (imat.eq.1) then
9468           s1=dipderg(2,jj,i)*dip(3,kk,k)
9469         else
9470           s1=dipderg(4,jj,j)*dip(2,kk,l)
9471         endif
9472 #endif
9473         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9474         if (j.eq.l+1) then
9475           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9476           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9477         else
9478           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9479           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9480         endif
9481         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9482         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9483 cd          write (2,*) 'turn6 derivatives'
9484 #ifdef MOMENT
9485           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9486 #else
9487           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9488 #endif
9489         else
9490 #ifdef MOMENT
9491           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9492 #else
9493           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9494 #endif
9495         endif
9496       endif
9497 C Derivatives in gamma(k-1)
9498 #ifdef MOMENT
9499       if (imat.eq.1) then
9500         s1=dip(3,jj,i)*dipderg(2,kk,k)
9501       else
9502         s1=dip(2,jj,j)*dipderg(4,kk,l)
9503       endif
9504 #endif
9505       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9506       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9507       if (j.eq.l+1) then
9508         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9509         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9510       else
9511         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9512         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9513       endif
9514       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9515       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9516       vv(1)=pizda(1,1)-pizda(2,2)
9517       vv(2)=pizda(2,1)+pizda(1,2)
9518       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9519       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9520 #ifdef MOMENT
9521         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9522 #else
9523         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9524 #endif
9525       else
9526 #ifdef MOMENT
9527         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9528 #else
9529         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9530 #endif
9531       endif
9532 C Derivatives in gamma(j-1) or gamma(l-1)
9533       if (l.eq.j+1 .and. l.gt.1) then
9534         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9535         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9536         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9537         vv(1)=pizda(1,1)-pizda(2,2)
9538         vv(2)=pizda(2,1)+pizda(1,2)
9539         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9540         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9541       else if (j.gt.1) then
9542         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9543         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9544         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9545         vv(1)=pizda(1,1)-pizda(2,2)
9546         vv(2)=pizda(2,1)+pizda(1,2)
9547         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9548         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9549           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9550         else
9551           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9552         endif
9553       endif
9554 C Cartesian derivatives.
9555       do iii=1,2
9556         do kkk=1,5
9557           do lll=1,3
9558 #ifdef MOMENT
9559             if (iii.eq.1) then
9560               if (imat.eq.1) then
9561                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9562               else
9563                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9564               endif
9565             else
9566               if (imat.eq.1) then
9567                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9568               else
9569                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9570               endif
9571             endif
9572 #endif
9573             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9574      &        auxvec(1))
9575             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9576             if (j.eq.l+1) then
9577               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9578      &          b1(1,j+1),auxvec(1))
9579               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9580             else
9581               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9582      &          b1(1,l+1),auxvec(1))
9583               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9584             endif
9585             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9586      &        pizda(1,1))
9587             vv(1)=pizda(1,1)-pizda(2,2)
9588             vv(2)=pizda(2,1)+pizda(1,2)
9589             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9590             if (swap) then
9591               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9592 #ifdef MOMENT
9593                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9594      &             -(s1+s2+s4)
9595 #else
9596                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9597      &             -(s2+s4)
9598 #endif
9599                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9600               else
9601 #ifdef MOMENT
9602                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9603 #else
9604                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9605 #endif
9606                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9607               endif
9608             else
9609 #ifdef MOMENT
9610               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9611 #else
9612               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9613 #endif
9614               if (l.eq.j+1) then
9615                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9616               else
9617                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9618               endif
9619             endif
9620           enddo
9621         enddo
9622       enddo
9623       return
9624       end
9625 c----------------------------------------------------------------------------
9626       double precision function eello_turn6(i,jj,kk)
9627       implicit real*8 (a-h,o-z)
9628       include 'DIMENSIONS'
9629       include 'COMMON.IOUNITS'
9630       include 'COMMON.CHAIN'
9631       include 'COMMON.DERIV'
9632       include 'COMMON.INTERACT'
9633       include 'COMMON.CONTACTS'
9634       include 'COMMON.TORSION'
9635       include 'COMMON.VAR'
9636       include 'COMMON.GEO'
9637       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9638      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9639      &  ggg1(3),ggg2(3)
9640       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9641      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9642 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9643 C           the respective energy moment and not to the cluster cumulant.
9644       s1=0.0d0
9645       s8=0.0d0
9646       s13=0.0d0
9647 c
9648       eello_turn6=0.0d0
9649       j=i+4
9650       k=i+1
9651       l=i+3
9652       iti=itortyp(itype(i))
9653       itk=itortyp(itype(k))
9654       itk1=itortyp(itype(k+1))
9655       itl=itortyp(itype(l))
9656       itj=itortyp(itype(j))
9657 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9658 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9659 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9660 cd        eello6=0.0d0
9661 cd        return
9662 cd      endif
9663 cd      write (iout,*)
9664 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9665 cd     &   ' and',k,l
9666 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9667       do iii=1,2
9668         do kkk=1,5
9669           do lll=1,3
9670             derx_turn(lll,kkk,iii)=0.0d0
9671           enddo
9672         enddo
9673       enddo
9674 cd      eij=1.0d0
9675 cd      ekl=1.0d0
9676 cd      ekont=1.0d0
9677       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9678 cd      eello6_5=0.0d0
9679 cd      write (2,*) 'eello6_5',eello6_5
9680 #ifdef MOMENT
9681       call transpose2(AEA(1,1,1),auxmat(1,1))
9682       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9683       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9684       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9685 #endif
9686       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9687       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9688       s2 = scalar2(b1(1,k),vtemp1(1))
9689 #ifdef MOMENT
9690       call transpose2(AEA(1,1,2),atemp(1,1))
9691       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9692       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9693       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9694 #endif
9695       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9696       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9697       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9698 #ifdef MOMENT
9699       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9700       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9701       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9702       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9703       ss13 = scalar2(b1(1,k),vtemp4(1))
9704       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9705 #endif
9706 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9707 c      s1=0.0d0
9708 c      s2=0.0d0
9709 c      s8=0.0d0
9710 c      s12=0.0d0
9711 c      s13=0.0d0
9712       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9713 C Derivatives in gamma(i+2)
9714       s1d =0.0d0
9715       s8d =0.0d0
9716 #ifdef MOMENT
9717       call transpose2(AEA(1,1,1),auxmatd(1,1))
9718       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9719       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9720       call transpose2(AEAderg(1,1,2),atempd(1,1))
9721       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9722       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9723 #endif
9724       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9725       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9726       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9727 c      s1d=0.0d0
9728 c      s2d=0.0d0
9729 c      s8d=0.0d0
9730 c      s12d=0.0d0
9731 c      s13d=0.0d0
9732       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9733 C Derivatives in gamma(i+3)
9734 #ifdef MOMENT
9735       call transpose2(AEA(1,1,1),auxmatd(1,1))
9736       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9737       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9738       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9739 #endif
9740       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9741       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9742       s2d = scalar2(b1(1,k),vtemp1d(1))
9743 #ifdef MOMENT
9744       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9745       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9746 #endif
9747       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9748 #ifdef MOMENT
9749       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9750       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9751       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9752 #endif
9753 c      s1d=0.0d0
9754 c      s2d=0.0d0
9755 c      s8d=0.0d0
9756 c      s12d=0.0d0
9757 c      s13d=0.0d0
9758 #ifdef MOMENT
9759       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9760      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9761 #else
9762       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9763      &               -0.5d0*ekont*(s2d+s12d)
9764 #endif
9765 C Derivatives in gamma(i+4)
9766       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9767       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9768       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9769 #ifdef MOMENT
9770       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9771       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9772       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9773 #endif
9774 c      s1d=0.0d0
9775 c      s2d=0.0d0
9776 c      s8d=0.0d0
9777 C      s12d=0.0d0
9778 c      s13d=0.0d0
9779 #ifdef MOMENT
9780       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9781 #else
9782       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9783 #endif
9784 C Derivatives in gamma(i+5)
9785 #ifdef MOMENT
9786       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9787       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9788       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9789 #endif
9790       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9791       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9792       s2d = scalar2(b1(1,k),vtemp1d(1))
9793 #ifdef MOMENT
9794       call transpose2(AEA(1,1,2),atempd(1,1))
9795       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9796       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9797 #endif
9798       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9799       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9800 #ifdef MOMENT
9801       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9802       ss13d = scalar2(b1(1,k),vtemp4d(1))
9803       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9804 #endif
9805 c      s1d=0.0d0
9806 c      s2d=0.0d0
9807 c      s8d=0.0d0
9808 c      s12d=0.0d0
9809 c      s13d=0.0d0
9810 #ifdef MOMENT
9811       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9812      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9813 #else
9814       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9815      &               -0.5d0*ekont*(s2d+s12d)
9816 #endif
9817 C Cartesian derivatives
9818       do iii=1,2
9819         do kkk=1,5
9820           do lll=1,3
9821 #ifdef MOMENT
9822             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9823             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9824             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9825 #endif
9826             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9827             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9828      &          vtemp1d(1))
9829             s2d = scalar2(b1(1,k),vtemp1d(1))
9830 #ifdef MOMENT
9831             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9832             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9833             s8d = -(atempd(1,1)+atempd(2,2))*
9834      &           scalar2(cc(1,1,itl),vtemp2(1))
9835 #endif
9836             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9837      &           auxmatd(1,1))
9838             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9839             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9840 c      s1d=0.0d0
9841 c      s2d=0.0d0
9842 c      s8d=0.0d0
9843 c      s12d=0.0d0
9844 c      s13d=0.0d0
9845 #ifdef MOMENT
9846             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9847      &        - 0.5d0*(s1d+s2d)
9848 #else
9849             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9850      &        - 0.5d0*s2d
9851 #endif
9852 #ifdef MOMENT
9853             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9854      &        - 0.5d0*(s8d+s12d)
9855 #else
9856             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9857      &        - 0.5d0*s12d
9858 #endif
9859           enddo
9860         enddo
9861       enddo
9862 #ifdef MOMENT
9863       do kkk=1,5
9864         do lll=1,3
9865           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9866      &      achuj_tempd(1,1))
9867           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9868           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9869           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9870           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9871           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9872      &      vtemp4d(1))
9873           ss13d = scalar2(b1(1,k),vtemp4d(1))
9874           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9875           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9876         enddo
9877       enddo
9878 #endif
9879 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9880 cd     &  16*eel_turn6_num
9881 cd      goto 1112
9882       if (j.lt.nres-1) then
9883         j1=j+1
9884         j2=j-1
9885       else
9886         j1=j-1
9887         j2=j-2
9888       endif
9889       if (l.lt.nres-1) then
9890         l1=l+1
9891         l2=l-1
9892       else
9893         l1=l-1
9894         l2=l-2
9895       endif
9896       do ll=1,3
9897 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9898 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9899 cgrad        ghalf=0.5d0*ggg1(ll)
9900 cd        ghalf=0.0d0
9901         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9902         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9903         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9904      &    +ekont*derx_turn(ll,2,1)
9905         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9906         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9907      &    +ekont*derx_turn(ll,4,1)
9908         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9909         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9910         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9911 cgrad        ghalf=0.5d0*ggg2(ll)
9912 cd        ghalf=0.0d0
9913         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9914      &    +ekont*derx_turn(ll,2,2)
9915         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9916         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9917      &    +ekont*derx_turn(ll,4,2)
9918         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9919         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9920         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9921       enddo
9922 cd      goto 1112
9923 cgrad      do m=i+1,j-1
9924 cgrad        do ll=1,3
9925 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9926 cgrad        enddo
9927 cgrad      enddo
9928 cgrad      do m=k+1,l-1
9929 cgrad        do ll=1,3
9930 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9931 cgrad        enddo
9932 cgrad      enddo
9933 cgrad1112  continue
9934 cgrad      do m=i+2,j2
9935 cgrad        do ll=1,3
9936 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9937 cgrad        enddo
9938 cgrad      enddo
9939 cgrad      do m=k+2,l2
9940 cgrad        do ll=1,3
9941 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9942 cgrad        enddo
9943 cgrad      enddo
9944 cd      do iii=1,nres-3
9945 cd        write (2,*) iii,g_corr6_loc(iii)
9946 cd      enddo
9947       eello_turn6=ekont*eel_turn6
9948 cd      write (2,*) 'ekont',ekont
9949 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9950       return
9951       end
9952
9953 C-----------------------------------------------------------------------------
9954       double precision function scalar(u,v)
9955 !DIR$ INLINEALWAYS scalar
9956 #ifndef OSF
9957 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9958 #endif
9959       implicit none
9960       double precision u(3),v(3)
9961 cd      double precision sc
9962 cd      integer i
9963 cd      sc=0.0d0
9964 cd      do i=1,3
9965 cd        sc=sc+u(i)*v(i)
9966 cd      enddo
9967 cd      scalar=sc
9968
9969       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9970       return
9971       end
9972 crc-------------------------------------------------
9973       SUBROUTINE MATVEC2(A1,V1,V2)
9974 !DIR$ INLINEALWAYS MATVEC2
9975 #ifndef OSF
9976 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9977 #endif
9978       implicit real*8 (a-h,o-z)
9979       include 'DIMENSIONS'
9980       DIMENSION A1(2,2),V1(2),V2(2)
9981 c      DO 1 I=1,2
9982 c        VI=0.0
9983 c        DO 3 K=1,2
9984 c    3     VI=VI+A1(I,K)*V1(K)
9985 c        Vaux(I)=VI
9986 c    1 CONTINUE
9987
9988       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9989       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9990
9991       v2(1)=vaux1
9992       v2(2)=vaux2
9993       END
9994 C---------------------------------------
9995       SUBROUTINE MATMAT2(A1,A2,A3)
9996 #ifndef OSF
9997 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9998 #endif
9999       implicit real*8 (a-h,o-z)
10000       include 'DIMENSIONS'
10001       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10002 c      DIMENSION AI3(2,2)
10003 c        DO  J=1,2
10004 c          A3IJ=0.0
10005 c          DO K=1,2
10006 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10007 c          enddo
10008 c          A3(I,J)=A3IJ
10009 c       enddo
10010 c      enddo
10011
10012       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10013       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10014       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10015       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10016
10017       A3(1,1)=AI3_11
10018       A3(2,1)=AI3_21
10019       A3(1,2)=AI3_12
10020       A3(2,2)=AI3_22
10021       END
10022
10023 c-------------------------------------------------------------------------
10024       double precision function scalar2(u,v)
10025 !DIR$ INLINEALWAYS scalar2
10026       implicit none
10027       double precision u(2),v(2)
10028       double precision sc
10029       integer i
10030       scalar2=u(1)*v(1)+u(2)*v(2)
10031       return
10032       end
10033
10034 C-----------------------------------------------------------------------------
10035
10036       subroutine transpose2(a,at)
10037 !DIR$ INLINEALWAYS transpose2
10038 #ifndef OSF
10039 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10040 #endif
10041       implicit none
10042       double precision a(2,2),at(2,2)
10043       at(1,1)=a(1,1)
10044       at(1,2)=a(2,1)
10045       at(2,1)=a(1,2)
10046       at(2,2)=a(2,2)
10047       return
10048       end
10049 c--------------------------------------------------------------------------
10050       subroutine transpose(n,a,at)
10051       implicit none
10052       integer n,i,j
10053       double precision a(n,n),at(n,n)
10054       do i=1,n
10055         do j=1,n
10056           at(j,i)=a(i,j)
10057         enddo
10058       enddo
10059       return
10060       end
10061 C---------------------------------------------------------------------------
10062       subroutine prodmat3(a1,a2,kk,transp,prod)
10063 !DIR$ INLINEALWAYS prodmat3
10064 #ifndef OSF
10065 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10066 #endif
10067       implicit none
10068       integer i,j
10069       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10070       logical transp
10071 crc      double precision auxmat(2,2),prod_(2,2)
10072
10073       if (transp) then
10074 crc        call transpose2(kk(1,1),auxmat(1,1))
10075 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10076 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10077
10078            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10079      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10080            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10081      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10082            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10083      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10084            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10085      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10086
10087       else
10088 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10089 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10090
10091            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10092      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10093            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10094      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10095            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10096      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10097            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10098      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10099
10100       endif
10101 c      call transpose2(a2(1,1),a2t(1,1))
10102
10103 crc      print *,transp
10104 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10105 crc      print *,((prod(i,j),i=1,2),j=1,2)
10106
10107       return
10108       end
10109 CCC----------------------------------------------
10110       subroutine Eliptransfer(eliptran)
10111       implicit real*8 (a-h,o-z)
10112       include 'DIMENSIONS'
10113       include 'COMMON.GEO'
10114       include 'COMMON.VAR'
10115       include 'COMMON.LOCAL'
10116       include 'COMMON.CHAIN'
10117       include 'COMMON.DERIV'
10118       include 'COMMON.NAMES'
10119       include 'COMMON.INTERACT'
10120       include 'COMMON.IOUNITS'
10121       include 'COMMON.CALC'
10122       include 'COMMON.CONTROL'
10123       include 'COMMON.SPLITELE'
10124       include 'COMMON.SBRIDGE'
10125 C this is done by Adasko
10126 C      print *,"wchodze"
10127 C structure of box:
10128 C      water
10129 C--bordliptop-- buffore starts
10130 C--bufliptop--- here true lipid starts
10131 C      lipid
10132 C--buflipbot--- lipid ends buffore starts
10133 C--bordlipbot--buffore ends
10134       eliptran=0.0
10135       do i=ilip_start,ilip_end
10136 C       do i=1,1
10137         if (itype(i).eq.ntyp1) cycle
10138
10139         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10140         if (positi.le.0) positi=positi+boxzsize
10141 C        print *,i
10142 C first for peptide groups
10143 c for each residue check if it is in lipid or lipid water border area
10144        if ((positi.gt.bordlipbot)
10145      &.and.(positi.lt.bordliptop)) then
10146 C the energy transfer exist
10147         if (positi.lt.buflipbot) then
10148 C what fraction I am in
10149          fracinbuf=1.0d0-
10150      &        ((positi-bordlipbot)/lipbufthick)
10151 C lipbufthick is thickenes of lipid buffore
10152          sslip=sscalelip(fracinbuf)
10153          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10154          eliptran=eliptran+sslip*pepliptran
10155          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10156          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10157 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10158
10159 C        print *,"doing sccale for lower part"
10160 C         print *,i,sslip,fracinbuf,ssgradlip
10161         elseif (positi.gt.bufliptop) then
10162          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10163          sslip=sscalelip(fracinbuf)
10164          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10165          eliptran=eliptran+sslip*pepliptran
10166          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10167          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10168 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10169 C          print *, "doing sscalefor top part"
10170 C         print *,i,sslip,fracinbuf,ssgradlip
10171         else
10172          eliptran=eliptran+pepliptran
10173 C         print *,"I am in true lipid"
10174         endif
10175 C       else
10176 C       eliptran=elpitran+0.0 ! I am in water
10177        endif
10178        enddo
10179 C       print *, "nic nie bylo w lipidzie?"
10180 C now multiply all by the peptide group transfer factor
10181 C       eliptran=eliptran*pepliptran
10182 C now the same for side chains
10183 CV       do i=1,1
10184        do i=ilip_start,ilip_end
10185         if (itype(i).eq.ntyp1) cycle
10186         positi=(mod(c(3,i+nres),boxzsize))
10187         if (positi.le.0) positi=positi+boxzsize
10188 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10189 c for each residue check if it is in lipid or lipid water border area
10190 C       respos=mod(c(3,i+nres),boxzsize)
10191 C       print *,positi,bordlipbot,buflipbot
10192        if ((positi.gt.bordlipbot)
10193      & .and.(positi.lt.bordliptop)) then
10194 C the energy transfer exist
10195         if (positi.lt.buflipbot) then
10196          fracinbuf=1.0d0-
10197      &     ((positi-bordlipbot)/lipbufthick)
10198 C lipbufthick is thickenes of lipid buffore
10199          sslip=sscalelip(fracinbuf)
10200          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10201          eliptran=eliptran+sslip*liptranene(itype(i))
10202          gliptranx(3,i)=gliptranx(3,i)
10203      &+ssgradlip*liptranene(itype(i))
10204          gliptranc(3,i-1)= gliptranc(3,i-1)
10205      &+ssgradlip*liptranene(itype(i))
10206 C         print *,"doing sccale for lower part"
10207         elseif (positi.gt.bufliptop) then
10208          fracinbuf=1.0d0-
10209      &((bordliptop-positi)/lipbufthick)
10210          sslip=sscalelip(fracinbuf)
10211          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10212          eliptran=eliptran+sslip*liptranene(itype(i))
10213          gliptranx(3,i)=gliptranx(3,i)
10214      &+ssgradlip*liptranene(itype(i))
10215          gliptranc(3,i-1)= gliptranc(3,i-1)
10216      &+ssgradlip*liptranene(itype(i))
10217 C          print *, "doing sscalefor top part",sslip,fracinbuf
10218         else
10219          eliptran=eliptran+liptranene(itype(i))
10220 C         print *,"I am in true lipid"
10221         endif
10222         endif ! if in lipid or buffor
10223 C       else
10224 C       eliptran=elpitran+0.0 ! I am in water
10225        enddo
10226        return
10227        end