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       if (AFMlog.gt.0) then
 277         call AFMforce(Eafmforce)
 278       else if (selfguide.gt.0) then
 279         call AFMvel(Eafmforce)
 280       endif
 281 #ifdef TIMING
 282       time_enecalc=time_enecalc+MPI_Wtime()-time00
 283 #endif
 284 c      print *,"Processor",myrank," computed Uconstr"
 285 #ifdef TIMING
 286       time00=MPI_Wtime()
 287 #endif
 288 c
 289 C Sum the energies
 290 C
 291       energia(1)=evdw
 292 #ifdef SCP14
 293       energia(2)=evdw2-evdw2_14
 294       energia(18)=evdw2_14
 295 #else
 296       energia(2)=evdw2
 297       energia(18)=0.0d0
 298 #endif
 299 #ifdef SPLITELE
 300       energia(3)=ees
 301       energia(16)=evdw1
 302 #else
 303       energia(3)=ees+evdw1
 304       energia(16)=0.0d0
 305 #endif
 306       energia(4)=ecorr
 307       energia(5)=ecorr5
 308       energia(6)=ecorr6
 309       energia(7)=eel_loc
 310       energia(8)=eello_turn3
 311       energia(9)=eello_turn4
 312       energia(10)=eturn6
 313       energia(11)=ebe
 314       energia(12)=escloc
 315       energia(13)=etors
 316       energia(14)=etors_d
 317       energia(15)=ehpb
 318       energia(19)=edihcnstr
 319       energia(17)=estr
 320       energia(20)=Uconst+Uconst_back
 321       energia(21)=esccor
 322       energia(22)=eliptran
 323       energia(23)=Eafmforce
 324 c    Here are the energies showed per procesor if the are more processors
 325 c    per molecule then we sum it up in sum_energy subroutine
 326 c      print *," Processor",myrank," calls SUM_ENERGY"
 327       call sum_energy(energia,.true.)
 328       if (dyn_ss) call dyn_set_nss
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331       time_sumene=time_sumene+MPI_Wtime()-time00
 332 #endif
 333       return
 334       end
 335 c-------------------------------------------------------------------------------
 336       subroutine sum_energy(energia,reduce)
 337       implicit real*8 (a-h,o-z)
 338       include 'DIMENSIONS'
 339 #ifndef ISNAN
 340       external proc_proc
 341 #ifdef WINPGI
 342 cMS$ATTRIBUTES C ::  proc_proc
 343 #endif
 344 #endif
 345 #ifdef MPI
 346       include "mpif.h"
 347 #endif
 348       include 'COMMON.SETUP'
 349       include 'COMMON.IOUNITS'
 350       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 351       include 'COMMON.FFIELD'
 352       include 'COMMON.DERIV'
 353       include 'COMMON.INTERACT'
 354       include 'COMMON.SBRIDGE'
 355       include 'COMMON.CHAIN'
 356       include 'COMMON.VAR'
 357       include 'COMMON.CONTROL'
 358       include 'COMMON.TIME1'
 359       logical reduce
 360 #ifdef MPI
 361       if (nfgtasks.gt.1 .and. reduce) then
 362 #ifdef DEBUG
 363         write (iout,*) "energies before REDUCE"
 364         call enerprint(energia)
 365         call flush(iout)
 366 #endif
 367         do i=0,n_ene
 368           enebuff(i)=energia(i)
 369         enddo
 370         time00=MPI_Wtime()
 371         call MPI_Barrier(FG_COMM,IERR)
 372         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 373         time00=MPI_Wtime()
 374         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 375      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 376 #ifdef DEBUG
 377         write (iout,*) "energies after REDUCE"
 378         call enerprint(energia)
 379         call flush(iout)
 380 #endif
 381         time_Reduce=time_Reduce+MPI_Wtime()-time00
 382       endif
 383       if (fg_rank.eq.0) then
 384 #endif
 385       evdw=energia(1)
 386 #ifdef SCP14
 387       evdw2=energia(2)+energia(18)
 388       evdw2_14=energia(18)
 389 #else
 390       evdw2=energia(2)
 391 #endif
 392 #ifdef SPLITELE
 393       ees=energia(3)
 394       evdw1=energia(16)
 395 #else
 396       ees=energia(3)
 397       evdw1=0.0d0
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eturn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       edihcnstr=energia(19)
 412       estr=energia(17)
 413       Uconst=energia(20)
 414       esccor=energia(21)
 415       eliptran=energia(22)
 416       Eafmforce=energia(23)
 417 #ifdef SPLITELE
 418       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*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+Eafmforce
 424 #else
 425       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 426      & +wang*ebe+wtor*etors+wscloc*escloc
 427      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 428      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 429      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 430      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 431      & +Eafmforce
 432 #endif
 433       energia(0)=etot
 434 c detecting NaNQ
 435 #ifdef ISNAN
 436 #ifdef AIX
 437       if (isnan(etot).ne.0) energia(0)=1.0d+99
 438 #else
 439       if (isnan(etot)) energia(0)=1.0d+99
 440 #endif
 441 #else
 442       i=0
 443 #ifdef WINPGI
 444       idumm=proc_proc(etot,i)
 445 #else
 446       call proc_proc(etot,i)
 447 #endif
 448       if(i.eq.1)energia(0)=1.0d+99
 449 #endif
 450 #ifdef MPI
 451       endif
 452 #endif
 453       return
 454       end
 455 c-------------------------------------------------------------------------------
 456       subroutine sum_gradient
 457       implicit real*8 (a-h,o-z)
 458       include 'DIMENSIONS'
 459 #ifndef ISNAN
 460       external proc_proc
 461 #ifdef WINPGI
 462 cMS$ATTRIBUTES C ::  proc_proc
 463 #endif
 464 #endif
 465 #ifdef MPI
 466       include 'mpif.h'
 467 #endif
 468       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 469      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 470      & ,gloc_scbuf(3,-1:maxres)
 471       include 'COMMON.SETUP'
 472       include 'COMMON.IOUNITS'
 473       include 'COMMON.FFIELD'
 474       include 'COMMON.DERIV'
 475       include 'COMMON.INTERACT'
 476       include 'COMMON.SBRIDGE'
 477       include 'COMMON.CHAIN'
 478       include 'COMMON.VAR'
 479       include 'COMMON.CONTROL'
 480       include 'COMMON.TIME1'
 481       include 'COMMON.MAXGRAD'
 482       include 'COMMON.SCCOR'
 483 #ifdef TIMING
 484       time01=MPI_Wtime()
 485 #endif
 486 #ifdef DEBUG
 487       write (iout,*) "sum_gradient gvdwc, gvdwx"
 488       do i=1,nres
 489         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 490      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 491       enddo
 492       call flush(iout)
 493 #endif
 494 #ifdef MPI
 495 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 496         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 497      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 498 #endif
 499 C
 500 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 501 C            in virtual-bond-vector coordinates
 502 C
 503 #ifdef DEBUG
 504 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 505 c      do i=1,nres-1
 506 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 507 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 508 c      enddo
 509 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 510 c      do i=1,nres-1
 511 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 512 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 513 c      enddo
 514       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 515       do i=1,nres
 516         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 517      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 518      &   g_corr5_loc(i)
 519       enddo
 520       call flush(iout)
 521 #endif
 522 #ifdef SPLITELE
 523       do i=0,nct
 524         do j=1,3
 525           gradbufc(j,i)=wsc*gvdwc(j,i)+
 526      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 527      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 528      &                wel_loc*gel_loc_long(j,i)+
 529      &                wcorr*gradcorr_long(j,i)+
 530      &                wcorr5*gradcorr5_long(j,i)+
 531      &                wcorr6*gradcorr6_long(j,i)+
 532      &                wturn6*gcorr6_turn_long(j,i)+
 533      &                wstrain*ghpbc(j,i)
 534      &                +wliptran*gliptranc(j,i)
 535      &                +gradafm(j,i)
 536
 537         enddo
 538       enddo
 539 #else
 540       do i=0,nct
 541         do j=1,3
 542           gradbufc(j,i)=wsc*gvdwc(j,i)+
 543      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 544      &                welec*gelc_long(j,i)+
 545      &                wbond*gradb(j,i)+
 546      &                wel_loc*gel_loc_long(j,i)+
 547      &                wcorr*gradcorr_long(j,i)+
 548      &                wcorr5*gradcorr5_long(j,i)+
 549      &                wcorr6*gradcorr6_long(j,i)+
 550      &                wturn6*gcorr6_turn_long(j,i)+
 551      &                wstrain*ghpbc(j,i)
 552      &                +wliptran*gliptranc(j,i)
 553      &                +gradafm(j,i)
 554
 555         enddo
 556       enddo
 557 #endif
 558 #ifdef MPI
 559       if (nfgtasks.gt.1) then
 560       time00=MPI_Wtime()
 561 #ifdef DEBUG
 562       write (iout,*) "gradbufc before allreduce"
 563       do i=1,nres
 564         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 565       enddo
 566       call flush(iout)
 567 #endif
 568       do i=0,nres
 569         do j=1,3
 570           gradbufc_sum(j,i)=gradbufc(j,i)
 571         enddo
 572       enddo
 573 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 574 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 575 c      time_reduce=time_reduce+MPI_Wtime()-time00
 576 #ifdef DEBUG
 577 c      write (iout,*) "gradbufc_sum after allreduce"
 578 c      do i=1,nres
 579 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 580 c      enddo
 581 c      call flush(iout)
 582 #endif
 583 #ifdef TIMING
 584 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 585 #endif
 586       do i=nnt,nres
 587         do k=1,3
 588           gradbufc(k,i)=0.0d0
 589         enddo
 590       enddo
 591 #ifdef DEBUG
 592       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 593       write (iout,*) (i," jgrad_start",jgrad_start(i),
 594      &                  " jgrad_end  ",jgrad_end(i),
 595      &                  i=igrad_start,igrad_end)
 596 #endif
 597 c
 598 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 599 c do not parallelize this part.
 600 c
 601 c      do i=igrad_start,igrad_end
 602 c        do j=jgrad_start(i),jgrad_end(i)
 603 c          do k=1,3
 604 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 605 c          enddo
 606 c        enddo
 607 c      enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,-1,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 #ifdef DEBUG
 617       write (iout,*) "gradbufc after summing"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 620       enddo
 621       call flush(iout)
 622 #endif
 623       else
 624 #endif
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632       do i=-1,nres
 633         do j=1,3
 634           gradbufc_sum(j,i)=gradbufc(j,i)
 635           gradbufc(j,i)=0.0d0
 636         enddo
 637       enddo
 638       do j=1,3
 639         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 640       enddo
 641       do i=nres-2,-1,-1
 642         do j=1,3
 643           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 644         enddo
 645       enddo
 646 c      do i=nnt,nres-1
 647 c        do k=1,3
 648 c          gradbufc(k,i)=0.0d0
 649 c        enddo
 650 c        do j=i+1,nres
 651 c          do k=1,3
 652 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 653 c          enddo
 654 c        enddo
 655 c      enddo
 656 #ifdef DEBUG
 657       write (iout,*) "gradbufc after summing"
 658       do i=1,nres
 659         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 660       enddo
 661       call flush(iout)
 662 #endif
 663 #ifdef MPI
 664       endif
 665 #endif
 666       do k=1,3
 667         gradbufc(k,nres)=0.0d0
 668       enddo
 669       do i=-1,nct
 670         do j=1,3
 671 #ifdef SPLITELE
 672           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 673      &                wel_loc*gel_loc(j,i)+
 674      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 675      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 676      &                wel_loc*gel_loc_long(j,i)+
 677      &                wcorr*gradcorr_long(j,i)+
 678      &                wcorr5*gradcorr5_long(j,i)+
 679      &                wcorr6*gradcorr6_long(j,i)+
 680      &                wturn6*gcorr6_turn_long(j,i))+
 681      &                wbond*gradb(j,i)+
 682      &                wcorr*gradcorr(j,i)+
 683      &                wturn3*gcorr3_turn(j,i)+
 684      &                wturn4*gcorr4_turn(j,i)+
 685      &                wcorr5*gradcorr5(j,i)+
 686      &                wcorr6*gradcorr6(j,i)+
 687      &                wturn6*gcorr6_turn(j,i)+
 688      &                wsccor*gsccorc(j,i)
 689      &               +wscloc*gscloc(j,i)
 690      &               +wliptran*gliptranc(j,i)
 691      &                +gradafm(j,i)
 692 #else
 693           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 694      &                wel_loc*gel_loc(j,i)+
 695      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 696      &                welec*gelc_long(j,i)
 697      &                wel_loc*gel_loc_long(j,i)+
 698      &                wcorr*gcorr_long(j,i)+
 699      &                wcorr5*gradcorr5_long(j,i)+
 700      &                wcorr6*gradcorr6_long(j,i)+
 701      &                wturn6*gcorr6_turn_long(j,i))+
 702      &                wbond*gradb(j,i)+
 703      &                wcorr*gradcorr(j,i)+
 704      &                wturn3*gcorr3_turn(j,i)+
 705      &                wturn4*gcorr4_turn(j,i)+
 706      &                wcorr5*gradcorr5(j,i)+
 707      &                wcorr6*gradcorr6(j,i)+
 708      &                wturn6*gcorr6_turn(j,i)+
 709      &                wsccor*gsccorc(j,i)
 710      &               +wscloc*gscloc(j,i)
 711      &               +wliptran*gliptranc(j,i)
 712      &                +gradafm(j,i)
 713
 714 #endif
 715           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 716      &                  wbond*gradbx(j,i)+
 717      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 718      &                  wsccor*gsccorx(j,i)
 719      &                 +wscloc*gsclocx(j,i)
 720      &                 +wliptran*gliptranx(j,i)
 721         enddo
 722       enddo
 723 #ifdef DEBUG
 724       write (iout,*) "gloc before adding corr"
 725       do i=1,4*nres
 726         write (iout,*) i,gloc(i,icg)
 727       enddo
 728 #endif
 729       do i=1,nres-3
 730         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 731      &   +wcorr5*g_corr5_loc(i)
 732      &   +wcorr6*g_corr6_loc(i)
 733      &   +wturn4*gel_loc_turn4(i)
 734      &   +wturn3*gel_loc_turn3(i)
 735      &   +wturn6*gel_loc_turn6(i)
 736      &   +wel_loc*gel_loc_loc(i)
 737       enddo
 738 #ifdef DEBUG
 739       write (iout,*) "gloc after adding corr"
 740       do i=1,4*nres
 741         write (iout,*) i,gloc(i,icg)
 742       enddo
 743 #endif
 744 #ifdef MPI
 745       if (nfgtasks.gt.1) then
 746         do j=1,3
 747           do i=1,nres
 748             gradbufc(j,i)=gradc(j,i,icg)
 749             gradbufx(j,i)=gradx(j,i,icg)
 750           enddo
 751         enddo
 752         do i=1,4*nres
 753           glocbuf(i)=gloc(i,icg)
 754         enddo
 755 c#define DEBUG
 756 #ifdef DEBUG
 757       write (iout,*) "gloc_sc before reduce"
 758       do i=1,nres
 759        do j=1,1
 760         write (iout,*) i,j,gloc_sc(j,i,icg)
 761        enddo
 762       enddo
 763 #endif
 764 c#undef DEBUG
 765         do i=1,nres
 766          do j=1,3
 767           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 768          enddo
 769         enddo
 770         time00=MPI_Wtime()
 771         call MPI_Barrier(FG_COMM,IERR)
 772         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 773         time00=MPI_Wtime()
 774         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 775      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 776         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 777      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 778         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 779      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 780         time_reduce=time_reduce+MPI_Wtime()-time00
 781         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 782      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 783         time_reduce=time_reduce+MPI_Wtime()-time00
 784 c#define DEBUG
 785 #ifdef DEBUG
 786       write (iout,*) "gloc_sc after reduce"
 787       do i=1,nres
 788        do j=1,1
 789         write (iout,*) i,j,gloc_sc(j,i,icg)
 790        enddo
 791       enddo
 792 #endif
 793 c#undef DEBUG
 794 #ifdef DEBUG
 795       write (iout,*) "gloc after reduce"
 796       do i=1,4*nres
 797         write (iout,*) i,gloc(i,icg)
 798       enddo
 799 #endif
 800       endif
 801 #endif
 802       if (gnorm_check) then
 803 c
 804 c Compute the maximum elements of the gradient
 805 c
 806       gvdwc_max=0.0d0
 807       gvdwc_scp_max=0.0d0
 808       gelc_max=0.0d0
 809       gvdwpp_max=0.0d0
 810       gradb_max=0.0d0
 811       ghpbc_max=0.0d0
 812       gradcorr_max=0.0d0
 813       gel_loc_max=0.0d0
 814       gcorr3_turn_max=0.0d0
 815       gcorr4_turn_max=0.0d0
 816       gradcorr5_max=0.0d0
 817       gradcorr6_max=0.0d0
 818       gcorr6_turn_max=0.0d0
 819       gsccorc_max=0.0d0
 820       gscloc_max=0.0d0
 821       gvdwx_max=0.0d0
 822       gradx_scp_max=0.0d0
 823       ghpbx_max=0.0d0
 824       gradxorr_max=0.0d0
 825       gsccorx_max=0.0d0
 826       gsclocx_max=0.0d0
 827       do i=1,nct
 828         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 829         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 830         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 831         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 832      &   gvdwc_scp_max=gvdwc_scp_norm
 833         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 834         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 835         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 836         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 837         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 838         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 839         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 840         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 841         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 842         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 843         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 844         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 845         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 846      &    gcorr3_turn(1,i)))
 847         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 848      &    gcorr3_turn_max=gcorr3_turn_norm
 849         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 850      &    gcorr4_turn(1,i)))
 851         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 852      &    gcorr4_turn_max=gcorr4_turn_norm
 853         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 854         if (gradcorr5_norm.gt.gradcorr5_max)
 855      &    gradcorr5_max=gradcorr5_norm
 856         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 857         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 858         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 859      &    gcorr6_turn(1,i)))
 860         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 861      &    gcorr6_turn_max=gcorr6_turn_norm
 862         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 863         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 864         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 865         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 866         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 867         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 868         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 869         if (gradx_scp_norm.gt.gradx_scp_max)
 870      &    gradx_scp_max=gradx_scp_norm
 871         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 872         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 873         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 874         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 875         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 876         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 877         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 878         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 879       enddo
 880       if (gradout) then
 881 #ifdef AIX
 882         open(istat,file=statname,position="append")
 883 #else
 884         open(istat,file=statname,access="append")
 885 #endif
 886         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 887      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 888      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 889      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 890      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 891      &     gsccorx_max,gsclocx_max
 892         close(istat)
 893         if (gvdwc_max.gt.1.0d4) then
 894           write (iout,*) "gvdwc gvdwx gradb gradbx"
 895           do i=nnt,nct
 896             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 897      &        gradb(j,i),gradbx(j,i),j=1,3)
 898           enddo
 899           call pdbout(0.0d0,'cipiszcze',iout)
 900           call flush(iout)
 901         endif
 902       endif
 903       endif
 904 #ifdef DEBUG
 905       write (iout,*) "gradc gradx gloc"
 906       do i=1,nres
 907         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 908      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 909       enddo
 910 #endif
 911 #ifdef TIMING
 912       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 913 #endif
 914       return
 915       end
 916 c-------------------------------------------------------------------------------
 917       subroutine rescale_weights(t_bath)
 918       implicit real*8 (a-h,o-z)
 919       include 'DIMENSIONS'
 920       include 'COMMON.IOUNITS'
 921       include 'COMMON.FFIELD'
 922       include 'COMMON.SBRIDGE'
 923       double precision kfac /2.4d0/
 924       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 925 c      facT=temp0/t_bath
 926 c      facT=2*temp0/(t_bath+temp0)
 927       if (rescale_mode.eq.0) then
 928         facT=1.0d0
 929         facT2=1.0d0
 930         facT3=1.0d0
 931         facT4=1.0d0
 932         facT5=1.0d0
 933       else if (rescale_mode.eq.1) then
 934         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 935         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 936         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 937         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 938         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 939       else if (rescale_mode.eq.2) then
 940         x=t_bath/temp0
 941         x2=x*x
 942         x3=x2*x
 943         x4=x3*x
 944         x5=x4*x
 945         facT=licznik/dlog(dexp(x)+dexp(-x))
 946         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 947         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 948         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 949         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 950       else
 951         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 952         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 953 #ifdef MPI
 954        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 955 #endif
 956        stop 555
 957       endif
 958       welec=weights(3)*fact
 959       wcorr=weights(4)*fact3
 960       wcorr5=weights(5)*fact4
 961       wcorr6=weights(6)*fact5
 962       wel_loc=weights(7)*fact2
 963       wturn3=weights(8)*fact2
 964       wturn4=weights(9)*fact3
 965       wturn6=weights(10)*fact5
 966       wtor=weights(13)*fact
 967       wtor_d=weights(14)*fact2
 968       wsccor=weights(21)*fact
 969
 970       return
 971       end
 972 C------------------------------------------------------------------------
 973       subroutine enerprint(energia)
 974       implicit real*8 (a-h,o-z)
 975       include 'DIMENSIONS'
 976       include 'COMMON.IOUNITS'
 977       include 'COMMON.FFIELD'
 978       include 'COMMON.SBRIDGE'
 979       include 'COMMON.MD'
 980       double precision energia(0:n_ene)
 981       etot=energia(0)
 982       evdw=energia(1)
 983       evdw2=energia(2)
 984 #ifdef SCP14
 985       evdw2=energia(2)+energia(18)
 986 #else
 987       evdw2=energia(2)
 988 #endif
 989       ees=energia(3)
 990 #ifdef SPLITELE
 991       evdw1=energia(16)
 992 #endif
 993       ecorr=energia(4)
 994       ecorr5=energia(5)
 995       ecorr6=energia(6)
 996       eel_loc=energia(7)
 997       eello_turn3=energia(8)
 998       eello_turn4=energia(9)
 999       eello_turn6=energia(10)
1000       ebe=energia(11)
1001       escloc=energia(12)
1002       etors=energia(13)
1003       etors_d=energia(14)
1004       ehpb=energia(15)
1005       edihcnstr=energia(19)
1006       estr=energia(17)
1007       Uconst=energia(20)
1008       esccor=energia(21)
1009       eliptran=energia(22)
1010       Eafmforce=energia(23)
1011 #ifdef SPLITELE
1012       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1013      &  estr,wbond,ebe,wang,
1014      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1015      &  ecorr,wcorr,
1016      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1017      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1018      &  edihcnstr,ebr*nss,
1019      &  Uconst,eliptran,wliptran,Eafmforce,etot
1020    10 format (/'Virtual-chain energies:'//
1021      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1022      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1023      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1024      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1025      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1026      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1027      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1028      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1029      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1030      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1031      & ' (SS bridges & dist. cnstr.)'/
1032      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1033      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1034      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1035      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1036      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1037      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1038      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1039      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1040      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1041      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1042      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1043      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1044      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1045      & 'ETOT=  ',1pE16.6,' (total)')
1046
1047 #else
1048       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1049      &  estr,wbond,ebe,wang,
1050      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1051      &  ecorr,wcorr,
1052      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1053      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1054      &  ebr*nss,Uconst,eliptran,wliptran,Eafmforc,etot
1055    10 format (/'Virtual-chain energies:'//
1056      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1057      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1058      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1059      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1060      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1061      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1062      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1063      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1064      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1065      & ' (SS bridges & dist. cnstr.)'/
1066      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1067      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1068      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1069      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1070      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1071      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1072      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1073      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1074      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1075      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1076      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1077      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1078      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1079      & 'ETOT=  ',1pE16.6,' (total)')
1080 #endif
1081       return
1082       end
1083 C-----------------------------------------------------------------------
1084       subroutine elj(evdw)
1085 C
1086 C This subroutine calculates the interaction energy of nonbonded side chains
1087 C assuming the LJ potential of interaction.
1088 C
1089       implicit real*8 (a-h,o-z)
1090       include 'DIMENSIONS'
1091       parameter (accur=1.0d-10)
1092       include 'COMMON.GEO'
1093       include 'COMMON.VAR'
1094       include 'COMMON.LOCAL'
1095       include 'COMMON.CHAIN'
1096       include 'COMMON.DERIV'
1097       include 'COMMON.INTERACT'
1098       include 'COMMON.TORSION'
1099       include 'COMMON.SBRIDGE'
1100       include 'COMMON.NAMES'
1101       include 'COMMON.IOUNITS'
1102       include 'COMMON.CONTACTS'
1103       dimension gg(3)
1104 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1105       evdw=0.0D0
1106       do i=iatsc_s,iatsc_e
1107         itypi=iabs(itype(i))
1108         if (itypi.eq.ntyp1) cycle
1109         itypi1=iabs(itype(i+1))
1110         xi=c(1,nres+i)
1111         yi=c(2,nres+i)
1112         zi=c(3,nres+i)
1113 C Change 12/1/95
1114         num_conti=0
1115 C
1116 C Calculate SC interaction energy.
1117 C
1118         do iint=1,nint_gr(i)
1119 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1120 cd   &                  'iend=',iend(i,iint)
1121           do j=istart(i,iint),iend(i,iint)
1122             itypj=iabs(itype(j))
1123             if (itypj.eq.ntyp1) cycle
1124             xj=c(1,nres+j)-xi
1125             yj=c(2,nres+j)-yi
1126             zj=c(3,nres+j)-zi
1127 C Change 12/1/95 to calculate four-body interactions
1128             rij=xj*xj+yj*yj+zj*zj
1129             rrij=1.0D0/rij
1130 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1131             eps0ij=eps(itypi,itypj)
1132             fac=rrij**expon2
1133 C have you changed here?
1134             e1=fac*fac*aa
1135             e2=fac*bb
1136             evdwij=e1+e2
1137 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1138 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1139 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1140 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1141 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1142 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1143             evdw=evdw+evdwij
1144 C
1145 C Calculate the components of the gradient in DC and X
1146 C
1147             fac=-rrij*(e1+evdwij)
1148             gg(1)=xj*fac
1149             gg(2)=yj*fac
1150             gg(3)=zj*fac
1151             do k=1,3
1152               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1153               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1154               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1155               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1156             enddo
1157 cgrad            do k=i,j-1
1158 cgrad              do l=1,3
1159 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1160 cgrad              enddo
1161 cgrad            enddo
1162 C
1163 C 12/1/95, revised on 5/20/97
1164 C
1165 C Calculate the contact function. The ith column of the array JCONT will
1166 C contain the numbers of atoms that make contacts with the atom I (of numbers
1167 C greater than I). The arrays FACONT and GACONT will contain the values of
1168 C the contact function and its derivative.
1169 C
1170 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1171 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1172 C Uncomment next line, if the correlation interactions are contact function only
1173             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1174               rij=dsqrt(rij)
1175               sigij=sigma(itypi,itypj)
1176               r0ij=rs0(itypi,itypj)
1177 C
1178 C Check whether the SC's are not too far to make a contact.
1179 C
1180               rcut=1.5d0*r0ij
1181               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1182 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1183 C
1184               if (fcont.gt.0.0D0) then
1185 C If the SC-SC distance if close to sigma, apply spline.
1186 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1187 cAdam &             fcont1,fprimcont1)
1188 cAdam           fcont1=1.0d0-fcont1
1189 cAdam           if (fcont1.gt.0.0d0) then
1190 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1191 cAdam             fcont=fcont*fcont1
1192 cAdam           endif
1193 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1194 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1195 cga             do k=1,3
1196 cga               gg(k)=gg(k)*eps0ij
1197 cga             enddo
1198 cga             eps0ij=-evdwij*eps0ij
1199 C Uncomment for AL's type of SC correlation interactions.
1200 cadam           eps0ij=-evdwij
1201                 num_conti=num_conti+1
1202                 jcont(num_conti,i)=j
1203                 facont(num_conti,i)=fcont*eps0ij
1204                 fprimcont=eps0ij*fprimcont/rij
1205                 fcont=expon*fcont
1206 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1207 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1208 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1209 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1210                 gacont(1,num_conti,i)=-fprimcont*xj
1211                 gacont(2,num_conti,i)=-fprimcont*yj
1212                 gacont(3,num_conti,i)=-fprimcont*zj
1213 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1214 cd              write (iout,'(2i3,3f10.5)')
1215 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1216               endif
1217             endif
1218           enddo      ! j
1219         enddo        ! iint
1220 C Change 12/1/95
1221         num_cont(i)=num_conti
1222       enddo          ! i
1223       do i=1,nct
1224         do j=1,3
1225           gvdwc(j,i)=expon*gvdwc(j,i)
1226           gvdwx(j,i)=expon*gvdwx(j,i)
1227         enddo
1228       enddo
1229 C******************************************************************************
1230 C
1231 C                              N O T E !!!
1232 C
1233 C To save time, the factor of EXPON has been extracted from ALL components
1234 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1235 C use!
1236 C
1237 C******************************************************************************
1238       return
1239       end
1240 C-----------------------------------------------------------------------------
1241       subroutine eljk(evdw)
1242 C
1243 C This subroutine calculates the interaction energy of nonbonded side chains
1244 C assuming the LJK potential of interaction.
1245 C
1246       implicit real*8 (a-h,o-z)
1247       include 'DIMENSIONS'
1248       include 'COMMON.GEO'
1249       include 'COMMON.VAR'
1250       include 'COMMON.LOCAL'
1251       include 'COMMON.CHAIN'
1252       include 'COMMON.DERIV'
1253       include 'COMMON.INTERACT'
1254       include 'COMMON.IOUNITS'
1255       include 'COMMON.NAMES'
1256       dimension gg(3)
1257       logical scheck
1258 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1259       evdw=0.0D0
1260       do i=iatsc_s,iatsc_e
1261         itypi=iabs(itype(i))
1262         if (itypi.eq.ntyp1) cycle
1263         itypi1=iabs(itype(i+1))
1264         xi=c(1,nres+i)
1265         yi=c(2,nres+i)
1266         zi=c(3,nres+i)
1267 C
1268 C Calculate SC interaction energy.
1269 C
1270         do iint=1,nint_gr(i)
1271           do j=istart(i,iint),iend(i,iint)
1272             itypj=iabs(itype(j))
1273             if (itypj.eq.ntyp1) cycle
1274             xj=c(1,nres+j)-xi
1275             yj=c(2,nres+j)-yi
1276             zj=c(3,nres+j)-zi
1277             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1278             fac_augm=rrij**expon
1279             e_augm=augm(itypi,itypj)*fac_augm
1280             r_inv_ij=dsqrt(rrij)
1281             rij=1.0D0/r_inv_ij
1282             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1283             fac=r_shift_inv**expon
1284 C have you changed here?
1285             e1=fac*fac*aa
1286             e2=fac*bb
1287             evdwij=e_augm+e1+e2
1288 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1289 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1290 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1291 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1292 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1293 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1294 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1295             evdw=evdw+evdwij
1296 C
1297 C Calculate the components of the gradient in DC and X
1298 C
1299             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1300             gg(1)=xj*fac
1301             gg(2)=yj*fac
1302             gg(3)=zj*fac
1303             do k=1,3
1304               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1305               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1306               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1307               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1308             enddo
1309 cgrad            do k=i,j-1
1310 cgrad              do l=1,3
1311 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1312 cgrad              enddo
1313 cgrad            enddo
1314           enddo      ! j
1315         enddo        ! iint
1316       enddo          ! i
1317       do i=1,nct
1318         do j=1,3
1319           gvdwc(j,i)=expon*gvdwc(j,i)
1320           gvdwx(j,i)=expon*gvdwx(j,i)
1321         enddo
1322       enddo
1323       return
1324       end
1325 C-----------------------------------------------------------------------------
1326       subroutine ebp(evdw)
1327 C
1328 C This subroutine calculates the interaction energy of nonbonded side chains
1329 C assuming the Berne-Pechukas potential of interaction.
1330 C
1331       implicit real*8 (a-h,o-z)
1332       include 'DIMENSIONS'
1333       include 'COMMON.GEO'
1334       include 'COMMON.VAR'
1335       include 'COMMON.LOCAL'
1336       include 'COMMON.CHAIN'
1337       include 'COMMON.DERIV'
1338       include 'COMMON.NAMES'
1339       include 'COMMON.INTERACT'
1340       include 'COMMON.IOUNITS'
1341       include 'COMMON.CALC'
1342       common /srutu/ icall
1343 c     double precision rrsave(maxdim)
1344       logical lprn
1345       evdw=0.0D0
1346 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1347       evdw=0.0D0
1348 c     if (icall.eq.0) then
1349 c       lprn=.true.
1350 c     else
1351         lprn=.false.
1352 c     endif
1353       ind=0
1354       do i=iatsc_s,iatsc_e
1355         itypi=iabs(itype(i))
1356         if (itypi.eq.ntyp1) cycle
1357         itypi1=iabs(itype(i+1))
1358         xi=c(1,nres+i)
1359         yi=c(2,nres+i)
1360         zi=c(3,nres+i)
1361         dxi=dc_norm(1,nres+i)
1362         dyi=dc_norm(2,nres+i)
1363         dzi=dc_norm(3,nres+i)
1364 c        dsci_inv=dsc_inv(itypi)
1365         dsci_inv=vbld_inv(i+nres)
1366 C
1367 C Calculate SC interaction energy.
1368 C
1369         do iint=1,nint_gr(i)
1370           do j=istart(i,iint),iend(i,iint)
1371             ind=ind+1
1372             itypj=iabs(itype(j))
1373             if (itypj.eq.ntyp1) cycle
1374 c            dscj_inv=dsc_inv(itypj)
1375             dscj_inv=vbld_inv(j+nres)
1376             chi1=chi(itypi,itypj)
1377             chi2=chi(itypj,itypi)
1378             chi12=chi1*chi2
1379             chip1=chip(itypi)
1380             chip2=chip(itypj)
1381             chip12=chip1*chip2
1382             alf1=alp(itypi)
1383             alf2=alp(itypj)
1384             alf12=0.5D0*(alf1+alf2)
1385 C For diagnostics only!!!
1386 c           chi1=0.0D0
1387 c           chi2=0.0D0
1388 c           chi12=0.0D0
1389 c           chip1=0.0D0
1390 c           chip2=0.0D0
1391 c           chip12=0.0D0
1392 c           alf1=0.0D0
1393 c           alf2=0.0D0
1394 c           alf12=0.0D0
1395             xj=c(1,nres+j)-xi
1396             yj=c(2,nres+j)-yi
1397             zj=c(3,nres+j)-zi
1398             dxj=dc_norm(1,nres+j)
1399             dyj=dc_norm(2,nres+j)
1400             dzj=dc_norm(3,nres+j)
1401             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1402 cd          if (icall.eq.0) then
1403 cd            rrsave(ind)=rrij
1404 cd          else
1405 cd            rrij=rrsave(ind)
1406 cd          endif
1407             rij=dsqrt(rrij)
1408 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1409             call sc_angular
1410 C Calculate whole angle-dependent part of epsilon and contributions
1411 C to its derivatives
1412 C have you changed here?
1413             fac=(rrij*sigsq)**expon2
1414             e1=fac*fac*aa
1415             e2=fac*bb
1416             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1417             eps2der=evdwij*eps3rt
1418             eps3der=evdwij*eps2rt
1419             evdwij=evdwij*eps2rt*eps3rt
1420             evdw=evdw+evdwij
1421             if (lprn) then
1422             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1423             epsi=bb**2/aa
1424 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1425 cd     &        restyp(itypi),i,restyp(itypj),j,
1426 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1427 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1428 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1429 cd     &        evdwij
1430             endif
1431 C Calculate gradient components.
1432             e1=e1*eps1*eps2rt**2*eps3rt**2
1433             fac=-expon*(e1+evdwij)
1434             sigder=fac/sigsq
1435             fac=rrij*fac
1436 C Calculate radial part of the gradient
1437             gg(1)=xj*fac
1438             gg(2)=yj*fac
1439             gg(3)=zj*fac
1440 C Calculate the angular part of the gradient and sum add the contributions
1441 C to the appropriate components of the Cartesian gradient.
1442             call sc_grad
1443           enddo      ! j
1444         enddo        ! iint
1445       enddo          ! i
1446 c     stop
1447       return
1448       end
1449 C-----------------------------------------------------------------------------
1450       subroutine egb(evdw)
1451 C
1452 C This subroutine calculates the interaction energy of nonbonded side chains
1453 C assuming the Gay-Berne potential of interaction.
1454 C
1455       implicit real*8 (a-h,o-z)
1456       include 'DIMENSIONS'
1457       include 'COMMON.GEO'
1458       include 'COMMON.VAR'
1459       include 'COMMON.LOCAL'
1460       include 'COMMON.CHAIN'
1461       include 'COMMON.DERIV'
1462       include 'COMMON.NAMES'
1463       include 'COMMON.INTERACT'
1464       include 'COMMON.IOUNITS'
1465       include 'COMMON.CALC'
1466       include 'COMMON.CONTROL'
1467       include 'COMMON.SPLITELE'
1468       include 'COMMON.SBRIDGE'
1469       logical lprn
1470       integer xshift,yshift,zshift
1471       evdw=0.0D0
1472 ccccc      energy_dec=.false.
1473 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1474       evdw=0.0D0
1475       lprn=.false.
1476 c     if (icall.eq.0) lprn=.false.
1477       ind=0
1478 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1479 C we have the original box)
1480 C      do xshift=-1,1
1481 C      do yshift=-1,1
1482 C      do zshift=-1,1
1483       do i=iatsc_s,iatsc_e
1484         itypi=iabs(itype(i))
1485         if (itypi.eq.ntyp1) cycle
1486         itypi1=iabs(itype(i+1))
1487         xi=c(1,nres+i)
1488         yi=c(2,nres+i)
1489         zi=c(3,nres+i)
1490 C Return atom into box, boxxsize is size of box in x dimension
1491 c  134   continue
1492 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1493 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1494 C Condition for being inside the proper box
1495 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1496 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1497 c        go to 134
1498 c        endif
1499 c  135   continue
1500 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1501 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1502 C Condition for being inside the proper box
1503 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1504 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1505 c        go to 135
1506 c        endif
1507 c  136   continue
1508 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1509 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1510 C Condition for being inside the proper box
1511 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1512 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1513 c        go to 136
1514 c        endif
1515           xi=mod(xi,boxxsize)
1516           if (xi.lt.0) xi=xi+boxxsize
1517           yi=mod(yi,boxysize)
1518           if (yi.lt.0) yi=yi+boxysize
1519           zi=mod(zi,boxzsize)
1520           if (zi.lt.0) zi=zi+boxzsize
1521 C define scaling factor for lipids
1522
1523 C        if (positi.le.0) positi=positi+boxzsize
1524 C        print *,i
1525 C first for peptide groups
1526 c for each residue check if it is in lipid or lipid water border area
1527        if ((zi.gt.bordlipbot)
1528      &.and.(zi.lt.bordliptop)) then
1529 C the energy transfer exist
1530         if (zi.lt.buflipbot) then
1531 C what fraction I am in
1532          fracinbuf=1.0d0-
1533      &        ((zi-bordlipbot)/lipbufthick)
1534 C lipbufthick is thickenes of lipid buffore
1535          sslipi=sscalelip(fracinbuf)
1536          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1537         elseif (zi.gt.bufliptop) then
1538          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1539          sslipi=sscalelip(fracinbuf)
1540          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1541         else
1542          sslipi=1.0d0
1543          ssgradlipi=0.0
1544         endif
1545        else
1546          sslipi=0.0d0
1547          ssgradlipi=0.0
1548        endif
1549
1550 C          xi=xi+xshift*boxxsize
1551 C          yi=yi+yshift*boxysize
1552 C          zi=zi+zshift*boxzsize
1553
1554         dxi=dc_norm(1,nres+i)
1555         dyi=dc_norm(2,nres+i)
1556         dzi=dc_norm(3,nres+i)
1557 c        dsci_inv=dsc_inv(itypi)
1558         dsci_inv=vbld_inv(i+nres)
1559 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1560 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1561 C
1562 C Calculate SC interaction energy.
1563 C
1564         do iint=1,nint_gr(i)
1565           do j=istart(i,iint),iend(i,iint)
1566             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1567               call dyn_ssbond_ene(i,j,evdwij)
1568               evdw=evdw+evdwij
1569               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1570      &                        'evdw',i,j,evdwij,' ss'
1571             ELSE
1572             ind=ind+1
1573             itypj=iabs(itype(j))
1574             if (itypj.eq.ntyp1) cycle
1575 c            dscj_inv=dsc_inv(itypj)
1576             dscj_inv=vbld_inv(j+nres)
1577 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1578 c     &       1.0d0/vbld(j+nres)
1579 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1580             sig0ij=sigma(itypi,itypj)
1581             chi1=chi(itypi,itypj)
1582             chi2=chi(itypj,itypi)
1583             chi12=chi1*chi2
1584             chip1=chip(itypi)
1585             chip2=chip(itypj)
1586             chip12=chip1*chip2
1587             alf1=alp(itypi)
1588             alf2=alp(itypj)
1589             alf12=0.5D0*(alf1+alf2)
1590 C For diagnostics only!!!
1591 c           chi1=0.0D0
1592 c           chi2=0.0D0
1593 c           chi12=0.0D0
1594 c           chip1=0.0D0
1595 c           chip2=0.0D0
1596 c           chip12=0.0D0
1597 c           alf1=0.0D0
1598 c           alf2=0.0D0
1599 c           alf12=0.0D0
1600             xj=c(1,nres+j)
1601             yj=c(2,nres+j)
1602             zj=c(3,nres+j)
1603 C Return atom J into box the original box
1604 c  137   continue
1605 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1606 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1607 C Condition for being inside the proper box
1608 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1609 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1610 c        go to 137
1611 c        endif
1612 c  138   continue
1613 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1614 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1615 C Condition for being inside the proper box
1616 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1617 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1618 c        go to 138
1619 c        endif
1620 c  139   continue
1621 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1622 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1623 C Condition for being inside the proper box
1624 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1625 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1626 c        go to 139
1627 c        endif
1628           xj=mod(xj,boxxsize)
1629           if (xj.lt.0) xj=xj+boxxsize
1630           yj=mod(yj,boxysize)
1631           if (yj.lt.0) yj=yj+boxysize
1632           zj=mod(zj,boxzsize)
1633           if (zj.lt.0) zj=zj+boxzsize
1634        if ((zj.gt.bordlipbot)
1635      &.and.(zj.lt.bordliptop)) then
1636 C the energy transfer exist
1637         if (zj.lt.buflipbot) then
1638 C what fraction I am in
1639          fracinbuf=1.0d0-
1640      &        ((zj-bordlipbot)/lipbufthick)
1641 C lipbufthick is thickenes of lipid buffore
1642          sslipj=sscalelip(fracinbuf)
1643          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1644         elseif (zj.gt.bufliptop) then
1645          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1646          sslipj=sscalelip(fracinbuf)
1647          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1648         else
1649          sslipj=1.0d0
1650          ssgradlipj=0.0
1651         endif
1652        else
1653          sslipj=0.0d0
1654          ssgradlipj=0.0
1655        endif
1656       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1657      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1658       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1659      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1660 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1661 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1662 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1663 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1664       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1665       xj_safe=xj
1666       yj_safe=yj
1667       zj_safe=zj
1668       subchap=0
1669       do xshift=-1,1
1670       do yshift=-1,1
1671       do zshift=-1,1
1672           xj=xj_safe+xshift*boxxsize
1673           yj=yj_safe+yshift*boxysize
1674           zj=zj_safe+zshift*boxzsize
1675           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1676           if(dist_temp.lt.dist_init) then
1677             dist_init=dist_temp
1678             xj_temp=xj
1679             yj_temp=yj
1680             zj_temp=zj
1681             subchap=1
1682           endif
1683        enddo
1684        enddo
1685        enddo
1686        if (subchap.eq.1) then
1687           xj=xj_temp-xi
1688           yj=yj_temp-yi
1689           zj=zj_temp-zi
1690        else
1691           xj=xj_safe-xi
1692           yj=yj_safe-yi
1693           zj=zj_safe-zi
1694        endif
1695             dxj=dc_norm(1,nres+j)
1696             dyj=dc_norm(2,nres+j)
1697             dzj=dc_norm(3,nres+j)
1698 C            xj=xj-xi
1699 C            yj=yj-yi
1700 C            zj=zj-zi
1701 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1702 c            write (iout,*) "j",j," dc_norm",
1703 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1704             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1705             rij=dsqrt(rrij)
1706             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1707             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1708
1709 c            write (iout,'(a7,4f8.3)')
1710 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1711             if (sss.gt.0.0d0) then
1712 C Calculate angle-dependent terms of energy and contributions to their
1713 C derivatives.
1714             call sc_angular
1715             sigsq=1.0D0/sigsq
1716             sig=sig0ij*dsqrt(sigsq)
1717             rij_shift=1.0D0/rij-sig+sig0ij
1718 c for diagnostics; uncomment
1719 c            rij_shift=1.2*sig0ij
1720 C I hate to put IF's in the loops, but here don't have another choice!!!!
1721             if (rij_shift.le.0.0D0) then
1722               evdw=1.0D20
1723 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1724 cd     &        restyp(itypi),i,restyp(itypj),j,
1725 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1726               return
1727             endif
1728             sigder=-sig*sigsq
1729 c---------------------------------------------------------------
1730             rij_shift=1.0D0/rij_shift
1731             fac=rij_shift**expon
1732 C here to start with
1733 C            if (c(i,3).gt.
1734             faclip=fac
1735             e1=fac*fac*aa
1736             e2=fac*bb
1737             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1738             eps2der=evdwij*eps3rt
1739             eps3der=evdwij*eps2rt
1740 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1741 C     &((sslipi+sslipj)/2.0d0+
1742 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1743 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1744 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1745             evdwij=evdwij*eps2rt*eps3rt
1746             evdw=evdw+evdwij*sss
1747             if (lprn) then
1748             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1749             epsi=bb**2/aa
1750             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1751      &        restyp(itypi),i,restyp(itypj),j,
1752      &        epsi,sigm,chi1,chi2,chip1,chip2,
1753      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1754      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1755      &        evdwij
1756             endif
1757
1758             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1759      &                        'evdw',i,j,evdwij
1760
1761 C Calculate gradient components.
1762             e1=e1*eps1*eps2rt**2*eps3rt**2
1763             fac=-expon*(e1+evdwij)*rij_shift
1764             sigder=fac*sigder
1765             fac=rij*fac
1766 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1767 c     &      evdwij,fac,sigma(itypi,itypj),expon
1768             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1769 c            fac=0.0d0
1770 C Calculate the radial part of the gradient
1771             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1772      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1773      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1774      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1775             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1776             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1777 C            gg_lipi(3)=0.0d0
1778 C            gg_lipj(3)=0.0d0
1779             gg(1)=xj*fac
1780             gg(2)=yj*fac
1781             gg(3)=zj*fac
1782 C Calculate angular part of the gradient.
1783             call sc_grad
1784             endif
1785             ENDIF    ! dyn_ss
1786           enddo      ! j
1787         enddo        ! iint
1788       enddo          ! i
1789 C      enddo          ! zshift
1790 C      enddo          ! yshift
1791 C      enddo          ! xshift
1792 c      write (iout,*) "Number of loop steps in EGB:",ind
1793 cccc      energy_dec=.false.
1794       return
1795       end
1796 C-----------------------------------------------------------------------------
1797       subroutine egbv(evdw)
1798 C
1799 C This subroutine calculates the interaction energy of nonbonded side chains
1800 C assuming the Gay-Berne-Vorobjev potential of interaction.
1801 C
1802       implicit real*8 (a-h,o-z)
1803       include 'DIMENSIONS'
1804       include 'COMMON.GEO'
1805       include 'COMMON.VAR'
1806       include 'COMMON.LOCAL'
1807       include 'COMMON.CHAIN'
1808       include 'COMMON.DERIV'
1809       include 'COMMON.NAMES'
1810       include 'COMMON.INTERACT'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CALC'
1813       common /srutu/ icall
1814       logical lprn
1815       evdw=0.0D0
1816 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1817       evdw=0.0D0
1818       lprn=.false.
1819 c     if (icall.eq.0) lprn=.true.
1820       ind=0
1821       do i=iatsc_s,iatsc_e
1822         itypi=iabs(itype(i))
1823         if (itypi.eq.ntyp1) cycle
1824         itypi1=iabs(itype(i+1))
1825         xi=c(1,nres+i)
1826         yi=c(2,nres+i)
1827         zi=c(3,nres+i)
1828           xi=mod(xi,boxxsize)
1829           if (xi.lt.0) xi=xi+boxxsize
1830           yi=mod(yi,boxysize)
1831           if (yi.lt.0) yi=yi+boxysize
1832           zi=mod(zi,boxzsize)
1833           if (zi.lt.0) zi=zi+boxzsize
1834 C define scaling factor for lipids
1835
1836 C        if (positi.le.0) positi=positi+boxzsize
1837 C        print *,i
1838 C first for peptide groups
1839 c for each residue check if it is in lipid or lipid water border area
1840        if ((zi.gt.bordlipbot)
1841      &.and.(zi.lt.bordliptop)) then
1842 C the energy transfer exist
1843         if (zi.lt.buflipbot) then
1844 C what fraction I am in
1845          fracinbuf=1.0d0-
1846      &        ((zi-bordlipbot)/lipbufthick)
1847 C lipbufthick is thickenes of lipid buffore
1848          sslipi=sscalelip(fracinbuf)
1849          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1850         elseif (zi.gt.bufliptop) then
1851          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1852          sslipi=sscalelip(fracinbuf)
1853          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1854         else
1855          sslipi=1.0d0
1856          ssgradlipi=0.0
1857         endif
1858        else
1859          sslipi=0.0d0
1860          ssgradlipi=0.0
1861        endif
1862
1863         dxi=dc_norm(1,nres+i)
1864         dyi=dc_norm(2,nres+i)
1865         dzi=dc_norm(3,nres+i)
1866 c        dsci_inv=dsc_inv(itypi)
1867         dsci_inv=vbld_inv(i+nres)
1868 C
1869 C Calculate SC interaction energy.
1870 C
1871         do iint=1,nint_gr(i)
1872           do j=istart(i,iint),iend(i,iint)
1873             ind=ind+1
1874             itypj=iabs(itype(j))
1875             if (itypj.eq.ntyp1) cycle
1876 c            dscj_inv=dsc_inv(itypj)
1877             dscj_inv=vbld_inv(j+nres)
1878             sig0ij=sigma(itypi,itypj)
1879             r0ij=r0(itypi,itypj)
1880             chi1=chi(itypi,itypj)
1881             chi2=chi(itypj,itypi)
1882             chi12=chi1*chi2
1883             chip1=chip(itypi)
1884             chip2=chip(itypj)
1885             chip12=chip1*chip2
1886             alf1=alp(itypi)
1887             alf2=alp(itypj)
1888             alf12=0.5D0*(alf1+alf2)
1889 C For diagnostics only!!!
1890 c           chi1=0.0D0
1891 c           chi2=0.0D0
1892 c           chi12=0.0D0
1893 c           chip1=0.0D0
1894 c           chip2=0.0D0
1895 c           chip12=0.0D0
1896 c           alf1=0.0D0
1897 c           alf2=0.0D0
1898 c           alf12=0.0D0
1899 C            xj=c(1,nres+j)-xi
1900 C            yj=c(2,nres+j)-yi
1901 C            zj=c(3,nres+j)-zi
1902           xj=mod(xj,boxxsize)
1903           if (xj.lt.0) xj=xj+boxxsize
1904           yj=mod(yj,boxysize)
1905           if (yj.lt.0) yj=yj+boxysize
1906           zj=mod(zj,boxzsize)
1907           if (zj.lt.0) zj=zj+boxzsize
1908        if ((zj.gt.bordlipbot)
1909      &.and.(zj.lt.bordliptop)) then
1910 C the energy transfer exist
1911         if (zj.lt.buflipbot) then
1912 C what fraction I am in
1913          fracinbuf=1.0d0-
1914      &        ((zj-bordlipbot)/lipbufthick)
1915 C lipbufthick is thickenes of lipid buffore
1916          sslipj=sscalelip(fracinbuf)
1917          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1918         elseif (zj.gt.bufliptop) then
1919          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1920          sslipj=sscalelip(fracinbuf)
1921          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1922         else
1923          sslipj=1.0d0
1924          ssgradlipj=0.0
1925         endif
1926        else
1927          sslipj=0.0d0
1928          ssgradlipj=0.0
1929        endif
1930       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1931      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1932       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1933      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1934 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1935 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1936       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1937       xj_safe=xj
1938       yj_safe=yj
1939       zj_safe=zj
1940       subchap=0
1941       do xshift=-1,1
1942       do yshift=-1,1
1943       do zshift=-1,1
1944           xj=xj_safe+xshift*boxxsize
1945           yj=yj_safe+yshift*boxysize
1946           zj=zj_safe+zshift*boxzsize
1947           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1948           if(dist_temp.lt.dist_init) then
1949             dist_init=dist_temp
1950             xj_temp=xj
1951             yj_temp=yj
1952             zj_temp=zj
1953             subchap=1
1954           endif
1955        enddo
1956        enddo
1957        enddo
1958        if (subchap.eq.1) then
1959           xj=xj_temp-xi
1960           yj=yj_temp-yi
1961           zj=zj_temp-zi
1962        else
1963           xj=xj_safe-xi
1964           yj=yj_safe-yi
1965           zj=zj_safe-zi
1966        endif
1967             dxj=dc_norm(1,nres+j)
1968             dyj=dc_norm(2,nres+j)
1969             dzj=dc_norm(3,nres+j)
1970             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1971             rij=dsqrt(rrij)
1972 C Calculate angle-dependent terms of energy and contributions to their
1973 C derivatives.
1974             call sc_angular
1975             sigsq=1.0D0/sigsq
1976             sig=sig0ij*dsqrt(sigsq)
1977             rij_shift=1.0D0/rij-sig+r0ij
1978 C I hate to put IF's in the loops, but here don't have another choice!!!!
1979             if (rij_shift.le.0.0D0) then
1980               evdw=1.0D20
1981               return
1982             endif
1983             sigder=-sig*sigsq
1984 c---------------------------------------------------------------
1985             rij_shift=1.0D0/rij_shift
1986             fac=rij_shift**expon
1987             e1=fac*fac*aa
1988             e2=fac*bb
1989             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1990             eps2der=evdwij*eps3rt
1991             eps3der=evdwij*eps2rt
1992             fac_augm=rrij**expon
1993             e_augm=augm(itypi,itypj)*fac_augm
1994             evdwij=evdwij*eps2rt*eps3rt
1995             evdw=evdw+evdwij+e_augm
1996             if (lprn) then
1997             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1998             epsi=bb**2/aa
1999             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2000      &        restyp(itypi),i,restyp(itypj),j,
2001      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2002      &        chi1,chi2,chip1,chip2,
2003      &        eps1,eps2rt**2,eps3rt**2,
2004      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2005      &        evdwij+e_augm
2006             endif
2007 C Calculate gradient components.
2008             e1=e1*eps1*eps2rt**2*eps3rt**2
2009             fac=-expon*(e1+evdwij)*rij_shift
2010             sigder=fac*sigder
2011             fac=rij*fac-2*expon*rrij*e_augm
2012             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2013 C Calculate the radial part of the gradient
2014             gg(1)=xj*fac
2015             gg(2)=yj*fac
2016             gg(3)=zj*fac
2017 C Calculate angular part of the gradient.
2018             call sc_grad
2019           enddo      ! j
2020         enddo        ! iint
2021       enddo          ! i
2022       end
2023 C-----------------------------------------------------------------------------
2024       subroutine sc_angular
2025 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2026 C om12. Called by ebp, egb, and egbv.
2027       implicit none
2028       include 'COMMON.CALC'
2029       include 'COMMON.IOUNITS'
2030       erij(1)=xj*rij
2031       erij(2)=yj*rij
2032       erij(3)=zj*rij
2033       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2034       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2035       om12=dxi*dxj+dyi*dyj+dzi*dzj
2036       chiom12=chi12*om12
2037 C Calculate eps1(om12) and its derivative in om12
2038       faceps1=1.0D0-om12*chiom12
2039       faceps1_inv=1.0D0/faceps1
2040       eps1=dsqrt(faceps1_inv)
2041 C Following variable is eps1*deps1/dom12
2042       eps1_om12=faceps1_inv*chiom12
2043 c diagnostics only
2044 c      faceps1_inv=om12
2045 c      eps1=om12
2046 c      eps1_om12=1.0d0
2047 c      write (iout,*) "om12",om12," eps1",eps1
2048 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2049 C and om12.
2050       om1om2=om1*om2
2051       chiom1=chi1*om1
2052       chiom2=chi2*om2
2053       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2054       sigsq=1.0D0-facsig*faceps1_inv
2055       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2056       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2057       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2058 c diagnostics only
2059 c      sigsq=1.0d0
2060 c      sigsq_om1=0.0d0
2061 c      sigsq_om2=0.0d0
2062 c      sigsq_om12=0.0d0
2063 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2064 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2065 c     &    " eps1",eps1
2066 C Calculate eps2 and its derivatives in om1, om2, and om12.
2067       chipom1=chip1*om1
2068       chipom2=chip2*om2
2069       chipom12=chip12*om12
2070       facp=1.0D0-om12*chipom12
2071       facp_inv=1.0D0/facp
2072       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2073 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2074 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2075 C Following variable is the square root of eps2
2076       eps2rt=1.0D0-facp1*facp_inv
2077 C Following three variables are the derivatives of the square root of eps
2078 C in om1, om2, and om12.
2079       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2080       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2081       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2082 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2083       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2084 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2085 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2086 c     &  " eps2rt_om12",eps2rt_om12
2087 C Calculate whole angle-dependent part of epsilon and contributions
2088 C to its derivatives
2089       return
2090       end
2091 C----------------------------------------------------------------------------
2092       subroutine sc_grad
2093       implicit real*8 (a-h,o-z)
2094       include 'DIMENSIONS'
2095       include 'COMMON.CHAIN'
2096       include 'COMMON.DERIV'
2097       include 'COMMON.CALC'
2098       include 'COMMON.IOUNITS'
2099       double precision dcosom1(3),dcosom2(3)
2100 cc      print *,'sss=',sss
2101       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2102       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2103       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2104      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2105 c diagnostics only
2106 c      eom1=0.0d0
2107 c      eom2=0.0d0
2108 c      eom12=evdwij*eps1_om12
2109 c end diagnostics
2110 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2111 c     &  " sigder",sigder
2112 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2113 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2114       do k=1,3
2115         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2116         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2117       enddo
2118       do k=1,3
2119         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2120       enddo
2121 c      write (iout,*) "gg",(gg(k),k=1,3)
2122       do k=1,3
2123         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2124      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2125      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2126         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2127      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2128      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2129 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2130 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2131 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2132 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2133       enddo
2134 C
2135 C Calculate the components of the gradient in DC and X
2136 C
2137 cgrad      do k=i,j-1
2138 cgrad        do l=1,3
2139 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2140 cgrad        enddo
2141 cgrad      enddo
2142       do l=1,3
2143         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2144         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2145       enddo
2146       return
2147       end
2148 C-----------------------------------------------------------------------
2149       subroutine e_softsphere(evdw)
2150 C
2151 C This subroutine calculates the interaction energy of nonbonded side chains
2152 C assuming the LJ potential of interaction.
2153 C
2154       implicit real*8 (a-h,o-z)
2155       include 'DIMENSIONS'
2156       parameter (accur=1.0d-10)
2157       include 'COMMON.GEO'
2158       include 'COMMON.VAR'
2159       include 'COMMON.LOCAL'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.DERIV'
2162       include 'COMMON.INTERACT'
2163       include 'COMMON.TORSION'
2164       include 'COMMON.SBRIDGE'
2165       include 'COMMON.NAMES'
2166       include 'COMMON.IOUNITS'
2167       include 'COMMON.CONTACTS'
2168       dimension gg(3)
2169 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2170       evdw=0.0D0
2171       do i=iatsc_s,iatsc_e
2172         itypi=iabs(itype(i))
2173         if (itypi.eq.ntyp1) cycle
2174         itypi1=iabs(itype(i+1))
2175         xi=c(1,nres+i)
2176         yi=c(2,nres+i)
2177         zi=c(3,nres+i)
2178 C
2179 C Calculate SC interaction energy.
2180 C
2181         do iint=1,nint_gr(i)
2182 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2183 cd   &                  'iend=',iend(i,iint)
2184           do j=istart(i,iint),iend(i,iint)
2185             itypj=iabs(itype(j))
2186             if (itypj.eq.ntyp1) cycle
2187             xj=c(1,nres+j)-xi
2188             yj=c(2,nres+j)-yi
2189             zj=c(3,nres+j)-zi
2190             rij=xj*xj+yj*yj+zj*zj
2191 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2192             r0ij=r0(itypi,itypj)
2193             r0ijsq=r0ij*r0ij
2194 c            print *,i,j,r0ij,dsqrt(rij)
2195             if (rij.lt.r0ijsq) then
2196               evdwij=0.25d0*(rij-r0ijsq)**2
2197               fac=rij-r0ijsq
2198             else
2199               evdwij=0.0d0
2200               fac=0.0d0
2201             endif
2202             evdw=evdw+evdwij
2203 C
2204 C Calculate the components of the gradient in DC and X
2205 C
2206             gg(1)=xj*fac
2207             gg(2)=yj*fac
2208             gg(3)=zj*fac
2209             do k=1,3
2210               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2211               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2212               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2213               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2214             enddo
2215 cgrad            do k=i,j-1
2216 cgrad              do l=1,3
2217 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2218 cgrad              enddo
2219 cgrad            enddo
2220           enddo ! j
2221         enddo ! iint
2222       enddo ! i
2223       return
2224       end
2225 C--------------------------------------------------------------------------
2226       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2227      &              eello_turn4)
2228 C
2229 C Soft-sphere potential of p-p interaction
2230 C
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233       include 'COMMON.CONTROL'
2234       include 'COMMON.IOUNITS'
2235       include 'COMMON.GEO'
2236       include 'COMMON.VAR'
2237       include 'COMMON.LOCAL'
2238       include 'COMMON.CHAIN'
2239       include 'COMMON.DERIV'
2240       include 'COMMON.INTERACT'
2241       include 'COMMON.CONTACTS'
2242       include 'COMMON.TORSION'
2243       include 'COMMON.VECTORS'
2244       include 'COMMON.FFIELD'
2245       dimension ggg(3)
2246 C      write(iout,*) 'In EELEC_soft_sphere'
2247       ees=0.0D0
2248       evdw1=0.0D0
2249       eel_loc=0.0d0
2250       eello_turn3=0.0d0
2251       eello_turn4=0.0d0
2252       ind=0
2253       do i=iatel_s,iatel_e
2254         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2255         dxi=dc(1,i)
2256         dyi=dc(2,i)
2257         dzi=dc(3,i)
2258         xmedi=c(1,i)+0.5d0*dxi
2259         ymedi=c(2,i)+0.5d0*dyi
2260         zmedi=c(3,i)+0.5d0*dzi
2261           xmedi=mod(xmedi,boxxsize)
2262           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2263           ymedi=mod(ymedi,boxysize)
2264           if (ymedi.lt.0) ymedi=ymedi+boxysize
2265           zmedi=mod(zmedi,boxzsize)
2266           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2267         num_conti=0
2268 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2269         do j=ielstart(i),ielend(i)
2270           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2271           ind=ind+1
2272           iteli=itel(i)
2273           itelj=itel(j)
2274           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2275           r0ij=rpp(iteli,itelj)
2276           r0ijsq=r0ij*r0ij
2277           dxj=dc(1,j)
2278           dyj=dc(2,j)
2279           dzj=dc(3,j)
2280           xj=c(1,j)+0.5D0*dxj
2281           yj=c(2,j)+0.5D0*dyj
2282           zj=c(3,j)+0.5D0*dzj
2283           xj=mod(xj,boxxsize)
2284           if (xj.lt.0) xj=xj+boxxsize
2285           yj=mod(yj,boxysize)
2286           if (yj.lt.0) yj=yj+boxysize
2287           zj=mod(zj,boxzsize)
2288           if (zj.lt.0) zj=zj+boxzsize
2289       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2290       xj_safe=xj
2291       yj_safe=yj
2292       zj_safe=zj
2293       isubchap=0
2294       do xshift=-1,1
2295       do yshift=-1,1
2296       do zshift=-1,1
2297           xj=xj_safe+xshift*boxxsize
2298           yj=yj_safe+yshift*boxysize
2299           zj=zj_safe+zshift*boxzsize
2300           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2301           if(dist_temp.lt.dist_init) then
2302             dist_init=dist_temp
2303             xj_temp=xj
2304             yj_temp=yj
2305             zj_temp=zj
2306             isubchap=1
2307           endif
2308        enddo
2309        enddo
2310        enddo
2311        if (isubchap.eq.1) then
2312           xj=xj_temp-xmedi
2313           yj=yj_temp-ymedi
2314           zj=zj_temp-zmedi
2315        else
2316           xj=xj_safe-xmedi
2317           yj=yj_safe-ymedi
2318           zj=zj_safe-zmedi
2319        endif
2320           rij=xj*xj+yj*yj+zj*zj
2321             sss=sscale(sqrt(rij))
2322             sssgrad=sscagrad(sqrt(rij))
2323           if (rij.lt.r0ijsq) then
2324             evdw1ij=0.25d0*(rij-r0ijsq)**2
2325             fac=rij-r0ijsq
2326           else
2327             evdw1ij=0.0d0
2328             fac=0.0d0
2329           endif
2330           evdw1=evdw1+evdw1ij*sss
2331 C
2332 C Calculate contributions to the Cartesian gradient.
2333 C
2334           ggg(1)=fac*xj*sssgrad
2335           ggg(2)=fac*yj*sssgrad
2336           ggg(3)=fac*zj*sssgrad
2337           do k=1,3
2338             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2339             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2340           enddo
2341 *
2342 * Loop over residues i+1 thru j-1.
2343 *
2344 cgrad          do k=i+1,j-1
2345 cgrad            do l=1,3
2346 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2347 cgrad            enddo
2348 cgrad          enddo
2349         enddo ! j
2350       enddo   ! i
2351 cgrad      do i=nnt,nct-1
2352 cgrad        do k=1,3
2353 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2354 cgrad        enddo
2355 cgrad        do j=i+1,nct-1
2356 cgrad          do k=1,3
2357 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2358 cgrad          enddo
2359 cgrad        enddo
2360 cgrad      enddo
2361       return
2362       end
2363 c------------------------------------------------------------------------------
2364       subroutine vec_and_deriv
2365       implicit real*8 (a-h,o-z)
2366       include 'DIMENSIONS'
2367 #ifdef MPI
2368       include 'mpif.h'
2369 #endif
2370       include 'COMMON.IOUNITS'
2371       include 'COMMON.GEO'
2372       include 'COMMON.VAR'
2373       include 'COMMON.LOCAL'
2374       include 'COMMON.CHAIN'
2375       include 'COMMON.VECTORS'
2376       include 'COMMON.SETUP'
2377       include 'COMMON.TIME1'
2378       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2379 C Compute the local reference systems. For reference system (i), the
2380 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2381 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2382 #ifdef PARVEC
2383       do i=ivec_start,ivec_end
2384 #else
2385       do i=1,nres-1
2386 #endif
2387           if (i.eq.nres-1) then
2388 C Case of the last full residue
2389 C Compute the Z-axis
2390             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2391             costh=dcos(pi-theta(nres))
2392             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2393             do k=1,3
2394               uz(k,i)=fac*uz(k,i)
2395             enddo
2396 C Compute the derivatives of uz
2397             uzder(1,1,1)= 0.0d0
2398             uzder(2,1,1)=-dc_norm(3,i-1)
2399             uzder(3,1,1)= dc_norm(2,i-1)
2400             uzder(1,2,1)= dc_norm(3,i-1)
2401             uzder(2,2,1)= 0.0d0
2402             uzder(3,2,1)=-dc_norm(1,i-1)
2403             uzder(1,3,1)=-dc_norm(2,i-1)
2404             uzder(2,3,1)= dc_norm(1,i-1)
2405             uzder(3,3,1)= 0.0d0
2406             uzder(1,1,2)= 0.0d0
2407             uzder(2,1,2)= dc_norm(3,i)
2408             uzder(3,1,2)=-dc_norm(2,i)
2409             uzder(1,2,2)=-dc_norm(3,i)
2410             uzder(2,2,2)= 0.0d0
2411             uzder(3,2,2)= dc_norm(1,i)
2412             uzder(1,3,2)= dc_norm(2,i)
2413             uzder(2,3,2)=-dc_norm(1,i)
2414             uzder(3,3,2)= 0.0d0
2415 C Compute the Y-axis
2416             facy=fac
2417             do k=1,3
2418               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2419             enddo
2420 C Compute the derivatives of uy
2421             do j=1,3
2422               do k=1,3
2423                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2424      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2425                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2426               enddo
2427               uyder(j,j,1)=uyder(j,j,1)-costh
2428               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2429             enddo
2430             do j=1,2
2431               do k=1,3
2432                 do l=1,3
2433                   uygrad(l,k,j,i)=uyder(l,k,j)
2434                   uzgrad(l,k,j,i)=uzder(l,k,j)
2435                 enddo
2436               enddo
2437             enddo
2438             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2439             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2440             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2441             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2442           else
2443 C Other residues
2444 C Compute the Z-axis
2445             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2446             costh=dcos(pi-theta(i+2))
2447             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2448             do k=1,3
2449               uz(k,i)=fac*uz(k,i)
2450             enddo
2451 C Compute the derivatives of uz
2452             uzder(1,1,1)= 0.0d0
2453             uzder(2,1,1)=-dc_norm(3,i+1)
2454             uzder(3,1,1)= dc_norm(2,i+1)
2455             uzder(1,2,1)= dc_norm(3,i+1)
2456             uzder(2,2,1)= 0.0d0
2457             uzder(3,2,1)=-dc_norm(1,i+1)
2458             uzder(1,3,1)=-dc_norm(2,i+1)
2459             uzder(2,3,1)= dc_norm(1,i+1)
2460             uzder(3,3,1)= 0.0d0
2461             uzder(1,1,2)= 0.0d0
2462             uzder(2,1,2)= dc_norm(3,i)
2463             uzder(3,1,2)=-dc_norm(2,i)
2464             uzder(1,2,2)=-dc_norm(3,i)
2465             uzder(2,2,2)= 0.0d0
2466             uzder(3,2,2)= dc_norm(1,i)
2467             uzder(1,3,2)= dc_norm(2,i)
2468             uzder(2,3,2)=-dc_norm(1,i)
2469             uzder(3,3,2)= 0.0d0
2470 C Compute the Y-axis
2471             facy=fac
2472             do k=1,3
2473               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2474             enddo
2475 C Compute the derivatives of uy
2476             do j=1,3
2477               do k=1,3
2478                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2479      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2480                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2481               enddo
2482               uyder(j,j,1)=uyder(j,j,1)-costh
2483               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2484             enddo
2485             do j=1,2
2486               do k=1,3
2487                 do l=1,3
2488                   uygrad(l,k,j,i)=uyder(l,k,j)
2489                   uzgrad(l,k,j,i)=uzder(l,k,j)
2490                 enddo
2491               enddo
2492             enddo
2493             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2494             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2495             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2496             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2497           endif
2498       enddo
2499       do i=1,nres-1
2500         vbld_inv_temp(1)=vbld_inv(i+1)
2501         if (i.lt.nres-1) then
2502           vbld_inv_temp(2)=vbld_inv(i+2)
2503           else
2504           vbld_inv_temp(2)=vbld_inv(i)
2505           endif
2506         do j=1,2
2507           do k=1,3
2508             do l=1,3
2509               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2510               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2511             enddo
2512           enddo
2513         enddo
2514       enddo
2515 #if defined(PARVEC) && defined(MPI)
2516       if (nfgtasks1.gt.1) then
2517         time00=MPI_Wtime()
2518 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2519 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2520 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2521         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2528      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2529      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2530         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2531      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2532      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2533         time_gather=time_gather+MPI_Wtime()-time00
2534       endif
2535 c      if (fg_rank.eq.0) then
2536 c        write (iout,*) "Arrays UY and UZ"
2537 c        do i=1,nres-1
2538 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2539 c     &     (uz(k,i),k=1,3)
2540 c        enddo
2541 c      endif
2542 #endif
2543       return
2544       end
2545 C-----------------------------------------------------------------------------
2546       subroutine check_vecgrad
2547       implicit real*8 (a-h,o-z)
2548       include 'DIMENSIONS'
2549       include 'COMMON.IOUNITS'
2550       include 'COMMON.GEO'
2551       include 'COMMON.VAR'
2552       include 'COMMON.LOCAL'
2553       include 'COMMON.CHAIN'
2554       include 'COMMON.VECTORS'
2555       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2556       dimension uyt(3,maxres),uzt(3,maxres)
2557       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2558       double precision delta /1.0d-7/
2559       call vec_and_deriv
2560 cd      do i=1,nres
2561 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2562 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2563 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2564 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2565 cd     &     (dc_norm(if90,i),if90=1,3)
2566 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2567 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2568 cd          write(iout,'(a)')
2569 cd      enddo
2570       do i=1,nres
2571         do j=1,2
2572           do k=1,3
2573             do l=1,3
2574               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2575               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2576             enddo
2577           enddo
2578         enddo
2579       enddo
2580       call vec_and_deriv
2581       do i=1,nres
2582         do j=1,3
2583           uyt(j,i)=uy(j,i)
2584           uzt(j,i)=uz(j,i)
2585         enddo
2586       enddo
2587       do i=1,nres
2588 cd        write (iout,*) 'i=',i
2589         do k=1,3
2590           erij(k)=dc_norm(k,i)
2591         enddo
2592         do j=1,3
2593           do k=1,3
2594             dc_norm(k,i)=erij(k)
2595           enddo
2596           dc_norm(j,i)=dc_norm(j,i)+delta
2597 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2598 c          do k=1,3
2599 c            dc_norm(k,i)=dc_norm(k,i)/fac
2600 c          enddo
2601 c          write (iout,*) (dc_norm(k,i),k=1,3)
2602 c          write (iout,*) (erij(k),k=1,3)
2603           call vec_and_deriv
2604           do k=1,3
2605             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2606             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2607             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2608             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2609           enddo
2610 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2611 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2612 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2613         enddo
2614         do k=1,3
2615           dc_norm(k,i)=erij(k)
2616         enddo
2617 cd        do k=1,3
2618 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2619 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2620 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2621 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2622 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2623 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2624 cd          write (iout,'(a)')
2625 cd        enddo
2626       enddo
2627       return
2628       end
2629 C--------------------------------------------------------------------------
2630       subroutine set_matrices
2631       implicit real*8 (a-h,o-z)
2632       include 'DIMENSIONS'
2633 #ifdef MPI
2634       include "mpif.h"
2635       include "COMMON.SETUP"
2636       integer IERR
2637       integer status(MPI_STATUS_SIZE)
2638 #endif
2639       include 'COMMON.IOUNITS'
2640       include 'COMMON.GEO'
2641       include 'COMMON.VAR'
2642       include 'COMMON.LOCAL'
2643       include 'COMMON.CHAIN'
2644       include 'COMMON.DERIV'
2645       include 'COMMON.INTERACT'
2646       include 'COMMON.CONTACTS'
2647       include 'COMMON.TORSION'
2648       include 'COMMON.VECTORS'
2649       include 'COMMON.FFIELD'
2650       double precision auxvec(2),auxmat(2,2)
2651 C
2652 C Compute the virtual-bond-torsional-angle dependent quantities needed
2653 C to calculate the el-loc multibody terms of various order.
2654 C
2655 c      write(iout,*) 'nphi=',nphi,nres
2656 #ifdef PARMAT
2657       do i=ivec_start+2,ivec_end+2
2658 #else
2659       do i=3,nres+1
2660 #endif
2661 #ifdef NEWCORR
2662         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2663           iti = itortyp(itype(i-2))
2664         else
2665           iti=ntortyp+1
2666         endif
2667 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2668         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2669           iti1 = itortyp(itype(i-1))
2670         else
2671           iti1=ntortyp+1
2672         endif
2673 c        write(iout,*),i
2674         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2675      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2676      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2677         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2678      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2679      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2680 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2681 c     &*(cos(theta(i)/2.0)
2682         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2683      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2684      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2685 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2686 c     &*(cos(theta(i)/2.0)
2687         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2688      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2689      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2690 c        if (ggb1(1,i).eq.0.0d0) then
2691 c        write(iout,*) 'i=',i,ggb1(1,i),
2692 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2693 c     &bnew1(2,1,iti)*cos(theta(i)),
2694 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2695 c        endif
2696         b1(2,i-2)=bnew1(1,2,iti)
2697         gtb1(2,i-2)=0.0
2698         b2(2,i-2)=bnew2(1,2,iti)
2699         gtb2(2,i-2)=0.0
2700         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2701         EE(1,2,i-2)=eeold(1,2,iti)
2702         EE(2,1,i-2)=eeold(2,1,iti)
2703         EE(2,2,i-2)=eeold(2,2,iti)
2704         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2705         gtEE(1,2,i-2)=0.0d0
2706         gtEE(2,2,i-2)=0.0d0
2707         gtEE(2,1,i-2)=0.0d0
2708 c        EE(2,2,iti)=0.0d0
2709 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2710 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2711 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2712 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2713        b1tilde(1,i-2)=b1(1,i-2)
2714        b1tilde(2,i-2)=-b1(2,i-2)
2715        b2tilde(1,i-2)=b2(1,i-2)
2716        b2tilde(2,i-2)=-b2(2,i-2)
2717 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2718 c       write(iout,*)  'b1=',b1(1,i-2)
2719 c       write (iout,*) 'theta=', theta(i-1)
2720        enddo
2721 #else
2722         b1(1,i-2)=b(3,iti)
2723         b1(2,i-2)=b(5,iti)
2724         b2(1,i-2)=b(2,iti)
2725         b2(2,i-2)=b(4,iti)
2726        b1tilde(1,i-2)=b1(1,i-2)
2727        b1tilde(2,i-2)=-b1(2,i-2)
2728        b2tilde(1,i-2)=b2(1,i-2)
2729        b2tilde(2,i-2)=-b2(2,i-2)
2730         EE(1,2,i-2)=eeold(1,2,iti)
2731         EE(2,1,i-2)=eeold(2,1,iti)
2732         EE(2,2,i-2)=eeold(2,2,iti)
2733         EE(1,1,i-2)=eeold(1,1,iti)
2734       enddo
2735 #endif
2736 #ifdef PARMAT
2737       do i=ivec_start+2,ivec_end+2
2738 #else
2739       do i=3,nres+1
2740 #endif
2741         if (i .lt. nres+1) then
2742           sin1=dsin(phi(i))
2743           cos1=dcos(phi(i))
2744           sintab(i-2)=sin1
2745           costab(i-2)=cos1
2746           obrot(1,i-2)=cos1
2747           obrot(2,i-2)=sin1
2748           sin2=dsin(2*phi(i))
2749           cos2=dcos(2*phi(i))
2750           sintab2(i-2)=sin2
2751           costab2(i-2)=cos2
2752           obrot2(1,i-2)=cos2
2753           obrot2(2,i-2)=sin2
2754           Ug(1,1,i-2)=-cos1
2755           Ug(1,2,i-2)=-sin1
2756           Ug(2,1,i-2)=-sin1
2757           Ug(2,2,i-2)= cos1
2758           Ug2(1,1,i-2)=-cos2
2759           Ug2(1,2,i-2)=-sin2
2760           Ug2(2,1,i-2)=-sin2
2761           Ug2(2,2,i-2)= cos2
2762         else
2763           costab(i-2)=1.0d0
2764           sintab(i-2)=0.0d0
2765           obrot(1,i-2)=1.0d0
2766           obrot(2,i-2)=0.0d0
2767           obrot2(1,i-2)=0.0d0
2768           obrot2(2,i-2)=0.0d0
2769           Ug(1,1,i-2)=1.0d0
2770           Ug(1,2,i-2)=0.0d0
2771           Ug(2,1,i-2)=0.0d0
2772           Ug(2,2,i-2)=1.0d0
2773           Ug2(1,1,i-2)=0.0d0
2774           Ug2(1,2,i-2)=0.0d0
2775           Ug2(2,1,i-2)=0.0d0
2776           Ug2(2,2,i-2)=0.0d0
2777         endif
2778         if (i .gt. 3 .and. i .lt. nres+1) then
2779           obrot_der(1,i-2)=-sin1
2780           obrot_der(2,i-2)= cos1
2781           Ugder(1,1,i-2)= sin1
2782           Ugder(1,2,i-2)=-cos1
2783           Ugder(2,1,i-2)=-cos1
2784           Ugder(2,2,i-2)=-sin1
2785           dwacos2=cos2+cos2
2786           dwasin2=sin2+sin2
2787           obrot2_der(1,i-2)=-dwasin2
2788           obrot2_der(2,i-2)= dwacos2
2789           Ug2der(1,1,i-2)= dwasin2
2790           Ug2der(1,2,i-2)=-dwacos2
2791           Ug2der(2,1,i-2)=-dwacos2
2792           Ug2der(2,2,i-2)=-dwasin2
2793         else
2794           obrot_der(1,i-2)=0.0d0
2795           obrot_der(2,i-2)=0.0d0
2796           Ugder(1,1,i-2)=0.0d0
2797           Ugder(1,2,i-2)=0.0d0
2798           Ugder(2,1,i-2)=0.0d0
2799           Ugder(2,2,i-2)=0.0d0
2800           obrot2_der(1,i-2)=0.0d0
2801           obrot2_der(2,i-2)=0.0d0
2802           Ug2der(1,1,i-2)=0.0d0
2803           Ug2der(1,2,i-2)=0.0d0
2804           Ug2der(2,1,i-2)=0.0d0
2805           Ug2der(2,2,i-2)=0.0d0
2806         endif
2807 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2808         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2809           iti = itortyp(itype(i-2))
2810         else
2811           iti=ntortyp
2812         endif
2813 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2814         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2815           iti1 = itortyp(itype(i-1))
2816         else
2817           iti1=ntortyp
2818         endif
2819 cd        write (iout,*) '*******i',i,' iti1',iti
2820 cd        write (iout,*) 'b1',b1(:,iti)
2821 cd        write (iout,*) 'b2',b2(:,iti)
2822 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2823 c        if (i .gt. iatel_s+2) then
2824         if (i .gt. nnt+2) then
2825           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2826 #ifdef NEWCORR
2827           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2828 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2829 #endif
2830 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2831 c     &    EE(1,2,iti),EE(2,2,iti)
2832           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2833           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2834 c          write(iout,*) "Macierz EUG",
2835 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2836 c     &    eug(2,2,i-2)
2837           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2838      &    then
2839           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2840           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2841           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2842           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2843           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2844           endif
2845         else
2846           do k=1,2
2847             Ub2(k,i-2)=0.0d0
2848             Ctobr(k,i-2)=0.0d0
2849             Dtobr2(k,i-2)=0.0d0
2850             do l=1,2
2851               EUg(l,k,i-2)=0.0d0
2852               CUg(l,k,i-2)=0.0d0
2853               DUg(l,k,i-2)=0.0d0
2854               DtUg2(l,k,i-2)=0.0d0
2855             enddo
2856           enddo
2857         endif
2858         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2859         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2860         do k=1,2
2861           muder(k,i-2)=Ub2der(k,i-2)
2862         enddo
2863 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2864         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2865           if (itype(i-1).le.ntyp) then
2866             iti1 = itortyp(itype(i-1))
2867           else
2868             iti1=ntortyp
2869           endif
2870         else
2871           iti1=ntortyp
2872         endif
2873         do k=1,2
2874           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2875         enddo
2876 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2877 cd        write (iout,*) 'mu1',mu1(:,i-2)
2878 cd        write (iout,*) 'mu2',mu2(:,i-2)
2879         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2880      &  then
2881         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2882         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2883         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2884         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2885         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2886 C Vectors and matrices dependent on a single virtual-bond dihedral.
2887         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2888         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2889         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2890         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2891         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2892         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2893         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2894         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2895         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2896         endif
2897       enddo
2898 C Matrices dependent on two consecutive virtual-bond dihedrals.
2899 C The order of matrices is from left to right.
2900       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2901      &then
2902 c      do i=max0(ivec_start,2),ivec_end
2903       do i=2,nres-1
2904         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2905         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2906         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2907         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2908         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2909         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2910         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2911         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2912       enddo
2913       endif
2914 #if defined(MPI) && defined(PARMAT)
2915 #ifdef DEBUG
2916 c      if (fg_rank.eq.0) then
2917         write (iout,*) "Arrays UG and UGDER before GATHER"
2918         do i=1,nres-1
2919           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2920      &     ((ug(l,k,i),l=1,2),k=1,2),
2921      &     ((ugder(l,k,i),l=1,2),k=1,2)
2922         enddo
2923         write (iout,*) "Arrays UG2 and UG2DER"
2924         do i=1,nres-1
2925           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2926      &     ((ug2(l,k,i),l=1,2),k=1,2),
2927      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2928         enddo
2929         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2930         do i=1,nres-1
2931           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2932      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2933      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2934         enddo
2935         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2936         do i=1,nres-1
2937           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2938      &     costab(i),sintab(i),costab2(i),sintab2(i)
2939         enddo
2940         write (iout,*) "Array MUDER"
2941         do i=1,nres-1
2942           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2943         enddo
2944 c      endif
2945 #endif
2946       if (nfgtasks.gt.1) then
2947         time00=MPI_Wtime()
2948 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2949 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2950 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2951 #ifdef MATGATHER
2952         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2953      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2954      &   FG_COMM1,IERR)
2955         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2956      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2957      &   FG_COMM1,IERR)
2958         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2959      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2960      &   FG_COMM1,IERR)
2961         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2962      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2963      &   FG_COMM1,IERR)
2964         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2965      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2966      &   FG_COMM1,IERR)
2967         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2968      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2969      &   FG_COMM1,IERR)
2970         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2971      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2972      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2973         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2974      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2975      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2976         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2977      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2978      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2979         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2980      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2981      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2982         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2983      &  then
2984         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2985      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2986      &   FG_COMM1,IERR)
2987         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2988      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2989      &   FG_COMM1,IERR)
2990         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2991      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2992      &   FG_COMM1,IERR)
2993        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2994      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2995      &   FG_COMM1,IERR)
2996         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2997      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2998      &   FG_COMM1,IERR)
2999         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3000      &   ivec_count(fg_rank1),
3001      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3002      &   FG_COMM1,IERR)
3003         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3004      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3005      &   FG_COMM1,IERR)
3006         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3007      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3008      &   FG_COMM1,IERR)
3009         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3010      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3011      &   FG_COMM1,IERR)
3012         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3013      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3014      &   FG_COMM1,IERR)
3015         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3016      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3017      &   FG_COMM1,IERR)
3018         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3019      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3020      &   FG_COMM1,IERR)
3021         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3022      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3023      &   FG_COMM1,IERR)
3024         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3025      &   ivec_count(fg_rank1),
3026      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3027      &   FG_COMM1,IERR)
3028         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3030      &   FG_COMM1,IERR)
3031        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3036      &   FG_COMM1,IERR)
3037        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3041      &   ivec_count(fg_rank1),
3042      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3043      &   FG_COMM1,IERR)
3044         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3045      &   ivec_count(fg_rank1),
3046      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3047      &   FG_COMM1,IERR)
3048         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3049      &   ivec_count(fg_rank1),
3050      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3051      &   MPI_MAT2,FG_COMM1,IERR)
3052         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3053      &   ivec_count(fg_rank1),
3054      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3055      &   MPI_MAT2,FG_COMM1,IERR)
3056         endif
3057 #else
3058 c Passes matrix info through the ring
3059       isend=fg_rank1
3060       irecv=fg_rank1-1
3061       if (irecv.lt.0) irecv=nfgtasks1-1
3062       iprev=irecv
3063       inext=fg_rank1+1
3064       if (inext.ge.nfgtasks1) inext=0
3065       do i=1,nfgtasks1-1
3066 c        write (iout,*) "isend",isend," irecv",irecv
3067 c        call flush(iout)
3068         lensend=lentyp(isend)
3069         lenrecv=lentyp(irecv)
3070 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3071 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3072 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3073 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3074 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3075 c        write (iout,*) "Gather ROTAT1"
3076 c        call flush(iout)
3077 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3078 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3079 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3080 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3081 c        write (iout,*) "Gather ROTAT2"
3082 c        call flush(iout)
3083         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3084      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3085      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3086      &   iprev,4400+irecv,FG_COMM,status,IERR)
3087 c        write (iout,*) "Gather ROTAT_OLD"
3088 c        call flush(iout)
3089         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3090      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3091      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3092      &   iprev,5500+irecv,FG_COMM,status,IERR)
3093 c        write (iout,*) "Gather PRECOMP11"
3094 c        call flush(iout)
3095         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3096      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3097      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3098      &   iprev,6600+irecv,FG_COMM,status,IERR)
3099 c        write (iout,*) "Gather PRECOMP12"
3100 c        call flush(iout)
3101         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3102      &  then
3103         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3104      &   MPI_ROTAT2(lensend),inext,7700+isend,
3105      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3106      &   iprev,7700+irecv,FG_COMM,status,IERR)
3107 c        write (iout,*) "Gather PRECOMP21"
3108 c        call flush(iout)
3109         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3110      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3111      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3112      &   iprev,8800+irecv,FG_COMM,status,IERR)
3113 c        write (iout,*) "Gather PRECOMP22"
3114 c        call flush(iout)
3115         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3116      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3117      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3118      &   MPI_PRECOMP23(lenrecv),
3119      &   iprev,9900+irecv,FG_COMM,status,IERR)
3120 c        write (iout,*) "Gather PRECOMP23"
3121 c        call flush(iout)
3122         endif
3123         isend=irecv
3124         irecv=irecv-1
3125         if (irecv.lt.0) irecv=nfgtasks1-1
3126       enddo
3127 #endif
3128         time_gather=time_gather+MPI_Wtime()-time00
3129       endif
3130 #ifdef DEBUG
3131 c      if (fg_rank.eq.0) then
3132         write (iout,*) "Arrays UG and UGDER"
3133         do i=1,nres-1
3134           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3135      &     ((ug(l,k,i),l=1,2),k=1,2),
3136      &     ((ugder(l,k,i),l=1,2),k=1,2)
3137         enddo
3138         write (iout,*) "Arrays UG2 and UG2DER"
3139         do i=1,nres-1
3140           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3141      &     ((ug2(l,k,i),l=1,2),k=1,2),
3142      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3143         enddo
3144         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3145         do i=1,nres-1
3146           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3147      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3148      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3149         enddo
3150         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3151         do i=1,nres-1
3152           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3153      &     costab(i),sintab(i),costab2(i),sintab2(i)
3154         enddo
3155         write (iout,*) "Array MUDER"
3156         do i=1,nres-1
3157           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3158         enddo
3159 c      endif
3160 #endif
3161 #endif
3162 cd      do i=1,nres
3163 cd        iti = itortyp(itype(i))
3164 cd        write (iout,*) i
3165 cd        do j=1,2
3166 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3167 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3168 cd        enddo
3169 cd      enddo
3170       return
3171       end
3172 C--------------------------------------------------------------------------
3173       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3174 C
3175 C This subroutine calculates the average interaction energy and its gradient
3176 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3177 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3178 C The potential depends both on the distance of peptide-group centers and on
3179 C the orientation of the CA-CA virtual bonds.
3180 C
3181       implicit real*8 (a-h,o-z)
3182 #ifdef MPI
3183       include 'mpif.h'
3184 #endif
3185       include 'DIMENSIONS'
3186       include 'COMMON.CONTROL'
3187       include 'COMMON.SETUP'
3188       include 'COMMON.IOUNITS'
3189       include 'COMMON.GEO'
3190       include 'COMMON.VAR'
3191       include 'COMMON.LOCAL'
3192       include 'COMMON.CHAIN'
3193       include 'COMMON.DERIV'
3194       include 'COMMON.INTERACT'
3195       include 'COMMON.CONTACTS'
3196       include 'COMMON.TORSION'
3197       include 'COMMON.VECTORS'
3198       include 'COMMON.FFIELD'
3199       include 'COMMON.TIME1'
3200       include 'COMMON.SPLITELE'
3201       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3202      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3203       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3204      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3205       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3206      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3207      &    num_conti,j1,j2
3208 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3209 #ifdef MOMENT
3210       double precision scal_el /1.0d0/
3211 #else
3212       double precision scal_el /0.5d0/
3213 #endif
3214 C 12/13/98
3215 C 13-go grudnia roku pamietnego...
3216       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3217      &                   0.0d0,1.0d0,0.0d0,
3218      &                   0.0d0,0.0d0,1.0d0/
3219 cd      write(iout,*) 'In EELEC'
3220 cd      do i=1,nloctyp
3221 cd        write(iout,*) 'Type',i
3222 cd        write(iout,*) 'B1',B1(:,i)
3223 cd        write(iout,*) 'B2',B2(:,i)
3224 cd        write(iout,*) 'CC',CC(:,:,i)
3225 cd        write(iout,*) 'DD',DD(:,:,i)
3226 cd        write(iout,*) 'EE',EE(:,:,i)
3227 cd      enddo
3228 cd      call check_vecgrad
3229 cd      stop
3230       if (icheckgrad.eq.1) then
3231         do i=1,nres-1
3232           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3233           do k=1,3
3234             dc_norm(k,i)=dc(k,i)*fac
3235           enddo
3236 c          write (iout,*) 'i',i,' fac',fac
3237         enddo
3238       endif
3239       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3240      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3241      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3242 c        call vec_and_deriv
3243 #ifdef TIMING
3244         time01=MPI_Wtime()
3245 #endif
3246         call set_matrices
3247 #ifdef TIMING
3248         time_mat=time_mat+MPI_Wtime()-time01
3249 #endif
3250       endif
3251 cd      do i=1,nres-1
3252 cd        write (iout,*) 'i=',i
3253 cd        do k=1,3
3254 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3255 cd        enddo
3256 cd        do k=1,3
3257 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3258 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3259 cd        enddo
3260 cd      enddo
3261       t_eelecij=0.0d0
3262       ees=0.0D0
3263       evdw1=0.0D0
3264       eel_loc=0.0d0
3265       eello_turn3=0.0d0
3266       eello_turn4=0.0d0
3267       ind=0
3268       do i=1,nres
3269         num_cont_hb(i)=0
3270       enddo
3271 cd      print '(a)','Enter EELEC'
3272 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3273       do i=1,nres
3274         gel_loc_loc(i)=0.0d0
3275         gcorr_loc(i)=0.0d0
3276       enddo
3277 c
3278 c
3279 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3280 C
3281 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3282 C
3283 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3284       do i=iturn3_start,iturn3_end
3285         if (i.le.1) cycle
3286 C        write(iout,*) "tu jest i",i
3287         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3288      &  .or. itype(i+2).eq.ntyp1
3289      &  .or. itype(i+3).eq.ntyp1
3290      &  .or. itype(i-1).eq.ntyp1
3291      &  .or. itype(i+4).eq.ntyp1
3292      &  ) cycle
3293         dxi=dc(1,i)
3294         dyi=dc(2,i)
3295         dzi=dc(3,i)
3296         dx_normi=dc_norm(1,i)
3297         dy_normi=dc_norm(2,i)
3298         dz_normi=dc_norm(3,i)
3299         xmedi=c(1,i)+0.5d0*dxi
3300         ymedi=c(2,i)+0.5d0*dyi
3301         zmedi=c(3,i)+0.5d0*dzi
3302           xmedi=mod(xmedi,boxxsize)
3303           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3304           ymedi=mod(ymedi,boxysize)
3305           if (ymedi.lt.0) ymedi=ymedi+boxysize
3306           zmedi=mod(zmedi,boxzsize)
3307           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3308         num_conti=0
3309         call eelecij(i,i+2,ees,evdw1,eel_loc)
3310         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3311         num_cont_hb(i)=num_conti
3312       enddo
3313       do i=iturn4_start,iturn4_end
3314         if (i.le.1) cycle
3315         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3316      &    .or. itype(i+3).eq.ntyp1
3317      &    .or. itype(i+4).eq.ntyp1
3318      &    .or. itype(i+5).eq.ntyp1
3319      &    .or. itype(i).eq.ntyp1
3320      &    .or. itype(i-1).eq.ntyp1
3321      &                             ) cycle
3322         dxi=dc(1,i)
3323         dyi=dc(2,i)
3324         dzi=dc(3,i)
3325         dx_normi=dc_norm(1,i)
3326         dy_normi=dc_norm(2,i)
3327         dz_normi=dc_norm(3,i)
3328         xmedi=c(1,i)+0.5d0*dxi
3329         ymedi=c(2,i)+0.5d0*dyi
3330         zmedi=c(3,i)+0.5d0*dzi
3331 C Return atom into box, boxxsize is size of box in x dimension
3332 c  194   continue
3333 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3334 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3335 C Condition for being inside the proper box
3336 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3337 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3338 c        go to 194
3339 c        endif
3340 c  195   continue
3341 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3342 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3343 C Condition for being inside the proper box
3344 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3345 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3346 c        go to 195
3347 c        endif
3348 c  196   continue
3349 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3350 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3351 C Condition for being inside the proper box
3352 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3353 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3354 c        go to 196
3355 c        endif
3356           xmedi=mod(xmedi,boxxsize)
3357           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3358           ymedi=mod(ymedi,boxysize)
3359           if (ymedi.lt.0) ymedi=ymedi+boxysize
3360           zmedi=mod(zmedi,boxzsize)
3361           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3362
3363         num_conti=num_cont_hb(i)
3364 c        write(iout,*) "JESTEM W PETLI"
3365         call eelecij(i,i+3,ees,evdw1,eel_loc)
3366         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3367      &   call eturn4(i,eello_turn4)
3368         num_cont_hb(i)=num_conti
3369       enddo   ! i
3370 C Loop over all neighbouring boxes
3371 C      do xshift=-1,1
3372 C      do yshift=-1,1
3373 C      do zshift=-1,1
3374 c
3375 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3376 c
3377       do i=iatel_s,iatel_e
3378         if (i.le.1) cycle
3379         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3380      &  .or. itype(i+2).eq.ntyp1
3381      &  .or. itype(i-1).eq.ntyp1
3382      &                ) cycle
3383         dxi=dc(1,i)
3384         dyi=dc(2,i)
3385         dzi=dc(3,i)
3386         dx_normi=dc_norm(1,i)
3387         dy_normi=dc_norm(2,i)
3388         dz_normi=dc_norm(3,i)
3389         xmedi=c(1,i)+0.5d0*dxi
3390         ymedi=c(2,i)+0.5d0*dyi
3391         zmedi=c(3,i)+0.5d0*dzi
3392           xmedi=mod(xmedi,boxxsize)
3393           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3394           ymedi=mod(ymedi,boxysize)
3395           if (ymedi.lt.0) ymedi=ymedi+boxysize
3396           zmedi=mod(zmedi,boxzsize)
3397           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3398 C          xmedi=xmedi+xshift*boxxsize
3399 C          ymedi=ymedi+yshift*boxysize
3400 C          zmedi=zmedi+zshift*boxzsize
3401
3402 C Return tom into box, boxxsize is size of box in x dimension
3403 c  164   continue
3404 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3405 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3406 C Condition for being inside the proper box
3407 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3408 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3409 c        go to 164
3410 c        endif
3411 c  165   continue
3412 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3413 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3414 C Condition for being inside the proper box
3415 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3416 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3417 c        go to 165
3418 c        endif
3419 c  166   continue
3420 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3421 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3422 cC Condition for being inside the proper box
3423 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3424 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3425 c        go to 166
3426 c        endif
3427
3428 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3429         num_conti=num_cont_hb(i)
3430         do j=ielstart(i),ielend(i)
3431 C          write (iout,*) i,j
3432          if (j.le.1) cycle
3433           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3434      & .or.itype(j+2).eq.ntyp1
3435      & .or.itype(j-1).eq.ntyp1
3436      &) cycle
3437           call eelecij(i,j,ees,evdw1,eel_loc)
3438         enddo ! j
3439         num_cont_hb(i)=num_conti
3440       enddo   ! i
3441 C     enddo   ! zshift
3442 C      enddo   ! yshift
3443 C      enddo   ! xshift
3444
3445 c      write (iout,*) "Number of loop steps in EELEC:",ind
3446 cd      do i=1,nres
3447 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3448 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3449 cd      enddo
3450 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3451 ccc      eel_loc=eel_loc+eello_turn3
3452 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3453       return
3454       end
3455 C-------------------------------------------------------------------------------
3456       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3457       implicit real*8 (a-h,o-z)
3458       include 'DIMENSIONS'
3459 #ifdef MPI
3460       include "mpif.h"
3461 #endif
3462       include 'COMMON.CONTROL'
3463       include 'COMMON.IOUNITS'
3464       include 'COMMON.GEO'
3465       include 'COMMON.VAR'
3466       include 'COMMON.LOCAL'
3467       include 'COMMON.CHAIN'
3468       include 'COMMON.DERIV'
3469       include 'COMMON.INTERACT'
3470       include 'COMMON.CONTACTS'
3471       include 'COMMON.TORSION'
3472       include 'COMMON.VECTORS'
3473       include 'COMMON.FFIELD'
3474       include 'COMMON.TIME1'
3475       include 'COMMON.SPLITELE'
3476       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3477      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3478       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3479      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3480      &    gmuij2(4),gmuji2(4)
3481       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3482      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3483      &    num_conti,j1,j2
3484 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3485 #ifdef MOMENT
3486       double precision scal_el /1.0d0/
3487 #else
3488       double precision scal_el /0.5d0/
3489 #endif
3490 C 12/13/98
3491 C 13-go grudnia roku pamietnego...
3492       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3493      &                   0.0d0,1.0d0,0.0d0,
3494      &                   0.0d0,0.0d0,1.0d0/
3495 c          time00=MPI_Wtime()
3496 cd      write (iout,*) "eelecij",i,j
3497 c          ind=ind+1
3498           iteli=itel(i)
3499           itelj=itel(j)
3500           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3501           aaa=app(iteli,itelj)
3502           bbb=bpp(iteli,itelj)
3503           ael6i=ael6(iteli,itelj)
3504           ael3i=ael3(iteli,itelj)
3505           dxj=dc(1,j)
3506           dyj=dc(2,j)
3507           dzj=dc(3,j)
3508           dx_normj=dc_norm(1,j)
3509           dy_normj=dc_norm(2,j)
3510           dz_normj=dc_norm(3,j)
3511 C          xj=c(1,j)+0.5D0*dxj-xmedi
3512 C          yj=c(2,j)+0.5D0*dyj-ymedi
3513 C          zj=c(3,j)+0.5D0*dzj-zmedi
3514           xj=c(1,j)+0.5D0*dxj
3515           yj=c(2,j)+0.5D0*dyj
3516           zj=c(3,j)+0.5D0*dzj
3517           xj=mod(xj,boxxsize)
3518           if (xj.lt.0) xj=xj+boxxsize
3519           yj=mod(yj,boxysize)
3520           if (yj.lt.0) yj=yj+boxysize
3521           zj=mod(zj,boxzsize)
3522           if (zj.lt.0) zj=zj+boxzsize
3523           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3524       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3525       xj_safe=xj
3526       yj_safe=yj
3527       zj_safe=zj
3528       isubchap=0
3529       do xshift=-1,1
3530       do yshift=-1,1
3531       do zshift=-1,1
3532           xj=xj_safe+xshift*boxxsize
3533           yj=yj_safe+yshift*boxysize
3534           zj=zj_safe+zshift*boxzsize
3535           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3536           if(dist_temp.lt.dist_init) then
3537             dist_init=dist_temp
3538             xj_temp=xj
3539             yj_temp=yj
3540             zj_temp=zj
3541             isubchap=1
3542           endif
3543        enddo
3544        enddo
3545        enddo
3546        if (isubchap.eq.1) then
3547           xj=xj_temp-xmedi
3548           yj=yj_temp-ymedi
3549           zj=zj_temp-zmedi
3550        else
3551           xj=xj_safe-xmedi
3552           yj=yj_safe-ymedi
3553           zj=zj_safe-zmedi
3554        endif
3555 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3556 c  174   continue
3557 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3558 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3559 C Condition for being inside the proper box
3560 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3561 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3562 c        go to 174
3563 c        endif
3564 c  175   continue
3565 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3566 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3567 C Condition for being inside the proper box
3568 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3569 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3570 c        go to 175
3571 c        endif
3572 c  176   continue
3573 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3574 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3575 C Condition for being inside the proper box
3576 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3577 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3578 c        go to 176
3579 c        endif
3580 C        endif !endPBC condintion
3581 C        xj=xj-xmedi
3582 C        yj=yj-ymedi
3583 C        zj=zj-zmedi
3584           rij=xj*xj+yj*yj+zj*zj
3585
3586             sss=sscale(sqrt(rij))
3587             sssgrad=sscagrad(sqrt(rij))
3588 c            if (sss.gt.0.0d0) then
3589           rrmij=1.0D0/rij
3590           rij=dsqrt(rij)
3591           rmij=1.0D0/rij
3592           r3ij=rrmij*rmij
3593           r6ij=r3ij*r3ij
3594           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3595           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3596           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3597           fac=cosa-3.0D0*cosb*cosg
3598           ev1=aaa*r6ij*r6ij
3599 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3600           if (j.eq.i+2) ev1=scal_el*ev1
3601           ev2=bbb*r6ij
3602           fac3=ael6i*r6ij
3603           fac4=ael3i*r3ij
3604           evdwij=(ev1+ev2)
3605           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3606           el2=fac4*fac
3607 C MARYSIA
3608           eesij=(el1+el2)
3609 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3610           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3611           ees=ees+eesij
3612           evdw1=evdw1+evdwij*sss
3613 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3614 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3615 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3616 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3617
3618           if (energy_dec) then
3619               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3620      &'evdw1',i,j,evdwij
3621      &,iteli,itelj,aaa,evdw1
3622               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3623           endif
3624
3625 C
3626 C Calculate contributions to the Cartesian gradient.
3627 C
3628 #ifdef SPLITELE
3629           facvdw=-6*rrmij*(ev1+evdwij)*sss
3630           facel=-3*rrmij*(el1+eesij)
3631           fac1=fac
3632           erij(1)=xj*rmij
3633           erij(2)=yj*rmij
3634           erij(3)=zj*rmij
3635 *
3636 * Radial derivatives. First process both termini of the fragment (i,j)
3637 *
3638           ggg(1)=facel*xj
3639           ggg(2)=facel*yj
3640           ggg(3)=facel*zj
3641 c          do k=1,3
3642 c            ghalf=0.5D0*ggg(k)
3643 c            gelc(k,i)=gelc(k,i)+ghalf
3644 c            gelc(k,j)=gelc(k,j)+ghalf
3645 c          enddo
3646 c 9/28/08 AL Gradient compotents will be summed only at the end
3647           do k=1,3
3648             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3649             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3650           enddo
3651 *
3652 * Loop over residues i+1 thru j-1.
3653 *
3654 cgrad          do k=i+1,j-1
3655 cgrad            do l=1,3
3656 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3657 cgrad            enddo
3658 cgrad          enddo
3659           if (sss.gt.0.0) then
3660           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3661           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3662           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3663           else
3664           ggg(1)=0.0
3665           ggg(2)=0.0
3666           ggg(3)=0.0
3667           endif
3668 c          do k=1,3
3669 c            ghalf=0.5D0*ggg(k)
3670 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3671 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3672 c          enddo
3673 c 9/28/08 AL Gradient compotents will be summed only at the end
3674           do k=1,3
3675             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3676             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3677           enddo
3678 *
3679 * Loop over residues i+1 thru j-1.
3680 *
3681 cgrad          do k=i+1,j-1
3682 cgrad            do l=1,3
3683 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3684 cgrad            enddo
3685 cgrad          enddo
3686 #else
3687 C MARYSIA
3688           facvdw=(ev1+evdwij)*sss
3689           facel=(el1+eesij)
3690           fac1=fac
3691           fac=-3*rrmij*(facvdw+facvdw+facel)
3692           erij(1)=xj*rmij
3693           erij(2)=yj*rmij
3694           erij(3)=zj*rmij
3695 *
3696 * Radial derivatives. First process both termini of the fragment (i,j)
3697 *
3698           ggg(1)=fac*xj
3699           ggg(2)=fac*yj
3700           ggg(3)=fac*zj
3701 c          do k=1,3
3702 c            ghalf=0.5D0*ggg(k)
3703 c            gelc(k,i)=gelc(k,i)+ghalf
3704 c            gelc(k,j)=gelc(k,j)+ghalf
3705 c          enddo
3706 c 9/28/08 AL Gradient compotents will be summed only at the end
3707           do k=1,3
3708             gelc_long(k,j)=gelc(k,j)+ggg(k)
3709             gelc_long(k,i)=gelc(k,i)-ggg(k)
3710           enddo
3711 *
3712 * Loop over residues i+1 thru j-1.
3713 *
3714 cgrad          do k=i+1,j-1
3715 cgrad            do l=1,3
3716 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3717 cgrad            enddo
3718 cgrad          enddo
3719 c 9/28/08 AL Gradient compotents will be summed only at the end
3720           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3721           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3722           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3723           do k=1,3
3724             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3725             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3726           enddo
3727 #endif
3728 *
3729 * Angular part
3730 *
3731           ecosa=2.0D0*fac3*fac1+fac4
3732           fac4=-3.0D0*fac4
3733           fac3=-6.0D0*fac3
3734           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3735           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3736           do k=1,3
3737             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3738             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3739           enddo
3740 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3741 cd   &          (dcosg(k),k=1,3)
3742           do k=1,3
3743             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3744           enddo
3745 c          do k=1,3
3746 c            ghalf=0.5D0*ggg(k)
3747 c            gelc(k,i)=gelc(k,i)+ghalf
3748 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3749 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3750 c            gelc(k,j)=gelc(k,j)+ghalf
3751 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3752 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3753 c          enddo
3754 cgrad          do k=i+1,j-1
3755 cgrad            do l=1,3
3756 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3757 cgrad            enddo
3758 cgrad          enddo
3759           do k=1,3
3760             gelc(k,i)=gelc(k,i)
3761      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3762      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3763             gelc(k,j)=gelc(k,j)
3764      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3765      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3766             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3767             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3768           enddo
3769 C MARYSIA
3770 c          endif !sscale
3771           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3772      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3773      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3774 C
3775 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3776 C   energy of a peptide unit is assumed in the form of a second-order
3777 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3778 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3779 C   are computed for EVERY pair of non-contiguous peptide groups.
3780 C
3781
3782           if (j.lt.nres-1) then
3783             j1=j+1
3784             j2=j-1
3785           else
3786             j1=j-1
3787             j2=j-2
3788           endif
3789           kkk=0
3790           lll=0
3791           do k=1,2
3792             do l=1,2
3793               kkk=kkk+1
3794               muij(kkk)=mu(k,i)*mu(l,j)
3795 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3796 #ifdef NEWCORR
3797              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3798 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3799              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3800              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3801 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3802              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3803 #endif
3804             enddo
3805           enddo
3806 cd         write (iout,*) 'EELEC: i',i,' j',j
3807 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3808 cd          write(iout,*) 'muij',muij
3809           ury=scalar(uy(1,i),erij)
3810           urz=scalar(uz(1,i),erij)
3811           vry=scalar(uy(1,j),erij)
3812           vrz=scalar(uz(1,j),erij)
3813           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3814           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3815           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3816           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3817           fac=dsqrt(-ael6i)*r3ij
3818           a22=a22*fac
3819           a23=a23*fac
3820           a32=a32*fac
3821           a33=a33*fac
3822 cd          write (iout,'(4i5,4f10.5)')
3823 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3824 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3825 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3826 cd     &      uy(:,j),uz(:,j)
3827 cd          write (iout,'(4f10.5)')
3828 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3829 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3830 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3831 cd           write (iout,'(9f10.5/)')
3832 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3833 C Derivatives of the elements of A in virtual-bond vectors
3834           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3835           do k=1,3
3836             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3837             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3838             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3839             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3840             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3841             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3842             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3843             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3844             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3845             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3846             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3847             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3848           enddo
3849 C Compute radial contributions to the gradient
3850           facr=-3.0d0*rrmij
3851           a22der=a22*facr
3852           a23der=a23*facr
3853           a32der=a32*facr
3854           a33der=a33*facr
3855           agg(1,1)=a22der*xj
3856           agg(2,1)=a22der*yj
3857           agg(3,1)=a22der*zj
3858           agg(1,2)=a23der*xj
3859           agg(2,2)=a23der*yj
3860           agg(3,2)=a23der*zj
3861           agg(1,3)=a32der*xj
3862           agg(2,3)=a32der*yj
3863           agg(3,3)=a32der*zj
3864           agg(1,4)=a33der*xj
3865           agg(2,4)=a33der*yj
3866           agg(3,4)=a33der*zj
3867 C Add the contributions coming from er
3868           fac3=-3.0d0*fac
3869           do k=1,3
3870             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3871             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3872             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3873             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3874           enddo
3875           do k=1,3
3876 C Derivatives in DC(i)
3877 cgrad            ghalf1=0.5d0*agg(k,1)
3878 cgrad            ghalf2=0.5d0*agg(k,2)
3879 cgrad            ghalf3=0.5d0*agg(k,3)
3880 cgrad            ghalf4=0.5d0*agg(k,4)
3881             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3882      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3883             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3884      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3885             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3886      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3887             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3888      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3889 C Derivatives in DC(i+1)
3890             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3891      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3892             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3893      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3894             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3895      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3896             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3897      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3898 C Derivatives in DC(j)
3899             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3900      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3901             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3902      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3903             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3904      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3905             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3906      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3907 C Derivatives in DC(j+1) or DC(nres-1)
3908             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3909      &      -3.0d0*vryg(k,3)*ury)
3910             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3911      &      -3.0d0*vrzg(k,3)*ury)
3912             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3913      &      -3.0d0*vryg(k,3)*urz)
3914             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3915      &      -3.0d0*vrzg(k,3)*urz)
3916 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3917 cgrad              do l=1,4
3918 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3919 cgrad              enddo
3920 cgrad            endif
3921           enddo
3922           acipa(1,1)=a22
3923           acipa(1,2)=a23
3924           acipa(2,1)=a32
3925           acipa(2,2)=a33
3926           a22=-a22
3927           a23=-a23
3928           do l=1,2
3929             do k=1,3
3930               agg(k,l)=-agg(k,l)
3931               aggi(k,l)=-aggi(k,l)
3932               aggi1(k,l)=-aggi1(k,l)
3933               aggj(k,l)=-aggj(k,l)
3934               aggj1(k,l)=-aggj1(k,l)
3935             enddo
3936           enddo
3937           if (j.lt.nres-1) then
3938             a22=-a22
3939             a32=-a32
3940             do l=1,3,2
3941               do k=1,3
3942                 agg(k,l)=-agg(k,l)
3943                 aggi(k,l)=-aggi(k,l)
3944                 aggi1(k,l)=-aggi1(k,l)
3945                 aggj(k,l)=-aggj(k,l)
3946                 aggj1(k,l)=-aggj1(k,l)
3947               enddo
3948             enddo
3949           else
3950             a22=-a22
3951             a23=-a23
3952             a32=-a32
3953             a33=-a33
3954             do l=1,4
3955               do k=1,3
3956                 agg(k,l)=-agg(k,l)
3957                 aggi(k,l)=-aggi(k,l)
3958                 aggi1(k,l)=-aggi1(k,l)
3959                 aggj(k,l)=-aggj(k,l)
3960                 aggj1(k,l)=-aggj1(k,l)
3961               enddo
3962             enddo
3963           endif
3964           ENDIF ! WCORR
3965           IF (wel_loc.gt.0.0d0) THEN
3966 C Contribution to the local-electrostatic energy coming from the i-j pair
3967           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3968      &     +a33*muij(4)
3969 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3970 c     &                     ' eel_loc_ij',eel_loc_ij
3971 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3972 C Calculate patrial derivative for theta angle
3973 #ifdef NEWCORR
3974          geel_loc_ij=a22*gmuij1(1)
3975      &     +a23*gmuij1(2)
3976      &     +a32*gmuij1(3)
3977      &     +a33*gmuij1(4)
3978 c         write(iout,*) "derivative over thatai"
3979 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3980 c     &   a33*gmuij1(4)
3981          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3982      &      geel_loc_ij*wel_loc
3983 c         write(iout,*) "derivative over thatai-1"
3984 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3985 c     &   a33*gmuij2(4)
3986          geel_loc_ij=
3987      &     a22*gmuij2(1)
3988      &     +a23*gmuij2(2)
3989      &     +a32*gmuij2(3)
3990      &     +a33*gmuij2(4)
3991          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3992      &      geel_loc_ij*wel_loc
3993 c  Derivative over j residue
3994          geel_loc_ji=a22*gmuji1(1)
3995      &     +a23*gmuji1(2)
3996      &     +a32*gmuji1(3)
3997      &     +a33*gmuji1(4)
3998 c         write(iout,*) "derivative over thataj"
3999 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4000 c     &   a33*gmuji1(4)
4001
4002         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4003      &      geel_loc_ji*wel_loc
4004          geel_loc_ji=
4005      &     +a22*gmuji2(1)
4006      &     +a23*gmuji2(2)
4007      &     +a32*gmuji2(3)
4008      &     +a33*gmuji2(4)
4009 c         write(iout,*) "derivative over thataj-1"
4010 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4011 c     &   a33*gmuji2(4)
4012          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4013      &      geel_loc_ji*wel_loc
4014 #endif
4015 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4016
4017           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4018      &            'eelloc',i,j,eel_loc_ij
4019 c           if (eel_loc_ij.ne.0)
4020 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4021 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4022
4023           eel_loc=eel_loc+eel_loc_ij
4024 C Partial derivatives in virtual-bond dihedral angles gamma
4025           if (i.gt.1)
4026      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4027      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4028      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4029           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4030      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4031      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4032 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4033           do l=1,3
4034             ggg(l)=agg(l,1)*muij(1)+
4035      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4036             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4037             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4038 cgrad            ghalf=0.5d0*ggg(l)
4039 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4040 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4041           enddo
4042 cgrad          do k=i+1,j2
4043 cgrad            do l=1,3
4044 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4045 cgrad            enddo
4046 cgrad          enddo
4047 C Remaining derivatives of eello
4048           do l=1,3
4049             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4050      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4051             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4052      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4053             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4054      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4055             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4056      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4057           enddo
4058           ENDIF
4059 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4060 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4061           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4062      &       .and. num_conti.le.maxconts) then
4063 c            write (iout,*) i,j," entered corr"
4064 C
4065 C Calculate the contact function. The ith column of the array JCONT will
4066 C contain the numbers of atoms that make contacts with the atom I (of numbers
4067 C greater than I). The arrays FACONT and GACONT will contain the values of
4068 C the contact function and its derivative.
4069 c           r0ij=1.02D0*rpp(iteli,itelj)
4070 c           r0ij=1.11D0*rpp(iteli,itelj)
4071             r0ij=2.20D0*rpp(iteli,itelj)
4072 c           r0ij=1.55D0*rpp(iteli,itelj)
4073             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4074             if (fcont.gt.0.0D0) then
4075               num_conti=num_conti+1
4076               if (num_conti.gt.maxconts) then
4077                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4078      &                         ' will skip next contacts for this conf.'
4079               else
4080                 jcont_hb(num_conti,i)=j
4081 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4082 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4083                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4084      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4085 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4086 C  terms.
4087                 d_cont(num_conti,i)=rij
4088 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4089 C     --- Electrostatic-interaction matrix ---
4090                 a_chuj(1,1,num_conti,i)=a22
4091                 a_chuj(1,2,num_conti,i)=a23
4092                 a_chuj(2,1,num_conti,i)=a32
4093                 a_chuj(2,2,num_conti,i)=a33
4094 C     --- Gradient of rij
4095                 do kkk=1,3
4096                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4097                 enddo
4098                 kkll=0
4099                 do k=1,2
4100                   do l=1,2
4101                     kkll=kkll+1
4102                     do m=1,3
4103                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4104                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4105                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4106                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4107                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4108                     enddo
4109                   enddo
4110                 enddo
4111                 ENDIF
4112                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4113 C Calculate contact energies
4114                 cosa4=4.0D0*cosa
4115                 wij=cosa-3.0D0*cosb*cosg
4116                 cosbg1=cosb+cosg
4117                 cosbg2=cosb-cosg
4118 c               fac3=dsqrt(-ael6i)/r0ij**3
4119                 fac3=dsqrt(-ael6i)*r3ij
4120 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4121                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4122                 if (ees0tmp.gt.0) then
4123                   ees0pij=dsqrt(ees0tmp)
4124                 else
4125                   ees0pij=0
4126                 endif
4127 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4128                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4129                 if (ees0tmp.gt.0) then
4130                   ees0mij=dsqrt(ees0tmp)
4131                 else
4132                   ees0mij=0
4133                 endif
4134 c               ees0mij=0.0D0
4135                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4136                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4137 C Diagnostics. Comment out or remove after debugging!
4138 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4139 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4140 c               ees0m(num_conti,i)=0.0D0
4141 C End diagnostics.
4142 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4143 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4144 C Angular derivatives of the contact function
4145                 ees0pij1=fac3/ees0pij
4146                 ees0mij1=fac3/ees0mij
4147                 fac3p=-3.0D0*fac3*rrmij
4148                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4149                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4150 c               ees0mij1=0.0D0
4151                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4152                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4153                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4154                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4155                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4156                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4157                 ecosap=ecosa1+ecosa2
4158                 ecosbp=ecosb1+ecosb2
4159                 ecosgp=ecosg1+ecosg2
4160                 ecosam=ecosa1-ecosa2
4161                 ecosbm=ecosb1-ecosb2
4162                 ecosgm=ecosg1-ecosg2
4163 C Diagnostics
4164 c               ecosap=ecosa1
4165 c               ecosbp=ecosb1
4166 c               ecosgp=ecosg1
4167 c               ecosam=0.0D0
4168 c               ecosbm=0.0D0
4169 c               ecosgm=0.0D0
4170 C End diagnostics
4171                 facont_hb(num_conti,i)=fcont
4172                 fprimcont=fprimcont/rij
4173 cd              facont_hb(num_conti,i)=1.0D0
4174 C Following line is for diagnostics.
4175 cd              fprimcont=0.0D0
4176                 do k=1,3
4177                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4178                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4179                 enddo
4180                 do k=1,3
4181                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4182                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4183                 enddo
4184                 gggp(1)=gggp(1)+ees0pijp*xj
4185                 gggp(2)=gggp(2)+ees0pijp*yj
4186                 gggp(3)=gggp(3)+ees0pijp*zj
4187                 gggm(1)=gggm(1)+ees0mijp*xj
4188                 gggm(2)=gggm(2)+ees0mijp*yj
4189                 gggm(3)=gggm(3)+ees0mijp*zj
4190 C Derivatives due to the contact function
4191                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4192                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4193                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4194                 do k=1,3
4195 c
4196 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4197 c          following the change of gradient-summation algorithm.
4198 c
4199 cgrad                  ghalfp=0.5D0*gggp(k)
4200 cgrad                  ghalfm=0.5D0*gggm(k)
4201                   gacontp_hb1(k,num_conti,i)=!ghalfp
4202      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4203      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4204                   gacontp_hb2(k,num_conti,i)=!ghalfp
4205      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4206      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4207                   gacontp_hb3(k,num_conti,i)=gggp(k)
4208                   gacontm_hb1(k,num_conti,i)=!ghalfm
4209      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4210      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4211                   gacontm_hb2(k,num_conti,i)=!ghalfm
4212      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4213      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4214                   gacontm_hb3(k,num_conti,i)=gggm(k)
4215                 enddo
4216 C Diagnostics. Comment out or remove after debugging!
4217 cdiag           do k=1,3
4218 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4219 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4220 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4221 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4222 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4223 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4224 cdiag           enddo
4225               ENDIF ! wcorr
4226               endif  ! num_conti.le.maxconts
4227             endif  ! fcont.gt.0
4228           endif    ! j.gt.i+1
4229           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4230             do k=1,4
4231               do l=1,3
4232                 ghalf=0.5d0*agg(l,k)
4233                 aggi(l,k)=aggi(l,k)+ghalf
4234                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4235                 aggj(l,k)=aggj(l,k)+ghalf
4236               enddo
4237             enddo
4238             if (j.eq.nres-1 .and. i.lt.j-2) then
4239               do k=1,4
4240                 do l=1,3
4241                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4242                 enddo
4243               enddo
4244             endif
4245           endif
4246 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4247       return
4248       end
4249 C-----------------------------------------------------------------------------
4250       subroutine eturn3(i,eello_turn3)
4251 C Third- and fourth-order contributions from turns
4252       implicit real*8 (a-h,o-z)
4253       include 'DIMENSIONS'
4254       include 'COMMON.IOUNITS'
4255       include 'COMMON.GEO'
4256       include 'COMMON.VAR'
4257       include 'COMMON.LOCAL'
4258       include 'COMMON.CHAIN'
4259       include 'COMMON.DERIV'
4260       include 'COMMON.INTERACT'
4261       include 'COMMON.CONTACTS'
4262       include 'COMMON.TORSION'
4263       include 'COMMON.VECTORS'
4264       include 'COMMON.FFIELD'
4265       include 'COMMON.CONTROL'
4266       dimension ggg(3)
4267       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4268      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4269      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4270      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4271      &  auxgmat2(2,2),auxgmatt2(2,2)
4272       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4273      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4274       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4275      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4276      &    num_conti,j1,j2
4277       j=i+2
4278 c      write (iout,*) "eturn3",i,j,j1,j2
4279       a_temp(1,1)=a22
4280       a_temp(1,2)=a23
4281       a_temp(2,1)=a32
4282       a_temp(2,2)=a33
4283 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4284 C
4285 C               Third-order contributions
4286 C
4287 C                 (i+2)o----(i+3)
4288 C                      | |
4289 C                      | |
4290 C                 (i+1)o----i
4291 C
4292 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4293 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4294         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4295 c auxalary matices for theta gradient
4296 c auxalary matrix for i+1 and constant i+2
4297         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4298 c auxalary matrix for i+2 and constant i+1
4299         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4300         call transpose2(auxmat(1,1),auxmat1(1,1))
4301         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4302         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4303         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4304         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4305         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4306         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4307 C Derivatives in theta
4308         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4309      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4310         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4311      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4312
4313         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4314      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4315 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4316 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4317 cd     &    ' eello_turn3_num',4*eello_turn3_num
4318 C Derivatives in gamma(i)
4319         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4320         call transpose2(auxmat2(1,1),auxmat3(1,1))
4321         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4322         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4323 C Derivatives in gamma(i+1)
4324         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4325         call transpose2(auxmat2(1,1),auxmat3(1,1))
4326         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4327         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4328      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4329 C Cartesian derivatives
4330         do l=1,3
4331 c            ghalf1=0.5d0*agg(l,1)
4332 c            ghalf2=0.5d0*agg(l,2)
4333 c            ghalf3=0.5d0*agg(l,3)
4334 c            ghalf4=0.5d0*agg(l,4)
4335           a_temp(1,1)=aggi(l,1)!+ghalf1
4336           a_temp(1,2)=aggi(l,2)!+ghalf2
4337           a_temp(2,1)=aggi(l,3)!+ghalf3
4338           a_temp(2,2)=aggi(l,4)!+ghalf4
4339           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4340           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4341      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4342           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4343           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4344           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4345           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4346           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4347           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4348      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4349           a_temp(1,1)=aggj(l,1)!+ghalf1
4350           a_temp(1,2)=aggj(l,2)!+ghalf2
4351           a_temp(2,1)=aggj(l,3)!+ghalf3
4352           a_temp(2,2)=aggj(l,4)!+ghalf4
4353           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4354           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4355      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4356           a_temp(1,1)=aggj1(l,1)
4357           a_temp(1,2)=aggj1(l,2)
4358           a_temp(2,1)=aggj1(l,3)
4359           a_temp(2,2)=aggj1(l,4)
4360           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4361           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4362      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4363         enddo
4364       return
4365       end
4366 C-------------------------------------------------------------------------------
4367       subroutine eturn4(i,eello_turn4)
4368 C Third- and fourth-order contributions from turns
4369       implicit real*8 (a-h,o-z)
4370       include 'DIMENSIONS'
4371       include 'COMMON.IOUNITS'
4372       include 'COMMON.GEO'
4373       include 'COMMON.VAR'
4374       include 'COMMON.LOCAL'
4375       include 'COMMON.CHAIN'
4376       include 'COMMON.DERIV'
4377       include 'COMMON.INTERACT'
4378       include 'COMMON.CONTACTS'
4379       include 'COMMON.TORSION'
4380       include 'COMMON.VECTORS'
4381       include 'COMMON.FFIELD'
4382       include 'COMMON.CONTROL'
4383       dimension ggg(3)
4384       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4385      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4386      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4387      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4388      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4389      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4390      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4391       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4392      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4393       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4394      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4395      &    num_conti,j1,j2
4396       j=i+3
4397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4398 C
4399 C               Fourth-order contributions
4400 C
4401 C                 (i+3)o----(i+4)
4402 C                     /  |
4403 C               (i+2)o   |
4404 C                     \  |
4405 C                 (i+1)o----i
4406 C
4407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4408 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4409 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4410 c        write(iout,*)"WCHODZE W PROGRAM"
4411         a_temp(1,1)=a22
4412         a_temp(1,2)=a23
4413         a_temp(2,1)=a32
4414         a_temp(2,2)=a33
4415         iti1=itortyp(itype(i+1))
4416         iti2=itortyp(itype(i+2))
4417         iti3=itortyp(itype(i+3))
4418 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4419         call transpose2(EUg(1,1,i+1),e1t(1,1))
4420         call transpose2(Eug(1,1,i+2),e2t(1,1))
4421         call transpose2(Eug(1,1,i+3),e3t(1,1))
4422 C Ematrix derivative in theta
4423         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4424         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4425         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4426         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4427 c       eta1 in derivative theta
4428         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4429         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4430 c       auxgvec is derivative of Ub2 so i+3 theta
4431         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4432 c       auxalary matrix of E i+1
4433         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4434 c        s1=0.0
4435 c        gs1=0.0
4436         s1=scalar2(b1(1,i+2),auxvec(1))
4437 c derivative of theta i+2 with constant i+3
4438         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4439 c derivative of theta i+2 with constant i+2
4440         gs32=scalar2(b1(1,i+2),auxgvec(1))
4441 c derivative of E matix in theta of i+1
4442         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4443
4444         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4445 c       ea31 in derivative theta
4446         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4447         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4448 c auxilary matrix auxgvec of Ub2 with constant E matirx
4449         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4450 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4451         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4452
4453 c        s2=0.0
4454 c        gs2=0.0
4455         s2=scalar2(b1(1,i+1),auxvec(1))
4456 c derivative of theta i+1 with constant i+3
4457         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4458 c derivative of theta i+2 with constant i+1
4459         gs21=scalar2(b1(1,i+1),auxgvec(1))
4460 c derivative of theta i+3 with constant i+1
4461         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4462 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4463 c     &  gtb1(1,i+1)
4464         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4465 c two derivatives over diffetent matrices
4466 c gtae3e2 is derivative over i+3
4467         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4468 c ae3gte2 is derivative over i+2
4469         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4470         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4471 c three possible derivative over theta E matices
4472 c i+1
4473         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4474 c i+2
4475         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4476 c i+3
4477         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4478         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4479
4480         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4481         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4482         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4483
4484         eello_turn4=eello_turn4-(s1+s2+s3)
4485 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4486         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4487      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4488 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4489 cd     &    ' eello_turn4_num',8*eello_turn4_num
4490 #ifdef NEWCORR
4491         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4492      &                  -(gs13+gsE13+gsEE1)*wturn4
4493         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4494      &                    -(gs23+gs21+gsEE2)*wturn4
4495         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4496      &                    -(gs32+gsE31+gsEE3)*wturn4
4497 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4498 c     &   gs2
4499 #endif
4500         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4501      &      'eturn4',i,j,-(s1+s2+s3)
4502 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4503 c     &    ' eello_turn4_num',8*eello_turn4_num
4504 C Derivatives in gamma(i)
4505         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4506         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4507         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4508         s1=scalar2(b1(1,i+2),auxvec(1))
4509         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4510         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4511         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4512 C Derivatives in gamma(i+1)
4513         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4514         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4515         s2=scalar2(b1(1,i+1),auxvec(1))
4516         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4517         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4518         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4519         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4520 C Derivatives in gamma(i+2)
4521         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4522         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4523         s1=scalar2(b1(1,i+2),auxvec(1))
4524         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4525         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4526         s2=scalar2(b1(1,i+1),auxvec(1))
4527         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4528         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4529         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4530         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4531 C Cartesian derivatives
4532 C Derivatives of this turn contributions in DC(i+2)
4533         if (j.lt.nres-1) then
4534           do l=1,3
4535             a_temp(1,1)=agg(l,1)
4536             a_temp(1,2)=agg(l,2)
4537             a_temp(2,1)=agg(l,3)
4538             a_temp(2,2)=agg(l,4)
4539             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4540             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4541             s1=scalar2(b1(1,i+2),auxvec(1))
4542             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4543             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4544             s2=scalar2(b1(1,i+1),auxvec(1))
4545             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4546             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4547             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4548             ggg(l)=-(s1+s2+s3)
4549             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4550           enddo
4551         endif
4552 C Remaining derivatives of this turn contribution
4553         do l=1,3
4554           a_temp(1,1)=aggi(l,1)
4555           a_temp(1,2)=aggi(l,2)
4556           a_temp(2,1)=aggi(l,3)
4557           a_temp(2,2)=aggi(l,4)
4558           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4559           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4560           s1=scalar2(b1(1,i+2),auxvec(1))
4561           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4562           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4563           s2=scalar2(b1(1,i+1),auxvec(1))
4564           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4565           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4566           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4567           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4568           a_temp(1,1)=aggi1(l,1)
4569           a_temp(1,2)=aggi1(l,2)
4570           a_temp(2,1)=aggi1(l,3)
4571           a_temp(2,2)=aggi1(l,4)
4572           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4573           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4574           s1=scalar2(b1(1,i+2),auxvec(1))
4575           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4576           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4577           s2=scalar2(b1(1,i+1),auxvec(1))
4578           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4579           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4580           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4581           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4582           a_temp(1,1)=aggj(l,1)
4583           a_temp(1,2)=aggj(l,2)
4584           a_temp(2,1)=aggj(l,3)
4585           a_temp(2,2)=aggj(l,4)
4586           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4587           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4588           s1=scalar2(b1(1,i+2),auxvec(1))
4589           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4590           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4591           s2=scalar2(b1(1,i+1),auxvec(1))
4592           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4593           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4594           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4595           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4596           a_temp(1,1)=aggj1(l,1)
4597           a_temp(1,2)=aggj1(l,2)
4598           a_temp(2,1)=aggj1(l,3)
4599           a_temp(2,2)=aggj1(l,4)
4600           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4601           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4602           s1=scalar2(b1(1,i+2),auxvec(1))
4603           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4604           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4605           s2=scalar2(b1(1,i+1),auxvec(1))
4606           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4607           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4608           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4609 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4610           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4611         enddo
4612       return
4613       end
4614 C-----------------------------------------------------------------------------
4615       subroutine vecpr(u,v,w)
4616       implicit real*8(a-h,o-z)
4617       dimension u(3),v(3),w(3)
4618       w(1)=u(2)*v(3)-u(3)*v(2)
4619       w(2)=-u(1)*v(3)+u(3)*v(1)
4620       w(3)=u(1)*v(2)-u(2)*v(1)
4621       return
4622       end
4623 C-----------------------------------------------------------------------------
4624       subroutine unormderiv(u,ugrad,unorm,ungrad)
4625 C This subroutine computes the derivatives of a normalized vector u, given
4626 C the derivatives computed without normalization conditions, ugrad. Returns
4627 C ungrad.
4628       implicit none
4629       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4630       double precision vec(3)
4631       double precision scalar
4632       integer i,j
4633 c      write (2,*) 'ugrad',ugrad
4634 c      write (2,*) 'u',u
4635       do i=1,3
4636         vec(i)=scalar(ugrad(1,i),u(1))
4637       enddo
4638 c      write (2,*) 'vec',vec
4639       do i=1,3
4640         do j=1,3
4641           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4642         enddo
4643       enddo
4644 c      write (2,*) 'ungrad',ungrad
4645       return
4646       end
4647 C-----------------------------------------------------------------------------
4648       subroutine escp_soft_sphere(evdw2,evdw2_14)
4649 C
4650 C This subroutine calculates the excluded-volume interaction energy between
4651 C peptide-group centers and side chains and its gradient in virtual-bond and
4652 C side-chain vectors.
4653 C
4654       implicit real*8 (a-h,o-z)
4655       include 'DIMENSIONS'
4656       include 'COMMON.GEO'
4657       include 'COMMON.VAR'
4658       include 'COMMON.LOCAL'
4659       include 'COMMON.CHAIN'
4660       include 'COMMON.DERIV'
4661       include 'COMMON.INTERACT'
4662       include 'COMMON.FFIELD'
4663       include 'COMMON.IOUNITS'
4664       include 'COMMON.CONTROL'
4665       dimension ggg(3)
4666       evdw2=0.0D0
4667       evdw2_14=0.0d0
4668       r0_scp=4.5d0
4669 cd    print '(a)','Enter ESCP'
4670 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4671 C      do xshift=-1,1
4672 C      do yshift=-1,1
4673 C      do zshift=-1,1
4674       do i=iatscp_s,iatscp_e
4675         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4676         iteli=itel(i)
4677         xi=0.5D0*(c(1,i)+c(1,i+1))
4678         yi=0.5D0*(c(2,i)+c(2,i+1))
4679         zi=0.5D0*(c(3,i)+c(3,i+1))
4680 C Return atom into box, boxxsize is size of box in x dimension
4681 c  134   continue
4682 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4683 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4684 C Condition for being inside the proper box
4685 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4686 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4687 c        go to 134
4688 c        endif
4689 c  135   continue
4690 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4691 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4692 C Condition for being inside the proper box
4693 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4694 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4695 c        go to 135
4696 c c       endif
4697 c  136   continue
4698 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4699 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4700 cC Condition for being inside the proper box
4701 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4702 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4703 c        go to 136
4704 c        endif
4705           xi=mod(xi,boxxsize)
4706           if (xi.lt.0) xi=xi+boxxsize
4707           yi=mod(yi,boxysize)
4708           if (yi.lt.0) yi=yi+boxysize
4709           zi=mod(zi,boxzsize)
4710           if (zi.lt.0) zi=zi+boxzsize
4711 C          xi=xi+xshift*boxxsize
4712 C          yi=yi+yshift*boxysize
4713 C          zi=zi+zshift*boxzsize
4714         do iint=1,nscp_gr(i)
4715
4716         do j=iscpstart(i,iint),iscpend(i,iint)
4717           if (itype(j).eq.ntyp1) cycle
4718           itypj=iabs(itype(j))
4719 C Uncomment following three lines for SC-p interactions
4720 c         xj=c(1,nres+j)-xi
4721 c         yj=c(2,nres+j)-yi
4722 c         zj=c(3,nres+j)-zi
4723 C Uncomment following three lines for Ca-p interactions
4724           xj=c(1,j)
4725           yj=c(2,j)
4726           zj=c(3,j)
4727 c  174   continue
4728 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4729 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4730 C Condition for being inside the proper box
4731 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4732 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4733 c        go to 174
4734 c        endif
4735 c  175   continue
4736 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4737 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4738 cC Condition for being inside the proper box
4739 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4740 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4741 c        go to 175
4742 c        endif
4743 c  176   continue
4744 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4745 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4746 C Condition for being inside the proper box
4747 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4748 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4749 c        go to 176
4750           xj=mod(xj,boxxsize)
4751           if (xj.lt.0) xj=xj+boxxsize
4752           yj=mod(yj,boxysize)
4753           if (yj.lt.0) yj=yj+boxysize
4754           zj=mod(zj,boxzsize)
4755           if (zj.lt.0) zj=zj+boxzsize
4756       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4757       xj_safe=xj
4758       yj_safe=yj
4759       zj_safe=zj
4760       subchap=0
4761       do xshift=-1,1
4762       do yshift=-1,1
4763       do zshift=-1,1
4764           xj=xj_safe+xshift*boxxsize
4765           yj=yj_safe+yshift*boxysize
4766           zj=zj_safe+zshift*boxzsize
4767           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4768           if(dist_temp.lt.dist_init) then
4769             dist_init=dist_temp
4770             xj_temp=xj
4771             yj_temp=yj
4772             zj_temp=zj
4773             subchap=1
4774           endif
4775        enddo
4776        enddo
4777        enddo
4778        if (subchap.eq.1) then
4779           xj=xj_temp-xi
4780           yj=yj_temp-yi
4781           zj=zj_temp-zi
4782        else
4783           xj=xj_safe-xi
4784           yj=yj_safe-yi
4785           zj=zj_safe-zi
4786        endif
4787 c c       endif
4788 C          xj=xj-xi
4789 C          yj=yj-yi
4790 C          zj=zj-zi
4791           rij=xj*xj+yj*yj+zj*zj
4792
4793           r0ij=r0_scp
4794           r0ijsq=r0ij*r0ij
4795           if (rij.lt.r0ijsq) then
4796             evdwij=0.25d0*(rij-r0ijsq)**2
4797             fac=rij-r0ijsq
4798           else
4799             evdwij=0.0d0
4800             fac=0.0d0
4801           endif
4802           evdw2=evdw2+evdwij
4803 C
4804 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4805 C
4806           ggg(1)=xj*fac
4807           ggg(2)=yj*fac
4808           ggg(3)=zj*fac
4809 cgrad          if (j.lt.i) then
4810 cd          write (iout,*) 'j<i'
4811 C Uncomment following three lines for SC-p interactions
4812 c           do k=1,3
4813 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4814 c           enddo
4815 cgrad          else
4816 cd          write (iout,*) 'j>i'
4817 cgrad            do k=1,3
4818 cgrad              ggg(k)=-ggg(k)
4819 C Uncomment following line for SC-p interactions
4820 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4821 cgrad            enddo
4822 cgrad          endif
4823 cgrad          do k=1,3
4824 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4825 cgrad          enddo
4826 cgrad          kstart=min0(i+1,j)
4827 cgrad          kend=max0(i-1,j-1)
4828 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4829 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4830 cgrad          do k=kstart,kend
4831 cgrad            do l=1,3
4832 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4833 cgrad            enddo
4834 cgrad          enddo
4835           do k=1,3
4836             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4837             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4838           enddo
4839         enddo
4840
4841         enddo ! iint
4842       enddo ! i
4843 C      enddo !zshift
4844 C      enddo !yshift
4845 C      enddo !xshift
4846       return
4847       end
4848 C-----------------------------------------------------------------------------
4849       subroutine escp(evdw2,evdw2_14)
4850 C
4851 C This subroutine calculates the excluded-volume interaction energy between
4852 C peptide-group centers and side chains and its gradient in virtual-bond and
4853 C side-chain vectors.
4854 C
4855       implicit real*8 (a-h,o-z)
4856       include 'DIMENSIONS'
4857       include 'COMMON.GEO'
4858       include 'COMMON.VAR'
4859       include 'COMMON.LOCAL'
4860       include 'COMMON.CHAIN'
4861       include 'COMMON.DERIV'
4862       include 'COMMON.INTERACT'
4863       include 'COMMON.FFIELD'
4864       include 'COMMON.IOUNITS'
4865       include 'COMMON.CONTROL'
4866       include 'COMMON.SPLITELE'
4867       dimension ggg(3)
4868       evdw2=0.0D0
4869       evdw2_14=0.0d0
4870 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4871 cd    print '(a)','Enter ESCP'
4872 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4873 C      do xshift=-1,1
4874 C      do yshift=-1,1
4875 C      do zshift=-1,1
4876       do i=iatscp_s,iatscp_e
4877         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4878         iteli=itel(i)
4879         xi=0.5D0*(c(1,i)+c(1,i+1))
4880         yi=0.5D0*(c(2,i)+c(2,i+1))
4881         zi=0.5D0*(c(3,i)+c(3,i+1))
4882           xi=mod(xi,boxxsize)
4883           if (xi.lt.0) xi=xi+boxxsize
4884           yi=mod(yi,boxysize)
4885           if (yi.lt.0) yi=yi+boxysize
4886           zi=mod(zi,boxzsize)
4887           if (zi.lt.0) zi=zi+boxzsize
4888 c          xi=xi+xshift*boxxsize
4889 c          yi=yi+yshift*boxysize
4890 c          zi=zi+zshift*boxzsize
4891 c        print *,xi,yi,zi,'polozenie i'
4892 C Return atom into box, boxxsize is size of box in x dimension
4893 c  134   continue
4894 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4895 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4896 C Condition for being inside the proper box
4897 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4898 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4899 c        go to 134
4900 c        endif
4901 c  135   continue
4902 c          print *,xi,boxxsize,"pierwszy"
4903
4904 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4905 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4906 C Condition for being inside the proper box
4907 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4908 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4909 c        go to 135
4910 c        endif
4911 c  136   continue
4912 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4913 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4914 C Condition for being inside the proper box
4915 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4916 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4917 c        go to 136
4918 c        endif
4919         do iint=1,nscp_gr(i)
4920
4921         do j=iscpstart(i,iint),iscpend(i,iint)
4922           itypj=iabs(itype(j))
4923           if (itypj.eq.ntyp1) cycle
4924 C Uncomment following three lines for SC-p interactions
4925 c         xj=c(1,nres+j)-xi
4926 c         yj=c(2,nres+j)-yi
4927 c         zj=c(3,nres+j)-zi
4928 C Uncomment following three lines for Ca-p interactions
4929           xj=c(1,j)
4930           yj=c(2,j)
4931           zj=c(3,j)
4932           xj=mod(xj,boxxsize)
4933           if (xj.lt.0) xj=xj+boxxsize
4934           yj=mod(yj,boxysize)
4935           if (yj.lt.0) yj=yj+boxysize
4936           zj=mod(zj,boxzsize)
4937           if (zj.lt.0) zj=zj+boxzsize
4938 c  174   continue
4939 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4940 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4941 C Condition for being inside the proper box
4942 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4943 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4944 c        go to 174
4945 c        endif
4946 c  175   continue
4947 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4948 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4949 cC Condition for being inside the proper box
4950 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4951 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4952 c        go to 175
4953 c        endif
4954 c  176   continue
4955 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4956 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4957 C Condition for being inside the proper box
4958 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4959 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4960 c        go to 176
4961 c        endif
4962 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4963       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4964       xj_safe=xj
4965       yj_safe=yj
4966       zj_safe=zj
4967       subchap=0
4968       do xshift=-1,1
4969       do yshift=-1,1
4970       do zshift=-1,1
4971           xj=xj_safe+xshift*boxxsize
4972           yj=yj_safe+yshift*boxysize
4973           zj=zj_safe+zshift*boxzsize
4974           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4975           if(dist_temp.lt.dist_init) then
4976             dist_init=dist_temp
4977             xj_temp=xj
4978             yj_temp=yj
4979             zj_temp=zj
4980             subchap=1
4981           endif
4982        enddo
4983        enddo
4984        enddo
4985        if (subchap.eq.1) then
4986           xj=xj_temp-xi
4987           yj=yj_temp-yi
4988           zj=zj_temp-zi
4989        else
4990           xj=xj_safe-xi
4991           yj=yj_safe-yi
4992           zj=zj_safe-zi
4993        endif
4994 c          print *,xj,yj,zj,'polozenie j'
4995           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4996 c          print *,rrij
4997           sss=sscale(1.0d0/(dsqrt(rrij)))
4998 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4999 c          if (sss.eq.0) print *,'czasem jest OK'
5000           if (sss.le.0.0d0) cycle
5001           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5002           fac=rrij**expon2
5003           e1=fac*fac*aad(itypj,iteli)
5004           e2=fac*bad(itypj,iteli)
5005           if (iabs(j-i) .le. 2) then
5006             e1=scal14*e1
5007             e2=scal14*e2
5008             evdw2_14=evdw2_14+(e1+e2)*sss
5009           endif
5010           evdwij=e1+e2
5011           evdw2=evdw2+evdwij*sss
5012           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5013      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5014      &       bad(itypj,iteli)
5015 C
5016 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5017 C
5018           fac=-(evdwij+e1)*rrij*sss
5019           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5020           ggg(1)=xj*fac
5021           ggg(2)=yj*fac
5022           ggg(3)=zj*fac
5023 cgrad          if (j.lt.i) then
5024 cd          write (iout,*) 'j<i'
5025 C Uncomment following three lines for SC-p interactions
5026 c           do k=1,3
5027 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5028 c           enddo
5029 cgrad          else
5030 cd          write (iout,*) 'j>i'
5031 cgrad            do k=1,3
5032 cgrad              ggg(k)=-ggg(k)
5033 C Uncomment following line for SC-p interactions
5034 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5035 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5036 cgrad            enddo
5037 cgrad          endif
5038 cgrad          do k=1,3
5039 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5040 cgrad          enddo
5041 cgrad          kstart=min0(i+1,j)
5042 cgrad          kend=max0(i-1,j-1)
5043 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5044 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5045 cgrad          do k=kstart,kend
5046 cgrad            do l=1,3
5047 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5048 cgrad            enddo
5049 cgrad          enddo
5050           do k=1,3
5051             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5052             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5053           enddo
5054 c        endif !endif for sscale cutoff
5055         enddo ! j
5056
5057         enddo ! iint
5058       enddo ! i
5059 c      enddo !zshift
5060 c      enddo !yshift
5061 c      enddo !xshift
5062       do i=1,nct
5063         do j=1,3
5064           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5065           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5066           gradx_scp(j,i)=expon*gradx_scp(j,i)
5067         enddo
5068       enddo
5069 C******************************************************************************
5070 C
5071 C                              N O T E !!!
5072 C
5073 C To save time the factor EXPON has been extracted from ALL components
5074 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5075 C use!
5076 C
5077 C******************************************************************************
5078       return
5079       end
5080 C--------------------------------------------------------------------------
5081       subroutine edis(ehpb)
5082 C
5083 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5084 C
5085       implicit real*8 (a-h,o-z)
5086       include 'DIMENSIONS'
5087       include 'COMMON.SBRIDGE'
5088       include 'COMMON.CHAIN'
5089       include 'COMMON.DERIV'
5090       include 'COMMON.VAR'
5091       include 'COMMON.INTERACT'
5092       include 'COMMON.IOUNITS'
5093       dimension ggg(3)
5094       ehpb=0.0D0
5095 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5096 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5097       if (link_end.eq.0) return
5098       do i=link_start,link_end
5099 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5100 C CA-CA distance used in regularization of structure.
5101         ii=ihpb(i)
5102         jj=jhpb(i)
5103 C iii and jjj point to the residues for which the distance is assigned.
5104         if (ii.gt.nres) then
5105           iii=ii-nres
5106           jjj=jj-nres
5107         else
5108           iii=ii
5109           jjj=jj
5110         endif
5111 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5112 c     &    dhpb(i),dhpb1(i),forcon(i)
5113 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5114 C    distance and angle dependent SS bond potential.
5115 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5116 C     & iabs(itype(jjj)).eq.1) then
5117 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5118 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5119         if (.not.dyn_ss .and. i.le.nss) then
5120 C 15/02/13 CC dynamic SSbond - additional check
5121          if (ii.gt.nres
5122      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5123           call ssbond_ene(iii,jjj,eij)
5124           ehpb=ehpb+2*eij
5125          endif
5126 cd          write (iout,*) "eij",eij
5127         else
5128 C Calculate the distance between the two points and its difference from the
5129 C target distance.
5130           dd=dist(ii,jj)
5131             rdis=dd-dhpb(i)
5132 C Get the force constant corresponding to this distance.
5133             waga=forcon(i)
5134 C Calculate the contribution to energy.
5135             ehpb=ehpb+waga*rdis*rdis
5136 C
5137 C Evaluate gradient.
5138 C
5139             fac=waga*rdis/dd
5140 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5141 cd   &   ' waga=',waga,' fac=',fac
5142             do j=1,3
5143               ggg(j)=fac*(c(j,jj)-c(j,ii))
5144             enddo
5145 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5146 C If this is a SC-SC distance, we need to calculate the contributions to the
5147 C Cartesian gradient in the SC vectors (ghpbx).
5148           if (iii.lt.ii) then
5149           do j=1,3
5150             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5151             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5152           enddo
5153           endif
5154 cgrad        do j=iii,jjj-1
5155 cgrad          do k=1,3
5156 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5157 cgrad          enddo
5158 cgrad        enddo
5159           do k=1,3
5160             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5161             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5162           enddo
5163         endif
5164       enddo
5165       ehpb=0.5D0*ehpb
5166       return
5167       end
5168 C--------------------------------------------------------------------------
5169       subroutine ssbond_ene(i,j,eij)
5170 C
5171 C Calculate the distance and angle dependent SS-bond potential energy
5172 C using a free-energy function derived based on RHF/6-31G** ab initio
5173 C calculations of diethyl disulfide.
5174 C
5175 C A. Liwo and U. Kozlowska, 11/24/03
5176 C
5177       implicit real*8 (a-h,o-z)
5178       include 'DIMENSIONS'
5179       include 'COMMON.SBRIDGE'
5180       include 'COMMON.CHAIN'
5181       include 'COMMON.DERIV'
5182       include 'COMMON.LOCAL'
5183       include 'COMMON.INTERACT'
5184       include 'COMMON.VAR'
5185       include 'COMMON.IOUNITS'
5186       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5187       itypi=iabs(itype(i))
5188       xi=c(1,nres+i)
5189       yi=c(2,nres+i)
5190       zi=c(3,nres+i)
5191       dxi=dc_norm(1,nres+i)
5192       dyi=dc_norm(2,nres+i)
5193       dzi=dc_norm(3,nres+i)
5194 c      dsci_inv=dsc_inv(itypi)
5195       dsci_inv=vbld_inv(nres+i)
5196       itypj=iabs(itype(j))
5197 c      dscj_inv=dsc_inv(itypj)
5198       dscj_inv=vbld_inv(nres+j)
5199       xj=c(1,nres+j)-xi
5200       yj=c(2,nres+j)-yi
5201       zj=c(3,nres+j)-zi
5202       dxj=dc_norm(1,nres+j)
5203       dyj=dc_norm(2,nres+j)
5204       dzj=dc_norm(3,nres+j)
5205       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5206       rij=dsqrt(rrij)
5207       erij(1)=xj*rij
5208       erij(2)=yj*rij
5209       erij(3)=zj*rij
5210       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5211       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5212       om12=dxi*dxj+dyi*dyj+dzi*dzj
5213       do k=1,3
5214         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5215         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5216       enddo
5217       rij=1.0d0/rij
5218       deltad=rij-d0cm
5219       deltat1=1.0d0-om1
5220       deltat2=1.0d0+om2
5221       deltat12=om2-om1+2.0d0
5222       cosphi=om12-om1*om2
5223       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5224      &  +akct*deltad*deltat12
5225      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5226 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5227 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5228 c     &  " deltat12",deltat12," eij",eij
5229       ed=2*akcm*deltad+akct*deltat12
5230       pom1=akct*deltad
5231       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5232       eom1=-2*akth*deltat1-pom1-om2*pom2
5233       eom2= 2*akth*deltat2+pom1-om1*pom2
5234       eom12=pom2
5235       do k=1,3
5236         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5237         ghpbx(k,i)=ghpbx(k,i)-ggk
5238      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5239      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5240         ghpbx(k,j)=ghpbx(k,j)+ggk
5241      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5242      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5243         ghpbc(k,i)=ghpbc(k,i)-ggk
5244         ghpbc(k,j)=ghpbc(k,j)+ggk
5245       enddo
5246 C
5247 C Calculate the components of the gradient in DC and X
5248 C
5249 cgrad      do k=i,j-1
5250 cgrad        do l=1,3
5251 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5252 cgrad        enddo
5253 cgrad      enddo
5254       return
5255       end
5256 C--------------------------------------------------------------------------
5257       subroutine ebond(estr)
5258 c
5259 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5260 c
5261       implicit real*8 (a-h,o-z)
5262       include 'DIMENSIONS'
5263       include 'COMMON.LOCAL'
5264       include 'COMMON.GEO'
5265       include 'COMMON.INTERACT'
5266       include 'COMMON.DERIV'
5267       include 'COMMON.VAR'
5268       include 'COMMON.CHAIN'
5269       include 'COMMON.IOUNITS'
5270       include 'COMMON.NAMES'
5271       include 'COMMON.FFIELD'
5272       include 'COMMON.CONTROL'
5273       include 'COMMON.SETUP'
5274       double precision u(3),ud(3)
5275       estr=0.0d0
5276       estr1=0.0d0
5277       do i=ibondp_start,ibondp_end
5278         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5279 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5280 c          do j=1,3
5281 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5282 c     &      *dc(j,i-1)/vbld(i)
5283 c          enddo
5284 c          if (energy_dec) write(iout,*)
5285 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5286 c        else
5287 C       Checking if it involves dummy (NH3+ or COO-) group
5288          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5289 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5290         diff = vbld(i)-vbldpDUM
5291          else
5292 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5293         diff = vbld(i)-vbldp0
5294          endif
5295         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5296      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5297         estr=estr+diff*diff
5298         do j=1,3
5299           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5300         enddo
5301 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5302 c        endif
5303       enddo
5304       estr=0.5d0*AKP*estr+estr1
5305 c
5306 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5307 c
5308       do i=ibond_start,ibond_end
5309         iti=iabs(itype(i))
5310         if (iti.ne.10 .and. iti.ne.ntyp1) then
5311           nbi=nbondterm(iti)
5312           if (nbi.eq.1) then
5313             diff=vbld(i+nres)-vbldsc0(1,iti)
5314             if (energy_dec)  write (iout,*)
5315      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5316      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5317             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5318             do j=1,3
5319               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5320             enddo
5321           else
5322             do j=1,nbi
5323               diff=vbld(i+nres)-vbldsc0(j,iti)
5324               ud(j)=aksc(j,iti)*diff
5325               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5326             enddo
5327             uprod=u(1)
5328             do j=2,nbi
5329               uprod=uprod*u(j)
5330             enddo
5331             usum=0.0d0
5332             usumsqder=0.0d0
5333             do j=1,nbi
5334               uprod1=1.0d0
5335               uprod2=1.0d0
5336               do k=1,nbi
5337                 if (k.ne.j) then
5338                   uprod1=uprod1*u(k)
5339                   uprod2=uprod2*u(k)*u(k)
5340                 endif
5341               enddo
5342               usum=usum+uprod1
5343               usumsqder=usumsqder+ud(j)*uprod2
5344             enddo
5345             estr=estr+uprod/usum
5346             do j=1,3
5347              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5348             enddo
5349           endif
5350         endif
5351       enddo
5352       return
5353       end
5354 #ifdef CRYST_THETA
5355 C--------------------------------------------------------------------------
5356       subroutine ebend(etheta)
5357 C
5358 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5359 C angles gamma and its derivatives in consecutive thetas and gammas.
5360 C
5361       implicit real*8 (a-h,o-z)
5362       include 'DIMENSIONS'
5363       include 'COMMON.LOCAL'
5364       include 'COMMON.GEO'
5365       include 'COMMON.INTERACT'
5366       include 'COMMON.DERIV'
5367       include 'COMMON.VAR'
5368       include 'COMMON.CHAIN'
5369       include 'COMMON.IOUNITS'
5370       include 'COMMON.NAMES'
5371       include 'COMMON.FFIELD'
5372       include 'COMMON.CONTROL'
5373       common /calcthet/ term1,term2,termm,diffak,ratak,
5374      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5375      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5376       double precision y(2),z(2)
5377       delta=0.02d0*pi
5378 c      time11=dexp(-2*time)
5379 c      time12=1.0d0
5380       etheta=0.0D0
5381 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5382       do i=ithet_start,ithet_end
5383         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5384      &  .or.itype(i).eq.ntyp1) cycle
5385 C Zero the energy function and its derivative at 0 or pi.
5386         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5387         it=itype(i-1)
5388         ichir1=isign(1,itype(i-2))
5389         ichir2=isign(1,itype(i))
5390          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5391          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5392          if (itype(i-1).eq.10) then
5393           itype1=isign(10,itype(i-2))
5394           ichir11=isign(1,itype(i-2))
5395           ichir12=isign(1,itype(i-2))
5396           itype2=isign(10,itype(i))
5397           ichir21=isign(1,itype(i))
5398           ichir22=isign(1,itype(i))
5399          endif
5400
5401         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5402 #ifdef OSF
5403           phii=phi(i)
5404           if (phii.ne.phii) phii=150.0
5405 #else
5406           phii=phi(i)
5407 #endif
5408           y(1)=dcos(phii)
5409           y(2)=dsin(phii)
5410         else
5411           y(1)=0.0D0
5412           y(2)=0.0D0
5413         endif
5414         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5415 #ifdef OSF
5416           phii1=phi(i+1)
5417           if (phii1.ne.phii1) phii1=150.0
5418           phii1=pinorm(phii1)
5419           z(1)=cos(phii1)
5420 #else
5421           phii1=phi(i+1)
5422 #endif
5423           z(1)=dcos(phii1)
5424           z(2)=dsin(phii1)
5425         else
5426           z(1)=0.0D0
5427           z(2)=0.0D0
5428         endif
5429 C Calculate the "mean" value of theta from the part of the distribution
5430 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5431 C In following comments this theta will be referred to as t_c.
5432         thet_pred_mean=0.0d0
5433         do k=1,2
5434             athetk=athet(k,it,ichir1,ichir2)
5435             bthetk=bthet(k,it,ichir1,ichir2)
5436           if (it.eq.10) then
5437              athetk=athet(k,itype1,ichir11,ichir12)
5438              bthetk=bthet(k,itype2,ichir21,ichir22)
5439           endif
5440          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5441 c         write(iout,*) 'chuj tu', y(k),z(k)
5442         enddo
5443         dthett=thet_pred_mean*ssd
5444         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5445 C Derivatives of the "mean" values in gamma1 and gamma2.
5446         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5447      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5448          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5449      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5450          if (it.eq.10) then
5451       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5452      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5453         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5454      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5455          endif
5456         if (theta(i).gt.pi-delta) then
5457           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5458      &         E_tc0)
5459           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5460           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5461           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5462      &        E_theta)
5463           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5464      &        E_tc)
5465         else if (theta(i).lt.delta) then
5466           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5467           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5468           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5469      &        E_theta)
5470           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5471           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5472      &        E_tc)
5473         else
5474           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5475      &        E_theta,E_tc)
5476         endif
5477         etheta=etheta+ethetai
5478         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5479      &      'ebend',i,ethetai,theta(i),itype(i)
5480         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5481         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5482         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5483       enddo
5484 C Ufff.... We've done all this!!!
5485       return
5486       end
5487 C---------------------------------------------------------------------------
5488       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5489      &     E_tc)
5490       implicit real*8 (a-h,o-z)
5491       include 'DIMENSIONS'
5492       include 'COMMON.LOCAL'
5493       include 'COMMON.IOUNITS'
5494       common /calcthet/ term1,term2,termm,diffak,ratak,
5495      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5496      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5497 C Calculate the contributions to both Gaussian lobes.
5498 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5499 C The "polynomial part" of the "standard deviation" of this part of
5500 C the distributioni.
5501 ccc        write (iout,*) thetai,thet_pred_mean
5502         sig=polthet(3,it)
5503         do j=2,0,-1
5504           sig=sig*thet_pred_mean+polthet(j,it)
5505         enddo
5506 C Derivative of the "interior part" of the "standard deviation of the"
5507 C gamma-dependent Gaussian lobe in t_c.
5508         sigtc=3*polthet(3,it)
5509         do j=2,1,-1
5510           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5511         enddo
5512         sigtc=sig*sigtc
5513 C Set the parameters of both Gaussian lobes of the distribution.
5514 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5515         fac=sig*sig+sigc0(it)
5516         sigcsq=fac+fac
5517         sigc=1.0D0/sigcsq
5518 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5519         sigsqtc=-4.0D0*sigcsq*sigtc
5520 c       print *,i,sig,sigtc,sigsqtc
5521 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5522         sigtc=-sigtc/(fac*fac)
5523 C Following variable is sigma(t_c)**(-2)
5524         sigcsq=sigcsq*sigcsq
5525         sig0i=sig0(it)
5526         sig0inv=1.0D0/sig0i**2
5527         delthec=thetai-thet_pred_mean
5528         delthe0=thetai-theta0i
5529         term1=-0.5D0*sigcsq*delthec*delthec
5530         term2=-0.5D0*sig0inv*delthe0*delthe0
5531 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5532 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5533 C NaNs in taking the logarithm. We extract the largest exponent which is added
5534 C to the energy (this being the log of the distribution) at the end of energy
5535 C term evaluation for this virtual-bond angle.
5536         if (term1.gt.term2) then
5537           termm=term1
5538           term2=dexp(term2-termm)
5539           term1=1.0d0
5540         else
5541           termm=term2
5542           term1=dexp(term1-termm)
5543           term2=1.0d0
5544         endif
5545 C The ratio between the gamma-independent and gamma-dependent lobes of
5546 C the distribution is a Gaussian function of thet_pred_mean too.
5547         diffak=gthet(2,it)-thet_pred_mean
5548         ratak=diffak/gthet(3,it)**2
5549         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5550 C Let's differentiate it in thet_pred_mean NOW.
5551         aktc=ak*ratak
5552 C Now put together the distribution terms to make complete distribution.
5553         termexp=term1+ak*term2
5554         termpre=sigc+ak*sig0i
5555 C Contribution of the bending energy from this theta is just the -log of
5556 C the sum of the contributions from the two lobes and the pre-exponential
5557 C factor. Simple enough, isn't it?
5558         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5559 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5560 C NOW the derivatives!!!
5561 C 6/6/97 Take into account the deformation.
5562         E_theta=(delthec*sigcsq*term1
5563      &       +ak*delthe0*sig0inv*term2)/termexp
5564         E_tc=((sigtc+aktc*sig0i)/termpre
5565      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5566      &       aktc*term2)/termexp)
5567       return
5568       end
5569 c-----------------------------------------------------------------------------
5570       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5571       implicit real*8 (a-h,o-z)
5572       include 'DIMENSIONS'
5573       include 'COMMON.LOCAL'
5574       include 'COMMON.IOUNITS'
5575       common /calcthet/ term1,term2,termm,diffak,ratak,
5576      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5577      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5578       delthec=thetai-thet_pred_mean
5579       delthe0=thetai-theta0i
5580 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5581       t3 = thetai-thet_pred_mean
5582       t6 = t3**2
5583       t9 = term1
5584       t12 = t3*sigcsq
5585       t14 = t12+t6*sigsqtc
5586       t16 = 1.0d0
5587       t21 = thetai-theta0i
5588       t23 = t21**2
5589       t26 = term2
5590       t27 = t21*t26
5591       t32 = termexp
5592       t40 = t32**2
5593       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5594      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5595      & *(-t12*t9-ak*sig0inv*t27)
5596       return
5597       end
5598 #else
5599 C--------------------------------------------------------------------------
5600       subroutine ebend(etheta)
5601 C
5602 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5603 C angles gamma and its derivatives in consecutive thetas and gammas.
5604 C ab initio-derived potentials from
5605 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5606 C
5607       implicit real*8 (a-h,o-z)
5608       include 'DIMENSIONS'
5609       include 'COMMON.LOCAL'
5610       include 'COMMON.GEO'
5611       include 'COMMON.INTERACT'
5612       include 'COMMON.DERIV'
5613       include 'COMMON.VAR'
5614       include 'COMMON.CHAIN'
5615       include 'COMMON.IOUNITS'
5616       include 'COMMON.NAMES'
5617       include 'COMMON.FFIELD'
5618       include 'COMMON.CONTROL'
5619       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5620      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5621      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5622      & sinph1ph2(maxdouble,maxdouble)
5623       logical lprn /.false./, lprn1 /.false./
5624       etheta=0.0D0
5625       do i=ithet_start,ithet_end
5626 c        print *,i,itype(i-1),itype(i),itype(i-2)
5627         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5628      &  .or.itype(i).eq.ntyp1) cycle
5629 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5630
5631         if (iabs(itype(i+1)).eq.20) iblock=2
5632         if (iabs(itype(i+1)).ne.20) iblock=1
5633         dethetai=0.0d0
5634         dephii=0.0d0
5635         dephii1=0.0d0
5636         theti2=0.5d0*theta(i)
5637         ityp2=ithetyp((itype(i-1)))
5638         do k=1,nntheterm
5639           coskt(k)=dcos(k*theti2)
5640           sinkt(k)=dsin(k*theti2)
5641         enddo
5642         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5643 #ifdef OSF
5644           phii=phi(i)
5645           if (phii.ne.phii) phii=150.0
5646 #else
5647           phii=phi(i)
5648 #endif
5649           ityp1=ithetyp((itype(i-2)))
5650 C propagation of chirality for glycine type
5651           do k=1,nsingle
5652             cosph1(k)=dcos(k*phii)
5653             sinph1(k)=dsin(k*phii)
5654           enddo
5655         else
5656           phii=0.0d0
5657           ityp1=nthetyp+1
5658           do k=1,nsingle
5659             cosph1(k)=0.0d0
5660             sinph1(k)=0.0d0
5661           enddo
5662         endif
5663         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5664 #ifdef OSF
5665           phii1=phi(i+1)
5666           if (phii1.ne.phii1) phii1=150.0
5667           phii1=pinorm(phii1)
5668 #else
5669           phii1=phi(i+1)
5670 #endif
5671           ityp3=ithetyp((itype(i)))
5672           do k=1,nsingle
5673             cosph2(k)=dcos(k*phii1)
5674             sinph2(k)=dsin(k*phii1)
5675           enddo
5676         else
5677           phii1=0.0d0
5678           ityp3=nthetyp+1
5679           do k=1,nsingle
5680             cosph2(k)=0.0d0
5681             sinph2(k)=0.0d0
5682           enddo
5683         endif
5684         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5685         do k=1,ndouble
5686           do l=1,k-1
5687             ccl=cosph1(l)*cosph2(k-l)
5688             ssl=sinph1(l)*sinph2(k-l)
5689             scl=sinph1(l)*cosph2(k-l)
5690             csl=cosph1(l)*sinph2(k-l)
5691             cosph1ph2(l,k)=ccl-ssl
5692             cosph1ph2(k,l)=ccl+ssl
5693             sinph1ph2(l,k)=scl+csl
5694             sinph1ph2(k,l)=scl-csl
5695           enddo
5696         enddo
5697         if (lprn) then
5698         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5699      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5700         write (iout,*) "coskt and sinkt"
5701         do k=1,nntheterm
5702           write (iout,*) k,coskt(k),sinkt(k)
5703         enddo
5704         endif
5705         do k=1,ntheterm
5706           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5707           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5708      &      *coskt(k)
5709           if (lprn)
5710      &    write (iout,*) "k",k,"
5711      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5712      &     " ethetai",ethetai
5713         enddo
5714         if (lprn) then
5715         write (iout,*) "cosph and sinph"
5716         do k=1,nsingle
5717           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5718         enddo
5719         write (iout,*) "cosph1ph2 and sinph2ph2"
5720         do k=2,ndouble
5721           do l=1,k-1
5722             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5723      &         sinph1ph2(l,k),sinph1ph2(k,l)
5724           enddo
5725         enddo
5726         write(iout,*) "ethetai",ethetai
5727         endif
5728         do m=1,ntheterm2
5729           do k=1,nsingle
5730             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5731      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5732      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5733      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5734             ethetai=ethetai+sinkt(m)*aux
5735             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5736             dephii=dephii+k*sinkt(m)*(
5737      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5738      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5739             dephii1=dephii1+k*sinkt(m)*(
5740      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5741      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5742             if (lprn)
5743      &      write (iout,*) "m",m," k",k," bbthet",
5744      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5745      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5746      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5747      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5748           enddo
5749         enddo
5750         if (lprn)
5751      &  write(iout,*) "ethetai",ethetai
5752         do m=1,ntheterm3
5753           do k=2,ndouble
5754             do l=1,k-1
5755               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5756      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5757      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5758      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5759               ethetai=ethetai+sinkt(m)*aux
5760               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5761               dephii=dephii+l*sinkt(m)*(
5762      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5763      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5764      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5765      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5766               dephii1=dephii1+(k-l)*sinkt(m)*(
5767      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5768      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5769      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5770      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5771               if (lprn) then
5772               write (iout,*) "m",m," k",k," l",l," ffthet",
5773      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5774      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5775      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5776      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5777      &            " ethetai",ethetai
5778               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5779      &            cosph1ph2(k,l)*sinkt(m),
5780      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5781               endif
5782             enddo
5783           enddo
5784         enddo
5785 10      continue
5786 c        lprn1=.true.
5787         if (lprn1)
5788      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5789      &   i,theta(i)*rad2deg,phii*rad2deg,
5790      &   phii1*rad2deg,ethetai
5791 c        lprn1=.false.
5792         etheta=etheta+ethetai
5793         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5794         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5795         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5796       enddo
5797       return
5798       end
5799 #endif
5800 #ifdef CRYST_SC
5801 c-----------------------------------------------------------------------------
5802       subroutine esc(escloc)
5803 C Calculate the local energy of a side chain and its derivatives in the
5804 C corresponding virtual-bond valence angles THETA and the spherical angles
5805 C ALPHA and OMEGA.
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'COMMON.GEO'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.VAR'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.DERIV'
5813       include 'COMMON.CHAIN'
5814       include 'COMMON.IOUNITS'
5815       include 'COMMON.NAMES'
5816       include 'COMMON.FFIELD'
5817       include 'COMMON.CONTROL'
5818       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5819      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5820       common /sccalc/ time11,time12,time112,theti,it,nlobit
5821       delta=0.02d0*pi
5822       escloc=0.0D0
5823 c     write (iout,'(a)') 'ESC'
5824       do i=loc_start,loc_end
5825         it=itype(i)
5826         if (it.eq.ntyp1) cycle
5827         if (it.eq.10) goto 1
5828         nlobit=nlob(iabs(it))
5829 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5830 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5831         theti=theta(i+1)-pipol
5832         x(1)=dtan(theti)
5833         x(2)=alph(i)
5834         x(3)=omeg(i)
5835
5836         if (x(2).gt.pi-delta) then
5837           xtemp(1)=x(1)
5838           xtemp(2)=pi-delta
5839           xtemp(3)=x(3)
5840           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5841           xtemp(2)=pi
5842           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5843           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5844      &        escloci,dersc(2))
5845           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5846      &        ddersc0(1),dersc(1))
5847           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5848      &        ddersc0(3),dersc(3))
5849           xtemp(2)=pi-delta
5850           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5851           xtemp(2)=pi
5852           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5853           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5854      &            dersc0(2),esclocbi,dersc02)
5855           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5856      &            dersc12,dersc01)
5857           call splinthet(x(2),0.5d0*delta,ss,ssd)
5858           dersc0(1)=dersc01
5859           dersc0(2)=dersc02
5860           dersc0(3)=0.0d0
5861           do k=1,3
5862             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5863           enddo
5864           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5865 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5866 c    &             esclocbi,ss,ssd
5867           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5868 c         escloci=esclocbi
5869 c         write (iout,*) escloci
5870         else if (x(2).lt.delta) then
5871           xtemp(1)=x(1)
5872           xtemp(2)=delta
5873           xtemp(3)=x(3)
5874           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5875           xtemp(2)=0.0d0
5876           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5877           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5878      &        escloci,dersc(2))
5879           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5880      &        ddersc0(1),dersc(1))
5881           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5882      &        ddersc0(3),dersc(3))
5883           xtemp(2)=delta
5884           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5885           xtemp(2)=0.0d0
5886           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5887           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5888      &            dersc0(2),esclocbi,dersc02)
5889           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5890      &            dersc12,dersc01)
5891           dersc0(1)=dersc01
5892           dersc0(2)=dersc02
5893           dersc0(3)=0.0d0
5894           call splinthet(x(2),0.5d0*delta,ss,ssd)
5895           do k=1,3
5896             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5897           enddo
5898           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5899 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5900 c    &             esclocbi,ss,ssd
5901           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5902 c         write (iout,*) escloci
5903         else
5904           call enesc(x,escloci,dersc,ddummy,.false.)
5905         endif
5906
5907         escloc=escloc+escloci
5908         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5909      &     'escloc',i,escloci
5910 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5911
5912         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5913      &   wscloc*dersc(1)
5914         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5915         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5916     1   continue
5917       enddo
5918       return
5919       end
5920 C---------------------------------------------------------------------------
5921       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5922       implicit real*8 (a-h,o-z)
5923       include 'DIMENSIONS'
5924       include 'COMMON.GEO'
5925       include 'COMMON.LOCAL'
5926       include 'COMMON.IOUNITS'
5927       common /sccalc/ time11,time12,time112,theti,it,nlobit
5928       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5929       double precision contr(maxlob,-1:1)
5930       logical mixed
5931 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5932         escloc_i=0.0D0
5933         do j=1,3
5934           dersc(j)=0.0D0
5935           if (mixed) ddersc(j)=0.0d0
5936         enddo
5937         x3=x(3)
5938
5939 C Because of periodicity of the dependence of the SC energy in omega we have
5940 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5941 C To avoid underflows, first compute & store the exponents.
5942
5943         do iii=-1,1
5944
5945           x(3)=x3+iii*dwapi
5946
5947           do j=1,nlobit
5948             do k=1,3
5949               z(k)=x(k)-censc(k,j,it)
5950             enddo
5951             do k=1,3
5952               Axk=0.0D0
5953               do l=1,3
5954                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5955               enddo
5956               Ax(k,j,iii)=Axk
5957             enddo
5958             expfac=0.0D0
5959             do k=1,3
5960               expfac=expfac+Ax(k,j,iii)*z(k)
5961             enddo
5962             contr(j,iii)=expfac
5963           enddo ! j
5964
5965         enddo ! iii
5966
5967         x(3)=x3
5968 C As in the case of ebend, we want to avoid underflows in exponentiation and
5969 C subsequent NaNs and INFs in energy calculation.
5970 C Find the largest exponent
5971         emin=contr(1,-1)
5972         do iii=-1,1
5973           do j=1,nlobit
5974             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5975           enddo
5976         enddo
5977         emin=0.5D0*emin
5978 cd      print *,'it=',it,' emin=',emin
5979
5980 C Compute the contribution to SC energy and derivatives
5981         do iii=-1,1
5982
5983           do j=1,nlobit
5984 #ifdef OSF
5985             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5986             if(adexp.ne.adexp) adexp=1.0
5987             expfac=dexp(adexp)
5988 #else
5989             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5990 #endif
5991 cd          print *,'j=',j,' expfac=',expfac
5992             escloc_i=escloc_i+expfac
5993             do k=1,3
5994               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5995             enddo
5996             if (mixed) then
5997               do k=1,3,2
5998                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5999      &            +gaussc(k,2,j,it))*expfac
6000               enddo
6001             endif
6002           enddo
6003
6004         enddo ! iii
6005
6006         dersc(1)=dersc(1)/cos(theti)**2
6007         ddersc(1)=ddersc(1)/cos(theti)**2
6008         ddersc(3)=ddersc(3)
6009
6010         escloci=-(dlog(escloc_i)-emin)
6011         do j=1,3
6012           dersc(j)=dersc(j)/escloc_i
6013         enddo
6014         if (mixed) then
6015           do j=1,3,2
6016             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6017           enddo
6018         endif
6019       return
6020       end
6021 C------------------------------------------------------------------------------
6022       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6023       implicit real*8 (a-h,o-z)
6024       include 'DIMENSIONS'
6025       include 'COMMON.GEO'
6026       include 'COMMON.LOCAL'
6027       include 'COMMON.IOUNITS'
6028       common /sccalc/ time11,time12,time112,theti,it,nlobit
6029       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6030       double precision contr(maxlob)
6031       logical mixed
6032
6033       escloc_i=0.0D0
6034
6035       do j=1,3
6036         dersc(j)=0.0D0
6037       enddo
6038
6039       do j=1,nlobit
6040         do k=1,2
6041           z(k)=x(k)-censc(k,j,it)
6042         enddo
6043         z(3)=dwapi
6044         do k=1,3
6045           Axk=0.0D0
6046           do l=1,3
6047             Axk=Axk+gaussc(l,k,j,it)*z(l)
6048           enddo
6049           Ax(k,j)=Axk
6050         enddo
6051         expfac=0.0D0
6052         do k=1,3
6053           expfac=expfac+Ax(k,j)*z(k)
6054         enddo
6055         contr(j)=expfac
6056       enddo ! j
6057
6058 C As in the case of ebend, we want to avoid underflows in exponentiation and
6059 C subsequent NaNs and INFs in energy calculation.
6060 C Find the largest exponent
6061       emin=contr(1)
6062       do j=1,nlobit
6063         if (emin.gt.contr(j)) emin=contr(j)
6064       enddo
6065       emin=0.5D0*emin
6066
6067 C Compute the contribution to SC energy and derivatives
6068
6069       dersc12=0.0d0
6070       do j=1,nlobit
6071         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6072         escloc_i=escloc_i+expfac
6073         do k=1,2
6074           dersc(k)=dersc(k)+Ax(k,j)*expfac
6075         enddo
6076         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6077      &            +gaussc(1,2,j,it))*expfac
6078         dersc(3)=0.0d0
6079       enddo
6080
6081       dersc(1)=dersc(1)/cos(theti)**2
6082       dersc12=dersc12/cos(theti)**2
6083       escloci=-(dlog(escloc_i)-emin)
6084       do j=1,2
6085         dersc(j)=dersc(j)/escloc_i
6086       enddo
6087       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6088       return
6089       end
6090 #else
6091 c----------------------------------------------------------------------------------
6092       subroutine esc(escloc)
6093 C Calculate the local energy of a side chain and its derivatives in the
6094 C corresponding virtual-bond valence angles THETA and the spherical angles
6095 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6096 C added by Urszula Kozlowska. 07/11/2007
6097 C
6098       implicit real*8 (a-h,o-z)
6099       include 'DIMENSIONS'
6100       include 'COMMON.GEO'
6101       include 'COMMON.LOCAL'
6102       include 'COMMON.VAR'
6103       include 'COMMON.SCROT'
6104       include 'COMMON.INTERACT'
6105       include 'COMMON.DERIV'
6106       include 'COMMON.CHAIN'
6107       include 'COMMON.IOUNITS'
6108       include 'COMMON.NAMES'
6109       include 'COMMON.FFIELD'
6110       include 'COMMON.CONTROL'
6111       include 'COMMON.VECTORS'
6112       double precision x_prime(3),y_prime(3),z_prime(3)
6113      &    , sumene,dsc_i,dp2_i,x(65),
6114      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6115      &    de_dxx,de_dyy,de_dzz,de_dt
6116       double precision s1_t,s1_6_t,s2_t,s2_6_t
6117       double precision
6118      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6119      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6120      & dt_dCi(3),dt_dCi1(3)
6121       common /sccalc/ time11,time12,time112,theti,it,nlobit
6122       delta=0.02d0*pi
6123       escloc=0.0D0
6124       do i=loc_start,loc_end
6125         if (itype(i).eq.ntyp1) cycle
6126         costtab(i+1) =dcos(theta(i+1))
6127         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6128         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6129         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6130         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6131         cosfac=dsqrt(cosfac2)
6132         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6133         sinfac=dsqrt(sinfac2)
6134         it=iabs(itype(i))
6135         if (it.eq.10) goto 1
6136 c
6137 C  Compute the axes of tghe local cartesian coordinates system; store in
6138 c   x_prime, y_prime and z_prime
6139 c
6140         do j=1,3
6141           x_prime(j) = 0.00
6142           y_prime(j) = 0.00
6143           z_prime(j) = 0.00
6144         enddo
6145 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6146 C     &   dc_norm(3,i+nres)
6147         do j = 1,3
6148           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6149           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6150         enddo
6151         do j = 1,3
6152           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6153         enddo
6154 c       write (2,*) "i",i
6155 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6156 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6157 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6158 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6159 c      & " xy",scalar(x_prime(1),y_prime(1)),
6160 c      & " xz",scalar(x_prime(1),z_prime(1)),
6161 c      & " yy",scalar(y_prime(1),y_prime(1)),
6162 c      & " yz",scalar(y_prime(1),z_prime(1)),
6163 c      & " zz",scalar(z_prime(1),z_prime(1))
6164 c
6165 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6166 C to local coordinate system. Store in xx, yy, zz.
6167 c
6168         xx=0.0d0
6169         yy=0.0d0
6170         zz=0.0d0
6171         do j = 1,3
6172           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6173           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6174           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6175         enddo
6176
6177         xxtab(i)=xx
6178         yytab(i)=yy
6179         zztab(i)=zz
6180 C
6181 C Compute the energy of the ith side cbain
6182 C
6183 c        write (2,*) "xx",xx," yy",yy," zz",zz
6184         it=iabs(itype(i))
6185         do j = 1,65
6186           x(j) = sc_parmin(j,it)
6187         enddo
6188 #ifdef CHECK_COORD
6189 Cc diagnostics - remove later
6190         xx1 = dcos(alph(2))
6191         yy1 = dsin(alph(2))*dcos(omeg(2))
6192         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6193         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6194      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6195      &    xx1,yy1,zz1
6196 C,"  --- ", xx_w,yy_w,zz_w
6197 c end diagnostics
6198 #endif
6199         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6200      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6201      &   + x(10)*yy*zz
6202         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6203      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6204      & + x(20)*yy*zz
6205         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6206      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6207      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6208      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6209      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6210      &  +x(40)*xx*yy*zz
6211         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6212      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6213      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6214      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6215      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6216      &  +x(60)*xx*yy*zz
6217         dsc_i   = 0.743d0+x(61)
6218         dp2_i   = 1.9d0+x(62)
6219         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6220      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6221         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6222      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6223         s1=(1+x(63))/(0.1d0 + dscp1)
6224         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6225         s2=(1+x(65))/(0.1d0 + dscp2)
6226         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6227         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6228      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6229 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6230 c     &   sumene4,
6231 c     &   dscp1,dscp2,sumene
6232 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6233         escloc = escloc + sumene
6234 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6235 c     & ,zz,xx,yy
6236 c#define DEBUG
6237 #ifdef DEBUG
6238 C
6239 C This section to check the numerical derivatives of the energy of ith side
6240 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6241 C #define DEBUG in the code to turn it on.
6242 C
6243         write (2,*) "sumene               =",sumene
6244         aincr=1.0d-7
6245         xxsave=xx
6246         xx=xx+aincr
6247         write (2,*) xx,yy,zz
6248         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6249         de_dxx_num=(sumenep-sumene)/aincr
6250         xx=xxsave
6251         write (2,*) "xx+ sumene from enesc=",sumenep
6252         yysave=yy
6253         yy=yy+aincr
6254         write (2,*) xx,yy,zz
6255         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6256         de_dyy_num=(sumenep-sumene)/aincr
6257         yy=yysave
6258         write (2,*) "yy+ sumene from enesc=",sumenep
6259         zzsave=zz
6260         zz=zz+aincr
6261         write (2,*) xx,yy,zz
6262         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6263         de_dzz_num=(sumenep-sumene)/aincr
6264         zz=zzsave
6265         write (2,*) "zz+ sumene from enesc=",sumenep
6266         costsave=cost2tab(i+1)
6267         sintsave=sint2tab(i+1)
6268         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6269         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6270         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6271         de_dt_num=(sumenep-sumene)/aincr
6272         write (2,*) " t+ sumene from enesc=",sumenep
6273         cost2tab(i+1)=costsave
6274         sint2tab(i+1)=sintsave
6275 C End of diagnostics section.
6276 #endif
6277 C
6278 C Compute the gradient of esc
6279 C
6280 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6281         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6282         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6283         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6284         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6285         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6286         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6287         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6288         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6289         pom1=(sumene3*sint2tab(i+1)+sumene1)
6290      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6291         pom2=(sumene4*cost2tab(i+1)+sumene2)
6292      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6293         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6294         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6295      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6296      &  +x(40)*yy*zz
6297         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6298         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6299      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6300      &  +x(60)*yy*zz
6301         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6302      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6303      &        +(pom1+pom2)*pom_dx
6304 #ifdef DEBUG
6305         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6306 #endif
6307 C
6308         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6309         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6310      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6311      &  +x(40)*xx*zz
6312         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6313         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6314      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6315      &  +x(59)*zz**2 +x(60)*xx*zz
6316         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6317      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6318      &        +(pom1-pom2)*pom_dy
6319 #ifdef DEBUG
6320         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6321 #endif
6322 C
6323         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6324      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6325      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6326      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6327      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6328      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6329      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6330      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6331 #ifdef DEBUG
6332         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6333 #endif
6334 C
6335         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6336      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6337      &  +pom1*pom_dt1+pom2*pom_dt2
6338 #ifdef DEBUG
6339         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6340 #endif
6341 c#undef DEBUG
6342 c
6343 C
6344        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6345        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6346        cosfac2xx=cosfac2*xx
6347        sinfac2yy=sinfac2*yy
6348        do k = 1,3
6349          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6350      &      vbld_inv(i+1)
6351          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6352      &      vbld_inv(i)
6353          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6354          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6355 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6356 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6357 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6358 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6359          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6360          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6361          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6362          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6363          dZZ_Ci1(k)=0.0d0
6364          dZZ_Ci(k)=0.0d0
6365          do j=1,3
6366            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6367      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6368            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6369      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6370          enddo
6371
6372          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6373          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6374          dZZ_XYZ(k)=vbld_inv(i+nres)*
6375      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6376 c
6377          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6378          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6379        enddo
6380
6381        do k=1,3
6382          dXX_Ctab(k,i)=dXX_Ci(k)
6383          dXX_C1tab(k,i)=dXX_Ci1(k)
6384          dYY_Ctab(k,i)=dYY_Ci(k)
6385          dYY_C1tab(k,i)=dYY_Ci1(k)
6386          dZZ_Ctab(k,i)=dZZ_Ci(k)
6387          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6388          dXX_XYZtab(k,i)=dXX_XYZ(k)
6389          dYY_XYZtab(k,i)=dYY_XYZ(k)
6390          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6391        enddo
6392
6393        do k = 1,3
6394 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6395 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6396 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6397 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6398 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6399 c     &    dt_dci(k)
6400 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6401 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6402          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6403      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6404          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6405      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6406          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6407      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6408        enddo
6409 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6410 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6411
6412 C to check gradient call subroutine check_grad
6413
6414     1 continue
6415       enddo
6416       return
6417       end
6418 c------------------------------------------------------------------------------
6419       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6420       implicit none
6421       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6422      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6423       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6424      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6425      &   + x(10)*yy*zz
6426       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6427      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6428      & + x(20)*yy*zz
6429       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6430      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6431      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6432      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6433      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6434      &  +x(40)*xx*yy*zz
6435       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6436      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6437      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6438      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6439      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6440      &  +x(60)*xx*yy*zz
6441       dsc_i   = 0.743d0+x(61)
6442       dp2_i   = 1.9d0+x(62)
6443       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6444      &          *(xx*cost2+yy*sint2))
6445       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6446      &          *(xx*cost2-yy*sint2))
6447       s1=(1+x(63))/(0.1d0 + dscp1)
6448       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6449       s2=(1+x(65))/(0.1d0 + dscp2)
6450       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6451       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6452      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6453       enesc=sumene
6454       return
6455       end
6456 #endif
6457 c------------------------------------------------------------------------------
6458       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6459 C
6460 C This procedure calculates two-body contact function g(rij) and its derivative:
6461 C
6462 C           eps0ij                                     !       x < -1
6463 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6464 C            0                                         !       x > 1
6465 C
6466 C where x=(rij-r0ij)/delta
6467 C
6468 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6469 C
6470       implicit none
6471       double precision rij,r0ij,eps0ij,fcont,fprimcont
6472       double precision x,x2,x4,delta
6473 c     delta=0.02D0*r0ij
6474 c      delta=0.2D0*r0ij
6475       x=(rij-r0ij)/delta
6476       if (x.lt.-1.0D0) then
6477         fcont=eps0ij
6478         fprimcont=0.0D0
6479       else if (x.le.1.0D0) then
6480         x2=x*x
6481         x4=x2*x2
6482         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6483         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6484       else
6485         fcont=0.0D0
6486         fprimcont=0.0D0
6487       endif
6488       return
6489       end
6490 c------------------------------------------------------------------------------
6491       subroutine splinthet(theti,delta,ss,ssder)
6492       implicit real*8 (a-h,o-z)
6493       include 'DIMENSIONS'
6494       include 'COMMON.VAR'
6495       include 'COMMON.GEO'
6496       thetup=pi-delta
6497       thetlow=delta
6498       if (theti.gt.pipol) then
6499         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6500       else
6501         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6502         ssder=-ssder
6503       endif
6504       return
6505       end
6506 c------------------------------------------------------------------------------
6507       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6508       implicit none
6509       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6510       double precision ksi,ksi2,ksi3,a1,a2,a3
6511       a1=fprim0*delta/(f1-f0)
6512       a2=3.0d0-2.0d0*a1
6513       a3=a1-2.0d0
6514       ksi=(x-x0)/delta
6515       ksi2=ksi*ksi
6516       ksi3=ksi2*ksi
6517       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6518       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6519       return
6520       end
6521 c------------------------------------------------------------------------------
6522       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6523       implicit none
6524       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6525       double precision ksi,ksi2,ksi3,a1,a2,a3
6526       ksi=(x-x0)/delta
6527       ksi2=ksi*ksi
6528       ksi3=ksi2*ksi
6529       a1=fprim0x*delta
6530       a2=3*(f1x-f0x)-2*fprim0x*delta
6531       a3=fprim0x*delta-2*(f1x-f0x)
6532       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6533       return
6534       end
6535 C-----------------------------------------------------------------------------
6536 #ifdef CRYST_TOR
6537 C-----------------------------------------------------------------------------
6538       subroutine etor(etors,edihcnstr)
6539       implicit real*8 (a-h,o-z)
6540       include 'DIMENSIONS'
6541       include 'COMMON.VAR'
6542       include 'COMMON.GEO'
6543       include 'COMMON.LOCAL'
6544       include 'COMMON.TORSION'
6545       include 'COMMON.INTERACT'
6546       include 'COMMON.DERIV'
6547       include 'COMMON.CHAIN'
6548       include 'COMMON.NAMES'
6549       include 'COMMON.IOUNITS'
6550       include 'COMMON.FFIELD'
6551       include 'COMMON.TORCNSTR'
6552       include 'COMMON.CONTROL'
6553       logical lprn
6554 C Set lprn=.true. for debugging
6555       lprn=.false.
6556 c      lprn=.true.
6557       etors=0.0D0
6558       do i=iphi_start,iphi_end
6559       etors_ii=0.0D0
6560         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6561      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6562         itori=itortyp(itype(i-2))
6563         itori1=itortyp(itype(i-1))
6564         phii=phi(i)
6565         gloci=0.0D0
6566 C Proline-Proline pair is a special case...
6567         if (itori.eq.3 .and. itori1.eq.3) then
6568           if (phii.gt.-dwapi3) then
6569             cosphi=dcos(3*phii)
6570             fac=1.0D0/(1.0D0-cosphi)
6571             etorsi=v1(1,3,3)*fac
6572             etorsi=etorsi+etorsi
6573             etors=etors+etorsi-v1(1,3,3)
6574             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6575             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6576           endif
6577           do j=1,3
6578             v1ij=v1(j+1,itori,itori1)
6579             v2ij=v2(j+1,itori,itori1)
6580             cosphi=dcos(j*phii)
6581             sinphi=dsin(j*phii)
6582             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6583             if (energy_dec) etors_ii=etors_ii+
6584      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6585             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6586           enddo
6587         else
6588           do j=1,nterm_old
6589             v1ij=v1(j,itori,itori1)
6590             v2ij=v2(j,itori,itori1)
6591             cosphi=dcos(j*phii)
6592             sinphi=dsin(j*phii)
6593             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6594             if (energy_dec) etors_ii=etors_ii+
6595      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6596             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6597           enddo
6598         endif
6599         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6600              'etor',i,etors_ii
6601         if (lprn)
6602      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6603      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6604      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6605         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6606 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6607       enddo
6608 ! 6/20/98 - dihedral angle constraints
6609       edihcnstr=0.0d0
6610       do i=1,ndih_constr
6611         itori=idih_constr(i)
6612         phii=phi(itori)
6613         difi=phii-phi0(i)
6614         if (difi.gt.drange(i)) then
6615           difi=difi-drange(i)
6616           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6617           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6618         else if (difi.lt.-drange(i)) then
6619           difi=difi+drange(i)
6620           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6621           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6622         endif
6623 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6624 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6625       enddo
6626 !      write (iout,*) 'edihcnstr',edihcnstr
6627       return
6628       end
6629 c------------------------------------------------------------------------------
6630       subroutine etor_d(etors_d)
6631       etors_d=0.0d0
6632       return
6633       end
6634 c----------------------------------------------------------------------------
6635 #else
6636       subroutine etor(etors,edihcnstr)
6637       implicit real*8 (a-h,o-z)
6638       include 'DIMENSIONS'
6639       include 'COMMON.VAR'
6640       include 'COMMON.GEO'
6641       include 'COMMON.LOCAL'
6642       include 'COMMON.TORSION'
6643       include 'COMMON.INTERACT'
6644       include 'COMMON.DERIV'
6645       include 'COMMON.CHAIN'
6646       include 'COMMON.NAMES'
6647       include 'COMMON.IOUNITS'
6648       include 'COMMON.FFIELD'
6649       include 'COMMON.TORCNSTR'
6650       include 'COMMON.CONTROL'
6651       logical lprn
6652 C Set lprn=.true. for debugging
6653       lprn=.false.
6654 c     lprn=.true.
6655       etors=0.0D0
6656       do i=iphi_start,iphi_end
6657 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6658 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6659 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6660 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6661         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6662      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6663 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6664 C For introducing the NH3+ and COO- group please check the etor_d for reference
6665 C and guidance
6666         etors_ii=0.0D0
6667          if (iabs(itype(i)).eq.20) then
6668          iblock=2
6669          else
6670          iblock=1
6671          endif
6672         itori=itortyp(itype(i-2))
6673         itori1=itortyp(itype(i-1))
6674         phii=phi(i)
6675         gloci=0.0D0
6676 C Regular cosine and sine terms
6677         do j=1,nterm(itori,itori1,iblock)
6678           v1ij=v1(j,itori,itori1,iblock)
6679           v2ij=v2(j,itori,itori1,iblock)
6680           cosphi=dcos(j*phii)
6681           sinphi=dsin(j*phii)
6682           etors=etors+v1ij*cosphi+v2ij*sinphi
6683           if (energy_dec) etors_ii=etors_ii+
6684      &                v1ij*cosphi+v2ij*sinphi
6685           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6686         enddo
6687 C Lorentz terms
6688 C                         v1
6689 C  E = SUM ----------------------------------- - v1
6690 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6691 C
6692         cosphi=dcos(0.5d0*phii)
6693         sinphi=dsin(0.5d0*phii)
6694         do j=1,nlor(itori,itori1,iblock)
6695           vl1ij=vlor1(j,itori,itori1)
6696           vl2ij=vlor2(j,itori,itori1)
6697           vl3ij=vlor3(j,itori,itori1)
6698           pom=vl2ij*cosphi+vl3ij*sinphi
6699           pom1=1.0d0/(pom*pom+1.0d0)
6700           etors=etors+vl1ij*pom1
6701           if (energy_dec) etors_ii=etors_ii+
6702      &                vl1ij*pom1
6703           pom=-pom*pom1*pom1
6704           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6705         enddo
6706 C Subtract the constant term
6707         etors=etors-v0(itori,itori1,iblock)
6708           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6709      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6710         if (lprn)
6711      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6712      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6713      &  (v1(j,itori,itori1,iblock),j=1,6),
6714      &  (v2(j,itori,itori1,iblock),j=1,6)
6715         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6716 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6717       enddo
6718 ! 6/20/98 - dihedral angle constraints
6719       edihcnstr=0.0d0
6720 c      do i=1,ndih_constr
6721       do i=idihconstr_start,idihconstr_end
6722         itori=idih_constr(i)
6723         phii=phi(itori)
6724         difi=pinorm(phii-phi0(i))
6725         if (difi.gt.drange(i)) then
6726           difi=difi-drange(i)
6727           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6728           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6729         else if (difi.lt.-drange(i)) then
6730           difi=difi+drange(i)
6731           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6732           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6733         else
6734           difi=0.0
6735         endif
6736 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6737 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6738 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6739       enddo
6740 cd       write (iout,*) 'edihcnstr',edihcnstr
6741       return
6742       end
6743 c----------------------------------------------------------------------------
6744       subroutine etor_d(etors_d)
6745 C 6/23/01 Compute double torsional energy
6746       implicit real*8 (a-h,o-z)
6747       include 'DIMENSIONS'
6748       include 'COMMON.VAR'
6749       include 'COMMON.GEO'
6750       include 'COMMON.LOCAL'
6751       include 'COMMON.TORSION'
6752       include 'COMMON.INTERACT'
6753       include 'COMMON.DERIV'
6754       include 'COMMON.CHAIN'
6755       include 'COMMON.NAMES'
6756       include 'COMMON.IOUNITS'
6757       include 'COMMON.FFIELD'
6758       include 'COMMON.TORCNSTR'
6759       logical lprn
6760 C Set lprn=.true. for debugging
6761       lprn=.false.
6762 c     lprn=.true.
6763       etors_d=0.0D0
6764 c      write(iout,*) "a tu??"
6765       do i=iphid_start,iphid_end
6766 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6767 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6768 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6769 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6770 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6771          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6772      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6773      &  (itype(i+1).eq.ntyp1)) cycle
6774 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6775         itori=itortyp(itype(i-2))
6776         itori1=itortyp(itype(i-1))
6777         itori2=itortyp(itype(i))
6778         phii=phi(i)
6779         phii1=phi(i+1)
6780         gloci1=0.0D0
6781         gloci2=0.0D0
6782         iblock=1
6783         if (iabs(itype(i+1)).eq.20) iblock=2
6784 C Iblock=2 Proline type
6785 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6786 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6787 C        if (itype(i+1).eq.ntyp1) iblock=3
6788 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6789 C IS or IS NOT need for this
6790 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6791 C        is (itype(i-3).eq.ntyp1) ntblock=2
6792 C        ntblock is N-terminal blocking group
6793
6794 C Regular cosine and sine terms
6795         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6796 C Example of changes for NH3+ blocking group
6797 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6798 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6799           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6800           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6801           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6802           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6803           cosphi1=dcos(j*phii)
6804           sinphi1=dsin(j*phii)
6805           cosphi2=dcos(j*phii1)
6806           sinphi2=dsin(j*phii1)
6807           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6808      &     v2cij*cosphi2+v2sij*sinphi2
6809           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6810           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6811         enddo
6812         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6813           do l=1,k-1
6814             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6815             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6816             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6817             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6818             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6819             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6820             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6821             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6822             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6823      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6824             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6825      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6826             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6827      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6828           enddo
6829         enddo
6830         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6831         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6832       enddo
6833       return
6834       end
6835 #endif
6836 c------------------------------------------------------------------------------
6837       subroutine eback_sc_corr(esccor)
6838 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6839 c        conformational states; temporarily implemented as differences
6840 c        between UNRES torsional potentials (dependent on three types of
6841 c        residues) and the torsional potentials dependent on all 20 types
6842 c        of residues computed from AM1  energy surfaces of terminally-blocked
6843 c        amino-acid residues.
6844       implicit real*8 (a-h,o-z)
6845       include 'DIMENSIONS'
6846       include 'COMMON.VAR'
6847       include 'COMMON.GEO'
6848       include 'COMMON.LOCAL'
6849       include 'COMMON.TORSION'
6850       include 'COMMON.SCCOR'
6851       include 'COMMON.INTERACT'
6852       include 'COMMON.DERIV'
6853       include 'COMMON.CHAIN'
6854       include 'COMMON.NAMES'
6855       include 'COMMON.IOUNITS'
6856       include 'COMMON.FFIELD'
6857       include 'COMMON.CONTROL'
6858       logical lprn
6859 C Set lprn=.true. for debugging
6860       lprn=.false.
6861 c      lprn=.true.
6862 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6863       esccor=0.0D0
6864       do i=itau_start,itau_end
6865         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6866         esccor_ii=0.0D0
6867         isccori=isccortyp(itype(i-2))
6868         isccori1=isccortyp(itype(i-1))
6869 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6870         phii=phi(i)
6871         do intertyp=1,3 !intertyp
6872 cc Added 09 May 2012 (Adasko)
6873 cc  Intertyp means interaction type of backbone mainchain correlation:
6874 c   1 = SC...Ca...Ca...Ca
6875 c   2 = Ca...Ca...Ca...SC
6876 c   3 = SC...Ca...Ca...SCi
6877         gloci=0.0D0
6878         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6879      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6880      &      (itype(i-1).eq.ntyp1)))
6881      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6882      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6883      &     .or.(itype(i).eq.ntyp1)))
6884      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6885      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6886      &      (itype(i-3).eq.ntyp1)))) cycle
6887         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6888         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6889      & cycle
6890        do j=1,nterm_sccor(isccori,isccori1)
6891           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6892           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6893           cosphi=dcos(j*tauangle(intertyp,i))
6894           sinphi=dsin(j*tauangle(intertyp,i))
6895           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6896           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6897         enddo
6898 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6899         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6900         if (lprn)
6901      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6902      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6903      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6904      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6905         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6906        enddo !intertyp
6907       enddo
6908
6909       return
6910       end
6911 c----------------------------------------------------------------------------
6912       subroutine multibody(ecorr)
6913 C This subroutine calculates multi-body contributions to energy following
6914 C the idea of Skolnick et al. If side chains I and J make a contact and
6915 C at the same time side chains I+1 and J+1 make a contact, an extra
6916 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6917       implicit real*8 (a-h,o-z)
6918       include 'DIMENSIONS'
6919       include 'COMMON.IOUNITS'
6920       include 'COMMON.DERIV'
6921       include 'COMMON.INTERACT'
6922       include 'COMMON.CONTACTS'
6923       double precision gx(3),gx1(3)
6924       logical lprn
6925
6926 C Set lprn=.true. for debugging
6927       lprn=.false.
6928
6929       if (lprn) then
6930         write (iout,'(a)') 'Contact function values:'
6931         do i=nnt,nct-2
6932           write (iout,'(i2,20(1x,i2,f10.5))')
6933      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6934         enddo
6935       endif
6936       ecorr=0.0D0
6937       do i=nnt,nct
6938         do j=1,3
6939           gradcorr(j,i)=0.0D0
6940           gradxorr(j,i)=0.0D0
6941         enddo
6942       enddo
6943       do i=nnt,nct-2
6944
6945         DO ISHIFT = 3,4
6946
6947         i1=i+ishift
6948         num_conti=num_cont(i)
6949         num_conti1=num_cont(i1)
6950         do jj=1,num_conti
6951           j=jcont(jj,i)
6952           do kk=1,num_conti1
6953             j1=jcont(kk,i1)
6954             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6955 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6956 cd   &                   ' ishift=',ishift
6957 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6958 C The system gains extra energy.
6959               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6960             endif   ! j1==j+-ishift
6961           enddo     ! kk
6962         enddo       ! jj
6963
6964         ENDDO ! ISHIFT
6965
6966       enddo         ! i
6967       return
6968       end
6969 c------------------------------------------------------------------------------
6970       double precision function esccorr(i,j,k,l,jj,kk)
6971       implicit real*8 (a-h,o-z)
6972       include 'DIMENSIONS'
6973       include 'COMMON.IOUNITS'
6974       include 'COMMON.DERIV'
6975       include 'COMMON.INTERACT'
6976       include 'COMMON.CONTACTS'
6977       double precision gx(3),gx1(3)
6978       logical lprn
6979       lprn=.false.
6980       eij=facont(jj,i)
6981       ekl=facont(kk,k)
6982 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6983 C Calculate the multi-body contribution to energy.
6984 C Calculate multi-body contributions to the gradient.
6985 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6986 cd   & k,l,(gacont(m,kk,k),m=1,3)
6987       do m=1,3
6988         gx(m) =ekl*gacont(m,jj,i)
6989         gx1(m)=eij*gacont(m,kk,k)
6990         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6991         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6992         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6993         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6994       enddo
6995       do m=i,j-1
6996         do ll=1,3
6997           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6998         enddo
6999       enddo
7000       do m=k,l-1
7001         do ll=1,3
7002           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7003         enddo
7004       enddo
7005       esccorr=-eij*ekl
7006       return
7007       end
7008 c------------------------------------------------------------------------------
7009       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7010 C This subroutine calculates multi-body contributions to hydrogen-bonding
7011       implicit real*8 (a-h,o-z)
7012       include 'DIMENSIONS'
7013       include 'COMMON.IOUNITS'
7014 #ifdef MPI
7015       include "mpif.h"
7016       parameter (max_cont=maxconts)
7017       parameter (max_dim=26)
7018       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7019       double precision zapas(max_dim,maxconts,max_fg_procs),
7020      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7021       common /przechowalnia/ zapas
7022       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7023      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7024 #endif
7025       include 'COMMON.SETUP'
7026       include 'COMMON.FFIELD'
7027       include 'COMMON.DERIV'
7028       include 'COMMON.INTERACT'
7029       include 'COMMON.CONTACTS'
7030       include 'COMMON.CONTROL'
7031       include 'COMMON.LOCAL'
7032       double precision gx(3),gx1(3),time00
7033       logical lprn,ldone
7034
7035 C Set lprn=.true. for debugging
7036       lprn=.false.
7037 #ifdef MPI
7038       n_corr=0
7039       n_corr1=0
7040       if (nfgtasks.le.1) goto 30
7041       if (lprn) then
7042         write (iout,'(a)') 'Contact function values before RECEIVE:'
7043         do i=nnt,nct-2
7044           write (iout,'(2i3,50(1x,i2,f5.2))')
7045      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7046      &    j=1,num_cont_hb(i))
7047         enddo
7048       endif
7049       call flush(iout)
7050       do i=1,ntask_cont_from
7051         ncont_recv(i)=0
7052       enddo
7053       do i=1,ntask_cont_to
7054         ncont_sent(i)=0
7055       enddo
7056 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7057 c     & ntask_cont_to
7058 C Make the list of contacts to send to send to other procesors
7059 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7060 c      call flush(iout)
7061       do i=iturn3_start,iturn3_end
7062 c        write (iout,*) "make contact list turn3",i," num_cont",
7063 c     &    num_cont_hb(i)
7064         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7065       enddo
7066       do i=iturn4_start,iturn4_end
7067 c        write (iout,*) "make contact list turn4",i," num_cont",
7068 c     &   num_cont_hb(i)
7069         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7070       enddo
7071       do ii=1,nat_sent
7072         i=iat_sent(ii)
7073 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7074 c     &    num_cont_hb(i)
7075         do j=1,num_cont_hb(i)
7076         do k=1,4
7077           jjc=jcont_hb(j,i)
7078           iproc=iint_sent_local(k,jjc,ii)
7079 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7080           if (iproc.gt.0) then
7081             ncont_sent(iproc)=ncont_sent(iproc)+1
7082             nn=ncont_sent(iproc)
7083             zapas(1,nn,iproc)=i
7084             zapas(2,nn,iproc)=jjc
7085             zapas(3,nn,iproc)=facont_hb(j,i)
7086             zapas(4,nn,iproc)=ees0p(j,i)
7087             zapas(5,nn,iproc)=ees0m(j,i)
7088             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7089             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7090             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7091             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7092             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7093             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7094             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7095             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7096             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7097             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7098             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7099             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7100             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7101             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7102             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7103             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7104             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7105             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7106             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7107             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7108             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7109           endif
7110         enddo
7111         enddo
7112       enddo
7113       if (lprn) then
7114       write (iout,*)
7115      &  "Numbers of contacts to be sent to other processors",
7116      &  (ncont_sent(i),i=1,ntask_cont_to)
7117       write (iout,*) "Contacts sent"
7118       do ii=1,ntask_cont_to
7119         nn=ncont_sent(ii)
7120         iproc=itask_cont_to(ii)
7121         write (iout,*) nn," contacts to processor",iproc,
7122      &   " of CONT_TO_COMM group"
7123         do i=1,nn
7124           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7125         enddo
7126       enddo
7127       call flush(iout)
7128       endif
7129       CorrelType=477
7130       CorrelID=fg_rank+1
7131       CorrelType1=478
7132       CorrelID1=nfgtasks+fg_rank+1
7133       ireq=0
7134 C Receive the numbers of needed contacts from other processors
7135       do ii=1,ntask_cont_from
7136         iproc=itask_cont_from(ii)
7137         ireq=ireq+1
7138         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7139      &    FG_COMM,req(ireq),IERR)
7140       enddo
7141 c      write (iout,*) "IRECV ended"
7142 c      call flush(iout)
7143 C Send the number of contacts needed by other processors
7144       do ii=1,ntask_cont_to
7145         iproc=itask_cont_to(ii)
7146         ireq=ireq+1
7147         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7148      &    FG_COMM,req(ireq),IERR)
7149       enddo
7150 c      write (iout,*) "ISEND ended"
7151 c      write (iout,*) "number of requests (nn)",ireq
7152       call flush(iout)
7153       if (ireq.gt.0)
7154      &  call MPI_Waitall(ireq,req,status_array,ierr)
7155 c      write (iout,*)
7156 c     &  "Numbers of contacts to be received from other processors",
7157 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7158 c      call flush(iout)
7159 C Receive contacts
7160       ireq=0
7161       do ii=1,ntask_cont_from
7162         iproc=itask_cont_from(ii)
7163         nn=ncont_recv(ii)
7164 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7165 c     &   " of CONT_TO_COMM group"
7166         call flush(iout)
7167         if (nn.gt.0) then
7168           ireq=ireq+1
7169           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7170      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7171 c          write (iout,*) "ireq,req",ireq,req(ireq)
7172         endif
7173       enddo
7174 C Send the contacts to processors that need them
7175       do ii=1,ntask_cont_to
7176         iproc=itask_cont_to(ii)
7177         nn=ncont_sent(ii)
7178 c        write (iout,*) nn," contacts to processor",iproc,
7179 c     &   " of CONT_TO_COMM group"
7180         if (nn.gt.0) then
7181           ireq=ireq+1
7182           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7183      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7184 c          write (iout,*) "ireq,req",ireq,req(ireq)
7185 c          do i=1,nn
7186 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7187 c          enddo
7188         endif
7189       enddo
7190 c      write (iout,*) "number of requests (contacts)",ireq
7191 c      write (iout,*) "req",(req(i),i=1,4)
7192 c      call flush(iout)
7193       if (ireq.gt.0)
7194      & call MPI_Waitall(ireq,req,status_array,ierr)
7195       do iii=1,ntask_cont_from
7196         iproc=itask_cont_from(iii)
7197         nn=ncont_recv(iii)
7198         if (lprn) then
7199         write (iout,*) "Received",nn," contacts from processor",iproc,
7200      &   " of CONT_FROM_COMM group"
7201         call flush(iout)
7202         do i=1,nn
7203           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7204         enddo
7205         call flush(iout)
7206         endif
7207         do i=1,nn
7208           ii=zapas_recv(1,i,iii)
7209 c Flag the received contacts to prevent double-counting
7210           jj=-zapas_recv(2,i,iii)
7211 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7212 c          call flush(iout)
7213           nnn=num_cont_hb(ii)+1
7214           num_cont_hb(ii)=nnn
7215           jcont_hb(nnn,ii)=jj
7216           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7217           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7218           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7219           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7220           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7221           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7222           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7223           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7224           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7225           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7226           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7227           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7228           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7229           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7230           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7231           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7232           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7233           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7234           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7235           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7236           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7237           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7238           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7239           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7240         enddo
7241       enddo
7242       call flush(iout)
7243       if (lprn) then
7244         write (iout,'(a)') 'Contact function values after receive:'
7245         do i=nnt,nct-2
7246           write (iout,'(2i3,50(1x,i3,f5.2))')
7247      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7248      &    j=1,num_cont_hb(i))
7249         enddo
7250         call flush(iout)
7251       endif
7252    30 continue
7253 #endif
7254       if (lprn) then
7255         write (iout,'(a)') 'Contact function values:'
7256         do i=nnt,nct-2
7257           write (iout,'(2i3,50(1x,i3,f5.2))')
7258      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7259      &    j=1,num_cont_hb(i))
7260         enddo
7261       endif
7262       ecorr=0.0D0
7263 C Remove the loop below after debugging !!!
7264       do i=nnt,nct
7265         do j=1,3
7266           gradcorr(j,i)=0.0D0
7267           gradxorr(j,i)=0.0D0
7268         enddo
7269       enddo
7270 C Calculate the local-electrostatic correlation terms
7271       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7272         i1=i+1
7273         num_conti=num_cont_hb(i)
7274         num_conti1=num_cont_hb(i+1)
7275         do jj=1,num_conti
7276           j=jcont_hb(jj,i)
7277           jp=iabs(j)
7278           do kk=1,num_conti1
7279             j1=jcont_hb(kk,i1)
7280             jp1=iabs(j1)
7281 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7282 c     &         ' jj=',jj,' kk=',kk
7283             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7284      &          .or. j.lt.0 .and. j1.gt.0) .and.
7285      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7286 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7287 C The system gains extra energy.
7288               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7289               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7290      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7291               n_corr=n_corr+1
7292             else if (j1.eq.j) then
7293 C Contacts I-J and I-(J+1) occur simultaneously.
7294 C The system loses extra energy.
7295 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7296             endif
7297           enddo ! kk
7298           do kk=1,num_conti
7299             j1=jcont_hb(kk,i)
7300 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7301 c    &         ' jj=',jj,' kk=',kk
7302             if (j1.eq.j+1) then
7303 C Contacts I-J and (I+1)-J occur simultaneously.
7304 C The system loses extra energy.
7305 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7306             endif ! j1==j+1
7307           enddo ! kk
7308         enddo ! jj
7309       enddo ! i
7310       return
7311       end
7312 c------------------------------------------------------------------------------
7313       subroutine add_hb_contact(ii,jj,itask)
7314       implicit real*8 (a-h,o-z)
7315       include "DIMENSIONS"
7316       include "COMMON.IOUNITS"
7317       integer max_cont
7318       integer max_dim
7319       parameter (max_cont=maxconts)
7320       parameter (max_dim=26)
7321       include "COMMON.CONTACTS"
7322       double precision zapas(max_dim,maxconts,max_fg_procs),
7323      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7324       common /przechowalnia/ zapas
7325       integer i,j,ii,jj,iproc,itask(4),nn
7326 c      write (iout,*) "itask",itask
7327       do i=1,2
7328         iproc=itask(i)
7329         if (iproc.gt.0) then
7330           do j=1,num_cont_hb(ii)
7331             jjc=jcont_hb(j,ii)
7332 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7333             if (jjc.eq.jj) then
7334               ncont_sent(iproc)=ncont_sent(iproc)+1
7335               nn=ncont_sent(iproc)
7336               zapas(1,nn,iproc)=ii
7337               zapas(2,nn,iproc)=jjc
7338               zapas(3,nn,iproc)=facont_hb(j,ii)
7339               zapas(4,nn,iproc)=ees0p(j,ii)
7340               zapas(5,nn,iproc)=ees0m(j,ii)
7341               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7342               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7343               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7344               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7345               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7346               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7347               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7348               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7349               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7350               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7351               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7352               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7353               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7354               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7355               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7356               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7357               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7358               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7359               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7360               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7361               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7362               exit
7363             endif
7364           enddo
7365         endif
7366       enddo
7367       return
7368       end
7369 c------------------------------------------------------------------------------
7370       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7371      &  n_corr1)
7372 C This subroutine calculates multi-body contributions to hydrogen-bonding
7373       implicit real*8 (a-h,o-z)
7374       include 'DIMENSIONS'
7375       include 'COMMON.IOUNITS'
7376 #ifdef MPI
7377       include "mpif.h"
7378       parameter (max_cont=maxconts)
7379       parameter (max_dim=70)
7380       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7381       double precision zapas(max_dim,maxconts,max_fg_procs),
7382      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7383       common /przechowalnia/ zapas
7384       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7385      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7386 #endif
7387       include 'COMMON.SETUP'
7388       include 'COMMON.FFIELD'
7389       include 'COMMON.DERIV'
7390       include 'COMMON.LOCAL'
7391       include 'COMMON.INTERACT'
7392       include 'COMMON.CONTACTS'
7393       include 'COMMON.CHAIN'
7394       include 'COMMON.CONTROL'
7395       double precision gx(3),gx1(3)
7396       integer num_cont_hb_old(maxres)
7397       logical lprn,ldone
7398       double precision eello4,eello5,eelo6,eello_turn6
7399       external eello4,eello5,eello6,eello_turn6
7400 C Set lprn=.true. for debugging
7401       lprn=.false.
7402       eturn6=0.0d0
7403 #ifdef MPI
7404       do i=1,nres
7405         num_cont_hb_old(i)=num_cont_hb(i)
7406       enddo
7407       n_corr=0
7408       n_corr1=0
7409       if (nfgtasks.le.1) goto 30
7410       if (lprn) then
7411         write (iout,'(a)') 'Contact function values before RECEIVE:'
7412         do i=nnt,nct-2
7413           write (iout,'(2i3,50(1x,i2,f5.2))')
7414      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7415      &    j=1,num_cont_hb(i))
7416         enddo
7417       endif
7418       call flush(iout)
7419       do i=1,ntask_cont_from
7420         ncont_recv(i)=0
7421       enddo
7422       do i=1,ntask_cont_to
7423         ncont_sent(i)=0
7424       enddo
7425 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7426 c     & ntask_cont_to
7427 C Make the list of contacts to send to send to other procesors
7428       do i=iturn3_start,iturn3_end
7429 c        write (iout,*) "make contact list turn3",i," num_cont",
7430 c     &    num_cont_hb(i)
7431         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7432       enddo
7433       do i=iturn4_start,iturn4_end
7434 c        write (iout,*) "make contact list turn4",i," num_cont",
7435 c     &   num_cont_hb(i)
7436         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7437       enddo
7438       do ii=1,nat_sent
7439         i=iat_sent(ii)
7440 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7441 c     &    num_cont_hb(i)
7442         do j=1,num_cont_hb(i)
7443         do k=1,4
7444           jjc=jcont_hb(j,i)
7445           iproc=iint_sent_local(k,jjc,ii)
7446 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7447           if (iproc.ne.0) then
7448             ncont_sent(iproc)=ncont_sent(iproc)+1
7449             nn=ncont_sent(iproc)
7450             zapas(1,nn,iproc)=i
7451             zapas(2,nn,iproc)=jjc
7452             zapas(3,nn,iproc)=d_cont(j,i)
7453             ind=3
7454             do kk=1,3
7455               ind=ind+1
7456               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7457             enddo
7458             do kk=1,2
7459               do ll=1,2
7460                 ind=ind+1
7461                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7462               enddo
7463             enddo
7464             do jj=1,5
7465               do kk=1,3
7466                 do ll=1,2
7467                   do mm=1,2
7468                     ind=ind+1
7469                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7470                   enddo
7471                 enddo
7472               enddo
7473             enddo
7474           endif
7475         enddo
7476         enddo
7477       enddo
7478       if (lprn) then
7479       write (iout,*)
7480      &  "Numbers of contacts to be sent to other processors",
7481      &  (ncont_sent(i),i=1,ntask_cont_to)
7482       write (iout,*) "Contacts sent"
7483       do ii=1,ntask_cont_to
7484         nn=ncont_sent(ii)
7485         iproc=itask_cont_to(ii)
7486         write (iout,*) nn," contacts to processor",iproc,
7487      &   " of CONT_TO_COMM group"
7488         do i=1,nn
7489           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7490         enddo
7491       enddo
7492       call flush(iout)
7493       endif
7494       CorrelType=477
7495       CorrelID=fg_rank+1
7496       CorrelType1=478
7497       CorrelID1=nfgtasks+fg_rank+1
7498       ireq=0
7499 C Receive the numbers of needed contacts from other processors
7500       do ii=1,ntask_cont_from
7501         iproc=itask_cont_from(ii)
7502         ireq=ireq+1
7503         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7504      &    FG_COMM,req(ireq),IERR)
7505       enddo
7506 c      write (iout,*) "IRECV ended"
7507 c      call flush(iout)
7508 C Send the number of contacts needed by other processors
7509       do ii=1,ntask_cont_to
7510         iproc=itask_cont_to(ii)
7511         ireq=ireq+1
7512         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7513      &    FG_COMM,req(ireq),IERR)
7514       enddo
7515 c      write (iout,*) "ISEND ended"
7516 c      write (iout,*) "number of requests (nn)",ireq
7517       call flush(iout)
7518       if (ireq.gt.0)
7519      &  call MPI_Waitall(ireq,req,status_array,ierr)
7520 c      write (iout,*)
7521 c     &  "Numbers of contacts to be received from other processors",
7522 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7523 c      call flush(iout)
7524 C Receive contacts
7525       ireq=0
7526       do ii=1,ntask_cont_from
7527         iproc=itask_cont_from(ii)
7528         nn=ncont_recv(ii)
7529 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7530 c     &   " of CONT_TO_COMM group"
7531         call flush(iout)
7532         if (nn.gt.0) then
7533           ireq=ireq+1
7534           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7535      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7536 c          write (iout,*) "ireq,req",ireq,req(ireq)
7537         endif
7538       enddo
7539 C Send the contacts to processors that need them
7540       do ii=1,ntask_cont_to
7541         iproc=itask_cont_to(ii)
7542         nn=ncont_sent(ii)
7543 c        write (iout,*) nn," contacts to processor",iproc,
7544 c     &   " of CONT_TO_COMM group"
7545         if (nn.gt.0) then
7546           ireq=ireq+1
7547           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7548      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7549 c          write (iout,*) "ireq,req",ireq,req(ireq)
7550 c          do i=1,nn
7551 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7552 c          enddo
7553         endif
7554       enddo
7555 c      write (iout,*) "number of requests (contacts)",ireq
7556 c      write (iout,*) "req",(req(i),i=1,4)
7557 c      call flush(iout)
7558       if (ireq.gt.0)
7559      & call MPI_Waitall(ireq,req,status_array,ierr)
7560       do iii=1,ntask_cont_from
7561         iproc=itask_cont_from(iii)
7562         nn=ncont_recv(iii)
7563         if (lprn) then
7564         write (iout,*) "Received",nn," contacts from processor",iproc,
7565      &   " of CONT_FROM_COMM group"
7566         call flush(iout)
7567         do i=1,nn
7568           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7569         enddo
7570         call flush(iout)
7571         endif
7572         do i=1,nn
7573           ii=zapas_recv(1,i,iii)
7574 c Flag the received contacts to prevent double-counting
7575           jj=-zapas_recv(2,i,iii)
7576 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7577 c          call flush(iout)
7578           nnn=num_cont_hb(ii)+1
7579           num_cont_hb(ii)=nnn
7580           jcont_hb(nnn,ii)=jj
7581           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7582           ind=3
7583           do kk=1,3
7584             ind=ind+1
7585             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7586           enddo
7587           do kk=1,2
7588             do ll=1,2
7589               ind=ind+1
7590               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7591             enddo
7592           enddo
7593           do jj=1,5
7594             do kk=1,3
7595               do ll=1,2
7596                 do mm=1,2
7597                   ind=ind+1
7598                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7599                 enddo
7600               enddo
7601             enddo
7602           enddo
7603         enddo
7604       enddo
7605       call flush(iout)
7606       if (lprn) then
7607         write (iout,'(a)') 'Contact function values after receive:'
7608         do i=nnt,nct-2
7609           write (iout,'(2i3,50(1x,i3,5f6.3))')
7610      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7611      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7612         enddo
7613         call flush(iout)
7614       endif
7615    30 continue
7616 #endif
7617       if (lprn) then
7618         write (iout,'(a)') 'Contact function values:'
7619         do i=nnt,nct-2
7620           write (iout,'(2i3,50(1x,i2,5f6.3))')
7621      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7622      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7623         enddo
7624       endif
7625       ecorr=0.0D0
7626       ecorr5=0.0d0
7627       ecorr6=0.0d0
7628 C Remove the loop below after debugging !!!
7629       do i=nnt,nct
7630         do j=1,3
7631           gradcorr(j,i)=0.0D0
7632           gradxorr(j,i)=0.0D0
7633         enddo
7634       enddo
7635 C Calculate the dipole-dipole interaction energies
7636       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7637       do i=iatel_s,iatel_e+1
7638         num_conti=num_cont_hb(i)
7639         do jj=1,num_conti
7640           j=jcont_hb(jj,i)
7641 #ifdef MOMENT
7642           call dipole(i,j,jj)
7643 #endif
7644         enddo
7645       enddo
7646       endif
7647 C Calculate the local-electrostatic correlation terms
7648 c                write (iout,*) "gradcorr5 in eello5 before loop"
7649 c                do iii=1,nres
7650 c                  write (iout,'(i5,3f10.5)')
7651 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7652 c                enddo
7653       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7654 c        write (iout,*) "corr loop i",i
7655         i1=i+1
7656         num_conti=num_cont_hb(i)
7657         num_conti1=num_cont_hb(i+1)
7658         do jj=1,num_conti
7659           j=jcont_hb(jj,i)
7660           jp=iabs(j)
7661           do kk=1,num_conti1
7662             j1=jcont_hb(kk,i1)
7663             jp1=iabs(j1)
7664 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7665 c     &         ' jj=',jj,' kk=',kk
7666 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7667             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7668      &          .or. j.lt.0 .and. j1.gt.0) .and.
7669      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7670 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7671 C The system gains extra energy.
7672               n_corr=n_corr+1
7673               sqd1=dsqrt(d_cont(jj,i))
7674               sqd2=dsqrt(d_cont(kk,i1))
7675               sred_geom = sqd1*sqd2
7676               IF (sred_geom.lt.cutoff_corr) THEN
7677                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7678      &            ekont,fprimcont)
7679 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7680 cd     &         ' jj=',jj,' kk=',kk
7681                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7682                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7683                 do l=1,3
7684                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7685                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7686                 enddo
7687                 n_corr1=n_corr1+1
7688 cd               write (iout,*) 'sred_geom=',sred_geom,
7689 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7690 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7691 cd               write (iout,*) "g_contij",g_contij
7692 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7693 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7694                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7695                 if (wcorr4.gt.0.0d0)
7696      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7697                   if (energy_dec.and.wcorr4.gt.0.0d0)
7698      1                 write (iout,'(a6,4i5,0pf7.3)')
7699      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7700 c                write (iout,*) "gradcorr5 before eello5"
7701 c                do iii=1,nres
7702 c                  write (iout,'(i5,3f10.5)')
7703 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7704 c                enddo
7705                 if (wcorr5.gt.0.0d0)
7706      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7707 c                write (iout,*) "gradcorr5 after eello5"
7708 c                do iii=1,nres
7709 c                  write (iout,'(i5,3f10.5)')
7710 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7711 c                enddo
7712                   if (energy_dec.and.wcorr5.gt.0.0d0)
7713      1                 write (iout,'(a6,4i5,0pf7.3)')
7714      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7715 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7716 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7717                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7718      &               .or. wturn6.eq.0.0d0))then
7719 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7720                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7721                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7722      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7723 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7724 cd     &            'ecorr6=',ecorr6
7725 cd                write (iout,'(4e15.5)') sred_geom,
7726 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7727 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7728 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7729                 else if (wturn6.gt.0.0d0
7730      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7731 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7732                   eturn6=eturn6+eello_turn6(i,jj,kk)
7733                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7734      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7735 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7736                 endif
7737               ENDIF
7738 1111          continue
7739             endif
7740           enddo ! kk
7741         enddo ! jj
7742       enddo ! i
7743       do i=1,nres
7744         num_cont_hb(i)=num_cont_hb_old(i)
7745       enddo
7746 c                write (iout,*) "gradcorr5 in eello5"
7747 c                do iii=1,nres
7748 c                  write (iout,'(i5,3f10.5)')
7749 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7750 c                enddo
7751       return
7752       end
7753 c------------------------------------------------------------------------------
7754       subroutine add_hb_contact_eello(ii,jj,itask)
7755       implicit real*8 (a-h,o-z)
7756       include "DIMENSIONS"
7757       include "COMMON.IOUNITS"
7758       integer max_cont
7759       integer max_dim
7760       parameter (max_cont=maxconts)
7761       parameter (max_dim=70)
7762       include "COMMON.CONTACTS"
7763       double precision zapas(max_dim,maxconts,max_fg_procs),
7764      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7765       common /przechowalnia/ zapas
7766       integer i,j,ii,jj,iproc,itask(4),nn
7767 c      write (iout,*) "itask",itask
7768       do i=1,2
7769         iproc=itask(i)
7770         if (iproc.gt.0) then
7771           do j=1,num_cont_hb(ii)
7772             jjc=jcont_hb(j,ii)
7773 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7774             if (jjc.eq.jj) then
7775               ncont_sent(iproc)=ncont_sent(iproc)+1
7776               nn=ncont_sent(iproc)
7777               zapas(1,nn,iproc)=ii
7778               zapas(2,nn,iproc)=jjc
7779               zapas(3,nn,iproc)=d_cont(j,ii)
7780               ind=3
7781               do kk=1,3
7782                 ind=ind+1
7783                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7784               enddo
7785               do kk=1,2
7786                 do ll=1,2
7787                   ind=ind+1
7788                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7789                 enddo
7790               enddo
7791               do jj=1,5
7792                 do kk=1,3
7793                   do ll=1,2
7794                     do mm=1,2
7795                       ind=ind+1
7796                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7797                     enddo
7798                   enddo
7799                 enddo
7800               enddo
7801               exit
7802             endif
7803           enddo
7804         endif
7805       enddo
7806       return
7807       end
7808 c------------------------------------------------------------------------------
7809       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7810       implicit real*8 (a-h,o-z)
7811       include 'DIMENSIONS'
7812       include 'COMMON.IOUNITS'
7813       include 'COMMON.DERIV'
7814       include 'COMMON.INTERACT'
7815       include 'COMMON.CONTACTS'
7816       double precision gx(3),gx1(3)
7817       logical lprn
7818       lprn=.false.
7819       eij=facont_hb(jj,i)
7820       ekl=facont_hb(kk,k)
7821       ees0pij=ees0p(jj,i)
7822       ees0pkl=ees0p(kk,k)
7823       ees0mij=ees0m(jj,i)
7824       ees0mkl=ees0m(kk,k)
7825       ekont=eij*ekl
7826       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7827 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7828 C Following 4 lines for diagnostics.
7829 cd    ees0pkl=0.0D0
7830 cd    ees0pij=1.0D0
7831 cd    ees0mkl=0.0D0
7832 cd    ees0mij=1.0D0
7833 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7834 c     & 'Contacts ',i,j,
7835 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7836 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7837 c     & 'gradcorr_long'
7838 C Calculate the multi-body contribution to energy.
7839 c      ecorr=ecorr+ekont*ees
7840 C Calculate multi-body contributions to the gradient.
7841       coeffpees0pij=coeffp*ees0pij
7842       coeffmees0mij=coeffm*ees0mij
7843       coeffpees0pkl=coeffp*ees0pkl
7844       coeffmees0mkl=coeffm*ees0mkl
7845       do ll=1,3
7846 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7847         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7848      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7849      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7850         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7851      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7852      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7853 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7854         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7855      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7856      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7857         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7858      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7859      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7860         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7861      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7862      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7863         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7864         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7865         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7866      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7867      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7868         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7869         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7870 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7871       enddo
7872 c      write (iout,*)
7873 cgrad      do m=i+1,j-1
7874 cgrad        do ll=1,3
7875 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7876 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7877 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7878 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7879 cgrad        enddo
7880 cgrad      enddo
7881 cgrad      do m=k+1,l-1
7882 cgrad        do ll=1,3
7883 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7884 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7885 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7886 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7887 cgrad        enddo
7888 cgrad      enddo
7889 c      write (iout,*) "ehbcorr",ekont*ees
7890       ehbcorr=ekont*ees
7891       return
7892       end
7893 #ifdef MOMENT
7894 C---------------------------------------------------------------------------
7895       subroutine dipole(i,j,jj)
7896       implicit real*8 (a-h,o-z)
7897       include 'DIMENSIONS'
7898       include 'COMMON.IOUNITS'
7899       include 'COMMON.CHAIN'
7900       include 'COMMON.FFIELD'
7901       include 'COMMON.DERIV'
7902       include 'COMMON.INTERACT'
7903       include 'COMMON.CONTACTS'
7904       include 'COMMON.TORSION'
7905       include 'COMMON.VAR'
7906       include 'COMMON.GEO'
7907       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7908      &  auxmat(2,2)
7909       iti1 = itortyp(itype(i+1))
7910       if (j.lt.nres-1) then
7911         itj1 = itortyp(itype(j+1))
7912       else
7913         itj1=ntortyp
7914       endif
7915       do iii=1,2
7916         dipi(iii,1)=Ub2(iii,i)
7917         dipderi(iii)=Ub2der(iii,i)
7918         dipi(iii,2)=b1(iii,i+1)
7919         dipj(iii,1)=Ub2(iii,j)
7920         dipderj(iii)=Ub2der(iii,j)
7921         dipj(iii,2)=b1(iii,j+1)
7922       enddo
7923       kkk=0
7924       do iii=1,2
7925         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7926         do jjj=1,2
7927           kkk=kkk+1
7928           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7929         enddo
7930       enddo
7931       do kkk=1,5
7932         do lll=1,3
7933           mmm=0
7934           do iii=1,2
7935             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7936      &        auxvec(1))
7937             do jjj=1,2
7938               mmm=mmm+1
7939               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7940             enddo
7941           enddo
7942         enddo
7943       enddo
7944       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7945       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7946       do iii=1,2
7947         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7948       enddo
7949       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7950       do iii=1,2
7951         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7952       enddo
7953       return
7954       end
7955 #endif
7956 C---------------------------------------------------------------------------
7957       subroutine calc_eello(i,j,k,l,jj,kk)
7958 C
7959 C This subroutine computes matrices and vectors needed to calculate
7960 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7961 C
7962       implicit real*8 (a-h,o-z)
7963       include 'DIMENSIONS'
7964       include 'COMMON.IOUNITS'
7965       include 'COMMON.CHAIN'
7966       include 'COMMON.DERIV'
7967       include 'COMMON.INTERACT'
7968       include 'COMMON.CONTACTS'
7969       include 'COMMON.TORSION'
7970       include 'COMMON.VAR'
7971       include 'COMMON.GEO'
7972       include 'COMMON.FFIELD'
7973       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7974      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7975       logical lprn
7976       common /kutas/ lprn
7977 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7978 cd     & ' jj=',jj,' kk=',kk
7979 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7980 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7981 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7982       do iii=1,2
7983         do jjj=1,2
7984           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7985           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7986         enddo
7987       enddo
7988       call transpose2(aa1(1,1),aa1t(1,1))
7989       call transpose2(aa2(1,1),aa2t(1,1))
7990       do kkk=1,5
7991         do lll=1,3
7992           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7993      &      aa1tder(1,1,lll,kkk))
7994           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7995      &      aa2tder(1,1,lll,kkk))
7996         enddo
7997       enddo
7998       if (l.eq.j+1) then
7999 C parallel orientation of the two CA-CA-CA frames.
8000         if (i.gt.1) then
8001           iti=itortyp(itype(i))
8002         else
8003           iti=ntortyp
8004         endif
8005         itk1=itortyp(itype(k+1))
8006         itj=itortyp(itype(j))
8007         if (l.lt.nres-1) then
8008           itl1=itortyp(itype(l+1))
8009         else
8010           itl1=ntortyp
8011         endif
8012 C A1 kernel(j+1) A2T
8013 cd        do iii=1,2
8014 cd          write (iout,'(3f10.5,5x,3f10.5)')
8015 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8016 cd        enddo
8017         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8018      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8019      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8020 C Following matrices are needed only for 6-th order cumulants
8021         IF (wcorr6.gt.0.0d0) THEN
8022         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8023      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8024      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8025         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8026      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8027      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8028      &   ADtEAderx(1,1,1,1,1,1))
8029         lprn=.false.
8030         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8031      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8032      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8033      &   ADtEA1derx(1,1,1,1,1,1))
8034         ENDIF
8035 C End 6-th order cumulants
8036 cd        lprn=.false.
8037 cd        if (lprn) then
8038 cd        write (2,*) 'In calc_eello6'
8039 cd        do iii=1,2
8040 cd          write (2,*) 'iii=',iii
8041 cd          do kkk=1,5
8042 cd            write (2,*) 'kkk=',kkk
8043 cd            do jjj=1,2
8044 cd              write (2,'(3(2f10.5),5x)')
8045 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8046 cd            enddo
8047 cd          enddo
8048 cd        enddo
8049 cd        endif
8050         call transpose2(EUgder(1,1,k),auxmat(1,1))
8051         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8052         call transpose2(EUg(1,1,k),auxmat(1,1))
8053         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8054         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8055         do iii=1,2
8056           do kkk=1,5
8057             do lll=1,3
8058               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8059      &          EAEAderx(1,1,lll,kkk,iii,1))
8060             enddo
8061           enddo
8062         enddo
8063 C A1T kernel(i+1) A2
8064         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8065      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8066      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8067 C Following matrices are needed only for 6-th order cumulants
8068         IF (wcorr6.gt.0.0d0) THEN
8069         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8070      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8071      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8072         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8073      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8074      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8075      &   ADtEAderx(1,1,1,1,1,2))
8076         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8077      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8078      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8079      &   ADtEA1derx(1,1,1,1,1,2))
8080         ENDIF
8081 C End 6-th order cumulants
8082         call transpose2(EUgder(1,1,l),auxmat(1,1))
8083         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8084         call transpose2(EUg(1,1,l),auxmat(1,1))
8085         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8086         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8087         do iii=1,2
8088           do kkk=1,5
8089             do lll=1,3
8090               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8091      &          EAEAderx(1,1,lll,kkk,iii,2))
8092             enddo
8093           enddo
8094         enddo
8095 C AEAb1 and AEAb2
8096 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8097 C They are needed only when the fifth- or the sixth-order cumulants are
8098 C indluded.
8099         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8100         call transpose2(AEA(1,1,1),auxmat(1,1))
8101         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8102         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8103         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8104         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8105         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8106         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8107         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8108         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8109         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8110         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8111         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8112         call transpose2(AEA(1,1,2),auxmat(1,1))
8113         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8114         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8115         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8116         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8117         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8118         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8119         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8120         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8121         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8122         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8123         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8124 C Calculate the Cartesian derivatives of the vectors.
8125         do iii=1,2
8126           do kkk=1,5
8127             do lll=1,3
8128               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8129               call matvec2(auxmat(1,1),b1(1,i),
8130      &          AEAb1derx(1,lll,kkk,iii,1,1))
8131               call matvec2(auxmat(1,1),Ub2(1,i),
8132      &          AEAb2derx(1,lll,kkk,iii,1,1))
8133               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8134      &          AEAb1derx(1,lll,kkk,iii,2,1))
8135               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8136      &          AEAb2derx(1,lll,kkk,iii,2,1))
8137               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8138               call matvec2(auxmat(1,1),b1(1,j),
8139      &          AEAb1derx(1,lll,kkk,iii,1,2))
8140               call matvec2(auxmat(1,1),Ub2(1,j),
8141      &          AEAb2derx(1,lll,kkk,iii,1,2))
8142               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8143      &          AEAb1derx(1,lll,kkk,iii,2,2))
8144               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8145      &          AEAb2derx(1,lll,kkk,iii,2,2))
8146             enddo
8147           enddo
8148         enddo
8149         ENDIF
8150 C End vectors
8151       else
8152 C Antiparallel orientation of the two CA-CA-CA frames.
8153         if (i.gt.1) then
8154           iti=itortyp(itype(i))
8155         else
8156           iti=ntortyp
8157         endif
8158         itk1=itortyp(itype(k+1))
8159         itl=itortyp(itype(l))
8160         itj=itortyp(itype(j))
8161         if (j.lt.nres-1) then
8162           itj1=itortyp(itype(j+1))
8163         else
8164           itj1=ntortyp
8165         endif
8166 C A2 kernel(j-1)T A1T
8167         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8168      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8169      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8170 C Following matrices are needed only for 6-th order cumulants
8171         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8172      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8173         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8174      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8175      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8176         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8177      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8178      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8179      &   ADtEAderx(1,1,1,1,1,1))
8180         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8181      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8182      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8183      &   ADtEA1derx(1,1,1,1,1,1))
8184         ENDIF
8185 C End 6-th order cumulants
8186         call transpose2(EUgder(1,1,k),auxmat(1,1))
8187         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8188         call transpose2(EUg(1,1,k),auxmat(1,1))
8189         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8190         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8191         do iii=1,2
8192           do kkk=1,5
8193             do lll=1,3
8194               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8195      &          EAEAderx(1,1,lll,kkk,iii,1))
8196             enddo
8197           enddo
8198         enddo
8199 C A2T kernel(i+1)T A1
8200         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8201      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8202      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8203 C Following matrices are needed only for 6-th order cumulants
8204         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8205      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8206         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8207      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8208      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8209         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8210      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8211      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8212      &   ADtEAderx(1,1,1,1,1,2))
8213         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8214      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8215      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8216      &   ADtEA1derx(1,1,1,1,1,2))
8217         ENDIF
8218 C End 6-th order cumulants
8219         call transpose2(EUgder(1,1,j),auxmat(1,1))
8220         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8221         call transpose2(EUg(1,1,j),auxmat(1,1))
8222         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8223         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8224         do iii=1,2
8225           do kkk=1,5
8226             do lll=1,3
8227               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8228      &          EAEAderx(1,1,lll,kkk,iii,2))
8229             enddo
8230           enddo
8231         enddo
8232 C AEAb1 and AEAb2
8233 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8234 C They are needed only when the fifth- or the sixth-order cumulants are
8235 C indluded.
8236         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8237      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8238         call transpose2(AEA(1,1,1),auxmat(1,1))
8239         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8240         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8241         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8242         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8243         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8244         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8245         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8246         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8247         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8248         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8249         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8250         call transpose2(AEA(1,1,2),auxmat(1,1))
8251         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8252         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8253         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8254         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8255         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8256         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8257         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8258         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8259         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8260         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8261         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8262 C Calculate the Cartesian derivatives of the vectors.
8263         do iii=1,2
8264           do kkk=1,5
8265             do lll=1,3
8266               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8267               call matvec2(auxmat(1,1),b1(1,i),
8268      &          AEAb1derx(1,lll,kkk,iii,1,1))
8269               call matvec2(auxmat(1,1),Ub2(1,i),
8270      &          AEAb2derx(1,lll,kkk,iii,1,1))
8271               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8272      &          AEAb1derx(1,lll,kkk,iii,2,1))
8273               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8274      &          AEAb2derx(1,lll,kkk,iii,2,1))
8275               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8276               call matvec2(auxmat(1,1),b1(1,l),
8277      &          AEAb1derx(1,lll,kkk,iii,1,2))
8278               call matvec2(auxmat(1,1),Ub2(1,l),
8279      &          AEAb2derx(1,lll,kkk,iii,1,2))
8280               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8281      &          AEAb1derx(1,lll,kkk,iii,2,2))
8282               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8283      &          AEAb2derx(1,lll,kkk,iii,2,2))
8284             enddo
8285           enddo
8286         enddo
8287         ENDIF
8288 C End vectors
8289       endif
8290       return
8291       end
8292 C---------------------------------------------------------------------------
8293       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8294      &  KK,KKderg,AKA,AKAderg,AKAderx)
8295       implicit none
8296       integer nderg
8297       logical transp
8298       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8299      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8300      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8301       integer iii,kkk,lll
8302       integer jjj,mmm
8303       logical lprn
8304       common /kutas/ lprn
8305       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8306       do iii=1,nderg
8307         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8308      &    AKAderg(1,1,iii))
8309       enddo
8310 cd      if (lprn) write (2,*) 'In kernel'
8311       do kkk=1,5
8312 cd        if (lprn) write (2,*) 'kkk=',kkk
8313         do lll=1,3
8314           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8315      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8316 cd          if (lprn) then
8317 cd            write (2,*) 'lll=',lll
8318 cd            write (2,*) 'iii=1'
8319 cd            do jjj=1,2
8320 cd              write (2,'(3(2f10.5),5x)')
8321 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8322 cd            enddo
8323 cd          endif
8324           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8325      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8326 cd          if (lprn) then
8327 cd            write (2,*) 'lll=',lll
8328 cd            write (2,*) 'iii=2'
8329 cd            do jjj=1,2
8330 cd              write (2,'(3(2f10.5),5x)')
8331 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8332 cd            enddo
8333 cd          endif
8334         enddo
8335       enddo
8336       return
8337       end
8338 C---------------------------------------------------------------------------
8339       double precision function eello4(i,j,k,l,jj,kk)
8340       implicit real*8 (a-h,o-z)
8341       include 'DIMENSIONS'
8342       include 'COMMON.IOUNITS'
8343       include 'COMMON.CHAIN'
8344       include 'COMMON.DERIV'
8345       include 'COMMON.INTERACT'
8346       include 'COMMON.CONTACTS'
8347       include 'COMMON.TORSION'
8348       include 'COMMON.VAR'
8349       include 'COMMON.GEO'
8350       double precision pizda(2,2),ggg1(3),ggg2(3)
8351 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8352 cd        eello4=0.0d0
8353 cd        return
8354 cd      endif
8355 cd      print *,'eello4:',i,j,k,l,jj,kk
8356 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8357 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8358 cold      eij=facont_hb(jj,i)
8359 cold      ekl=facont_hb(kk,k)
8360 cold      ekont=eij*ekl
8361       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8362 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8363       gcorr_loc(k-1)=gcorr_loc(k-1)
8364      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8365       if (l.eq.j+1) then
8366         gcorr_loc(l-1)=gcorr_loc(l-1)
8367      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8368       else
8369         gcorr_loc(j-1)=gcorr_loc(j-1)
8370      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8371       endif
8372       do iii=1,2
8373         do kkk=1,5
8374           do lll=1,3
8375             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8376      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8377 cd            derx(lll,kkk,iii)=0.0d0
8378           enddo
8379         enddo
8380       enddo
8381 cd      gcorr_loc(l-1)=0.0d0
8382 cd      gcorr_loc(j-1)=0.0d0
8383 cd      gcorr_loc(k-1)=0.0d0
8384 cd      eel4=1.0d0
8385 cd      write (iout,*)'Contacts have occurred for peptide groups',
8386 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8387 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8388       if (j.lt.nres-1) then
8389         j1=j+1
8390         j2=j-1
8391       else
8392         j1=j-1
8393         j2=j-2
8394       endif
8395       if (l.lt.nres-1) then
8396         l1=l+1
8397         l2=l-1
8398       else
8399         l1=l-1
8400         l2=l-2
8401       endif
8402       do ll=1,3
8403 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8404 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8405         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8406         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8407 cgrad        ghalf=0.5d0*ggg1(ll)
8408         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8409         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8410         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8411         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8412         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8413         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8414 cgrad        ghalf=0.5d0*ggg2(ll)
8415         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8416         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8417         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8418         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8419         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8420         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8421       enddo
8422 cgrad      do m=i+1,j-1
8423 cgrad        do ll=1,3
8424 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8425 cgrad        enddo
8426 cgrad      enddo
8427 cgrad      do m=k+1,l-1
8428 cgrad        do ll=1,3
8429 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8430 cgrad        enddo
8431 cgrad      enddo
8432 cgrad      do m=i+2,j2
8433 cgrad        do ll=1,3
8434 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8435 cgrad        enddo
8436 cgrad      enddo
8437 cgrad      do m=k+2,l2
8438 cgrad        do ll=1,3
8439 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8440 cgrad        enddo
8441 cgrad      enddo
8442 cd      do iii=1,nres-3
8443 cd        write (2,*) iii,gcorr_loc(iii)
8444 cd      enddo
8445       eello4=ekont*eel4
8446 cd      write (2,*) 'ekont',ekont
8447 cd      write (iout,*) 'eello4',ekont*eel4
8448       return
8449       end
8450 C---------------------------------------------------------------------------
8451       double precision function eello5(i,j,k,l,jj,kk)
8452       implicit real*8 (a-h,o-z)
8453       include 'DIMENSIONS'
8454       include 'COMMON.IOUNITS'
8455       include 'COMMON.CHAIN'
8456       include 'COMMON.DERIV'
8457       include 'COMMON.INTERACT'
8458       include 'COMMON.CONTACTS'
8459       include 'COMMON.TORSION'
8460       include 'COMMON.VAR'
8461       include 'COMMON.GEO'
8462       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8463       double precision ggg1(3),ggg2(3)
8464 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8465 C                                                                              C
8466 C                            Parallel chains                                   C
8467 C                                                                              C
8468 C          o             o                   o             o                   C
8469 C         /l\           / \             \   / \           / \   /              C
8470 C        /   \         /   \             \ /   \         /   \ /               C
8471 C       j| o |l1       | o |              o| o |         | o |o                C
8472 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8473 C      \i/   \         /   \ /             /   \         /   \                 C
8474 C       o    k1             o                                                  C
8475 C         (I)          (II)                (III)          (IV)                 C
8476 C                                                                              C
8477 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8478 C                                                                              C
8479 C                            Antiparallel chains                               C
8480 C                                                                              C
8481 C          o             o                   o             o                   C
8482 C         /j\           / \             \   / \           / \   /              C
8483 C        /   \         /   \             \ /   \         /   \ /               C
8484 C      j1| o |l        | o |              o| o |         | o |o                C
8485 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8486 C      \i/   \         /   \ /             /   \         /   \                 C
8487 C       o     k1            o                                                  C
8488 C         (I)          (II)                (III)          (IV)                 C
8489 C                                                                              C
8490 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8491 C                                                                              C
8492 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8493 C                                                                              C
8494 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8495 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8496 cd        eello5=0.0d0
8497 cd        return
8498 cd      endif
8499 cd      write (iout,*)
8500 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8501 cd     &   ' and',k,l
8502       itk=itortyp(itype(k))
8503       itl=itortyp(itype(l))
8504       itj=itortyp(itype(j))
8505       eello5_1=0.0d0
8506       eello5_2=0.0d0
8507       eello5_3=0.0d0
8508       eello5_4=0.0d0
8509 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8510 cd     &   eel5_3_num,eel5_4_num)
8511       do iii=1,2
8512         do kkk=1,5
8513           do lll=1,3
8514             derx(lll,kkk,iii)=0.0d0
8515           enddo
8516         enddo
8517       enddo
8518 cd      eij=facont_hb(jj,i)
8519 cd      ekl=facont_hb(kk,k)
8520 cd      ekont=eij*ekl
8521 cd      write (iout,*)'Contacts have occurred for peptide groups',
8522 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8523 cd      goto 1111
8524 C Contribution from the graph I.
8525 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8526 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8527       call transpose2(EUg(1,1,k),auxmat(1,1))
8528       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8529       vv(1)=pizda(1,1)-pizda(2,2)
8530       vv(2)=pizda(1,2)+pizda(2,1)
8531       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8532      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8533 C Explicit gradient in virtual-dihedral angles.
8534       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8535      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8536      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8537       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8538       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8539       vv(1)=pizda(1,1)-pizda(2,2)
8540       vv(2)=pizda(1,2)+pizda(2,1)
8541       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8542      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8543      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8544       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8545       vv(1)=pizda(1,1)-pizda(2,2)
8546       vv(2)=pizda(1,2)+pizda(2,1)
8547       if (l.eq.j+1) then
8548         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8549      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8550      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8551       else
8552         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8553      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8554      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8555       endif
8556 C Cartesian gradient
8557       do iii=1,2
8558         do kkk=1,5
8559           do lll=1,3
8560             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8561      &        pizda(1,1))
8562             vv(1)=pizda(1,1)-pizda(2,2)
8563             vv(2)=pizda(1,2)+pizda(2,1)
8564             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8565      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8566      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8567           enddo
8568         enddo
8569       enddo
8570 c      goto 1112
8571 c1111  continue
8572 C Contribution from graph II
8573       call transpose2(EE(1,1,itk),auxmat(1,1))
8574       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8575       vv(1)=pizda(1,1)+pizda(2,2)
8576       vv(2)=pizda(2,1)-pizda(1,2)
8577       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8578      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8579 C Explicit gradient in virtual-dihedral angles.
8580       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8581      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8582       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8583       vv(1)=pizda(1,1)+pizda(2,2)
8584       vv(2)=pizda(2,1)-pizda(1,2)
8585       if (l.eq.j+1) then
8586         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8587      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8588      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8589       else
8590         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8591      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8592      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8593       endif
8594 C Cartesian gradient
8595       do iii=1,2
8596         do kkk=1,5
8597           do lll=1,3
8598             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8599      &        pizda(1,1))
8600             vv(1)=pizda(1,1)+pizda(2,2)
8601             vv(2)=pizda(2,1)-pizda(1,2)
8602             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8603      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8604      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8605           enddo
8606         enddo
8607       enddo
8608 cd      goto 1112
8609 cd1111  continue
8610       if (l.eq.j+1) then
8611 cd        goto 1110
8612 C Parallel orientation
8613 C Contribution from graph III
8614         call transpose2(EUg(1,1,l),auxmat(1,1))
8615         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8616         vv(1)=pizda(1,1)-pizda(2,2)
8617         vv(2)=pizda(1,2)+pizda(2,1)
8618         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8619      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8620 C Explicit gradient in virtual-dihedral angles.
8621         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8622      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8623      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8624         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8625         vv(1)=pizda(1,1)-pizda(2,2)
8626         vv(2)=pizda(1,2)+pizda(2,1)
8627         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8628      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8629      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8630         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8631         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8632         vv(1)=pizda(1,1)-pizda(2,2)
8633         vv(2)=pizda(1,2)+pizda(2,1)
8634         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8635      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8636      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8637 C Cartesian gradient
8638         do iii=1,2
8639           do kkk=1,5
8640             do lll=1,3
8641               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8642      &          pizda(1,1))
8643               vv(1)=pizda(1,1)-pizda(2,2)
8644               vv(2)=pizda(1,2)+pizda(2,1)
8645               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8646      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8647      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8648             enddo
8649           enddo
8650         enddo
8651 cd        goto 1112
8652 C Contribution from graph IV
8653 cd1110    continue
8654         call transpose2(EE(1,1,itl),auxmat(1,1))
8655         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8656         vv(1)=pizda(1,1)+pizda(2,2)
8657         vv(2)=pizda(2,1)-pizda(1,2)
8658         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8659      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8660 C Explicit gradient in virtual-dihedral angles.
8661         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8662      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8663         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8664         vv(1)=pizda(1,1)+pizda(2,2)
8665         vv(2)=pizda(2,1)-pizda(1,2)
8666         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8667      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8668      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8669 C Cartesian gradient
8670         do iii=1,2
8671           do kkk=1,5
8672             do lll=1,3
8673               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8674      &          pizda(1,1))
8675               vv(1)=pizda(1,1)+pizda(2,2)
8676               vv(2)=pizda(2,1)-pizda(1,2)
8677               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8678      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8679      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8680             enddo
8681           enddo
8682         enddo
8683       else
8684 C Antiparallel orientation
8685 C Contribution from graph III
8686 c        goto 1110
8687         call transpose2(EUg(1,1,j),auxmat(1,1))
8688         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8689         vv(1)=pizda(1,1)-pizda(2,2)
8690         vv(2)=pizda(1,2)+pizda(2,1)
8691         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8692      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8693 C Explicit gradient in virtual-dihedral angles.
8694         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8695      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8696      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8697         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8698         vv(1)=pizda(1,1)-pizda(2,2)
8699         vv(2)=pizda(1,2)+pizda(2,1)
8700         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8701      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8702      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8703         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8704         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8705         vv(1)=pizda(1,1)-pizda(2,2)
8706         vv(2)=pizda(1,2)+pizda(2,1)
8707         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8708      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8709      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8710 C Cartesian gradient
8711         do iii=1,2
8712           do kkk=1,5
8713             do lll=1,3
8714               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8715      &          pizda(1,1))
8716               vv(1)=pizda(1,1)-pizda(2,2)
8717               vv(2)=pizda(1,2)+pizda(2,1)
8718               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8719      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8720      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8721             enddo
8722           enddo
8723         enddo
8724 cd        goto 1112
8725 C Contribution from graph IV
8726 1110    continue
8727         call transpose2(EE(1,1,itj),auxmat(1,1))
8728         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8729         vv(1)=pizda(1,1)+pizda(2,2)
8730         vv(2)=pizda(2,1)-pizda(1,2)
8731         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8732      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8733 C Explicit gradient in virtual-dihedral angles.
8734         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8735      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8736         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8737         vv(1)=pizda(1,1)+pizda(2,2)
8738         vv(2)=pizda(2,1)-pizda(1,2)
8739         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8740      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8741      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8742 C Cartesian gradient
8743         do iii=1,2
8744           do kkk=1,5
8745             do lll=1,3
8746               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8747      &          pizda(1,1))
8748               vv(1)=pizda(1,1)+pizda(2,2)
8749               vv(2)=pizda(2,1)-pizda(1,2)
8750               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8751      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8752      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8753             enddo
8754           enddo
8755         enddo
8756       endif
8757 1112  continue
8758       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8759 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8760 cd        write (2,*) 'ijkl',i,j,k,l
8761 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8762 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8763 cd      endif
8764 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8765 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8766 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8767 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8768       if (j.lt.nres-1) then
8769         j1=j+1
8770         j2=j-1
8771       else
8772         j1=j-1
8773         j2=j-2
8774       endif
8775       if (l.lt.nres-1) then
8776         l1=l+1
8777         l2=l-1
8778       else
8779         l1=l-1
8780         l2=l-2
8781       endif
8782 cd      eij=1.0d0
8783 cd      ekl=1.0d0
8784 cd      ekont=1.0d0
8785 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8786 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8787 C        summed up outside the subrouine as for the other subroutines
8788 C        handling long-range interactions. The old code is commented out
8789 C        with "cgrad" to keep track of changes.
8790       do ll=1,3
8791 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8792 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8793         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8794         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8795 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8796 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8797 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8798 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8799 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8800 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8801 c     &   gradcorr5ij,
8802 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8803 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8804 cgrad        ghalf=0.5d0*ggg1(ll)
8805 cd        ghalf=0.0d0
8806         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8807         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8808         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8809         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8810         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8811         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8812 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8813 cgrad        ghalf=0.5d0*ggg2(ll)
8814 cd        ghalf=0.0d0
8815         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8816         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8817         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8818         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8819         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8820         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8821       enddo
8822 cd      goto 1112
8823 cgrad      do m=i+1,j-1
8824 cgrad        do ll=1,3
8825 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8826 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8827 cgrad        enddo
8828 cgrad      enddo
8829 cgrad      do m=k+1,l-1
8830 cgrad        do ll=1,3
8831 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8832 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8833 cgrad        enddo
8834 cgrad      enddo
8835 c1112  continue
8836 cgrad      do m=i+2,j2
8837 cgrad        do ll=1,3
8838 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8839 cgrad        enddo
8840 cgrad      enddo
8841 cgrad      do m=k+2,l2
8842 cgrad        do ll=1,3
8843 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8844 cgrad        enddo
8845 cgrad      enddo
8846 cd      do iii=1,nres-3
8847 cd        write (2,*) iii,g_corr5_loc(iii)
8848 cd      enddo
8849       eello5=ekont*eel5
8850 cd      write (2,*) 'ekont',ekont
8851 cd      write (iout,*) 'eello5',ekont*eel5
8852       return
8853       end
8854 c--------------------------------------------------------------------------
8855       double precision function eello6(i,j,k,l,jj,kk)
8856       implicit real*8 (a-h,o-z)
8857       include 'DIMENSIONS'
8858       include 'COMMON.IOUNITS'
8859       include 'COMMON.CHAIN'
8860       include 'COMMON.DERIV'
8861       include 'COMMON.INTERACT'
8862       include 'COMMON.CONTACTS'
8863       include 'COMMON.TORSION'
8864       include 'COMMON.VAR'
8865       include 'COMMON.GEO'
8866       include 'COMMON.FFIELD'
8867       double precision ggg1(3),ggg2(3)
8868 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8869 cd        eello6=0.0d0
8870 cd        return
8871 cd      endif
8872 cd      write (iout,*)
8873 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8874 cd     &   ' and',k,l
8875       eello6_1=0.0d0
8876       eello6_2=0.0d0
8877       eello6_3=0.0d0
8878       eello6_4=0.0d0
8879       eello6_5=0.0d0
8880       eello6_6=0.0d0
8881 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8882 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8883       do iii=1,2
8884         do kkk=1,5
8885           do lll=1,3
8886             derx(lll,kkk,iii)=0.0d0
8887           enddo
8888         enddo
8889       enddo
8890 cd      eij=facont_hb(jj,i)
8891 cd      ekl=facont_hb(kk,k)
8892 cd      ekont=eij*ekl
8893 cd      eij=1.0d0
8894 cd      ekl=1.0d0
8895 cd      ekont=1.0d0
8896       if (l.eq.j+1) then
8897         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8898         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8899         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8900         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8901         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8902         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8903       else
8904         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8905         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8906         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8907         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8908         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8909           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8910         else
8911           eello6_5=0.0d0
8912         endif
8913         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8914       endif
8915 C If turn contributions are considered, they will be handled separately.
8916       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8917 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8918 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8919 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8920 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8921 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8922 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8923 cd      goto 1112
8924       if (j.lt.nres-1) then
8925         j1=j+1
8926         j2=j-1
8927       else
8928         j1=j-1
8929         j2=j-2
8930       endif
8931       if (l.lt.nres-1) then
8932         l1=l+1
8933         l2=l-1
8934       else
8935         l1=l-1
8936         l2=l-2
8937       endif
8938       do ll=1,3
8939 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8940 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8941 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8942 cgrad        ghalf=0.5d0*ggg1(ll)
8943 cd        ghalf=0.0d0
8944         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8945         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8946         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8947         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8948         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8949         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8950         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8951         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8952 cgrad        ghalf=0.5d0*ggg2(ll)
8953 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8954 cd        ghalf=0.0d0
8955         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8956         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8957         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8958         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8959         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8960         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8961       enddo
8962 cd      goto 1112
8963 cgrad      do m=i+1,j-1
8964 cgrad        do ll=1,3
8965 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8966 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8967 cgrad        enddo
8968 cgrad      enddo
8969 cgrad      do m=k+1,l-1
8970 cgrad        do ll=1,3
8971 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8972 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8973 cgrad        enddo
8974 cgrad      enddo
8975 cgrad1112  continue
8976 cgrad      do m=i+2,j2
8977 cgrad        do ll=1,3
8978 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8979 cgrad        enddo
8980 cgrad      enddo
8981 cgrad      do m=k+2,l2
8982 cgrad        do ll=1,3
8983 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8984 cgrad        enddo
8985 cgrad      enddo
8986 cd      do iii=1,nres-3
8987 cd        write (2,*) iii,g_corr6_loc(iii)
8988 cd      enddo
8989       eello6=ekont*eel6
8990 cd      write (2,*) 'ekont',ekont
8991 cd      write (iout,*) 'eello6',ekont*eel6
8992       return
8993       end
8994 c--------------------------------------------------------------------------
8995       double precision function eello6_graph1(i,j,k,l,imat,swap)
8996       implicit real*8 (a-h,o-z)
8997       include 'DIMENSIONS'
8998       include 'COMMON.IOUNITS'
8999       include 'COMMON.CHAIN'
9000       include 'COMMON.DERIV'
9001       include 'COMMON.INTERACT'
9002       include 'COMMON.CONTACTS'
9003       include 'COMMON.TORSION'
9004       include 'COMMON.VAR'
9005       include 'COMMON.GEO'
9006       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9007       logical swap
9008       logical lprn
9009       common /kutas/ lprn
9010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9011 C                                                                              C
9012 C      Parallel       Antiparallel                                             C
9013 C                                                                              C
9014 C          o             o                                                     C
9015 C         /l\           /j\                                                    C
9016 C        /   \         /   \                                                   C
9017 C       /| o |         | o |\                                                  C
9018 C     \ j|/k\|  /   \  |/k\|l /                                                C
9019 C      \ /   \ /     \ /   \ /                                                 C
9020 C       o     o       o     o                                                  C
9021 C       i             i                                                        C
9022 C                                                                              C
9023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9024       itk=itortyp(itype(k))
9025       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9026       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9027       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9028       call transpose2(EUgC(1,1,k),auxmat(1,1))
9029       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9030       vv1(1)=pizda1(1,1)-pizda1(2,2)
9031       vv1(2)=pizda1(1,2)+pizda1(2,1)
9032       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9033       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9034       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9035       s5=scalar2(vv(1),Dtobr2(1,i))
9036 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9037       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9038       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9039      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9040      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9041      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9042      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9043      & +scalar2(vv(1),Dtobr2der(1,i)))
9044       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9045       vv1(1)=pizda1(1,1)-pizda1(2,2)
9046       vv1(2)=pizda1(1,2)+pizda1(2,1)
9047       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9048       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9049       if (l.eq.j+1) then
9050         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9051      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9052      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9053      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9054      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9055       else
9056         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9057      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9058      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9059      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9060      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9061       endif
9062       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9063       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9064       vv1(1)=pizda1(1,1)-pizda1(2,2)
9065       vv1(2)=pizda1(1,2)+pizda1(2,1)
9066       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9067      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9068      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9069      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9070       do iii=1,2
9071         if (swap) then
9072           ind=3-iii
9073         else
9074           ind=iii
9075         endif
9076         do kkk=1,5
9077           do lll=1,3
9078             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9079             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9080             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9081             call transpose2(EUgC(1,1,k),auxmat(1,1))
9082             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9083      &        pizda1(1,1))
9084             vv1(1)=pizda1(1,1)-pizda1(2,2)
9085             vv1(2)=pizda1(1,2)+pizda1(2,1)
9086             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9087             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9088      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9089             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9090      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9091             s5=scalar2(vv(1),Dtobr2(1,i))
9092             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9093           enddo
9094         enddo
9095       enddo
9096       return
9097       end
9098 c----------------------------------------------------------------------------
9099       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9100       implicit real*8 (a-h,o-z)
9101       include 'DIMENSIONS'
9102       include 'COMMON.IOUNITS'
9103       include 'COMMON.CHAIN'
9104       include 'COMMON.DERIV'
9105       include 'COMMON.INTERACT'
9106       include 'COMMON.CONTACTS'
9107       include 'COMMON.TORSION'
9108       include 'COMMON.VAR'
9109       include 'COMMON.GEO'
9110       logical swap
9111       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9112      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9113       logical lprn
9114       common /kutas/ lprn
9115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9116 C                                                                              C
9117 C      Parallel       Antiparallel                                             C
9118 C                                                                              C
9119 C          o             o                                                     C
9120 C     \   /l\           /j\   /                                                C
9121 C      \ /   \         /   \ /                                                 C
9122 C       o| o |         | o |o                                                  C
9123 C     \ j|/k\|      \  |/k\|l                                                  C
9124 C      \ /   \       \ /   \                                                   C
9125 C       o             o                                                        C
9126 C       i             i                                                        C
9127 C                                                                              C
9128 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9129 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9130 C AL 7/4/01 s1 would occur in the sixth-order moment,
9131 C           but not in a cluster cumulant
9132 #ifdef MOMENT
9133       s1=dip(1,jj,i)*dip(1,kk,k)
9134 #endif
9135       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9136       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9137       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9138       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9139       call transpose2(EUg(1,1,k),auxmat(1,1))
9140       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9141       vv(1)=pizda(1,1)-pizda(2,2)
9142       vv(2)=pizda(1,2)+pizda(2,1)
9143       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9144 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9145 #ifdef MOMENT
9146       eello6_graph2=-(s1+s2+s3+s4)
9147 #else
9148       eello6_graph2=-(s2+s3+s4)
9149 #endif
9150 c      eello6_graph2=-s3
9151 C Derivatives in gamma(i-1)
9152       if (i.gt.1) then
9153 #ifdef MOMENT
9154         s1=dipderg(1,jj,i)*dip(1,kk,k)
9155 #endif
9156         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9157         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9158         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9159         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9160 #ifdef MOMENT
9161         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9162 #else
9163         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9164 #endif
9165 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9166       endif
9167 C Derivatives in gamma(k-1)
9168 #ifdef MOMENT
9169       s1=dip(1,jj,i)*dipderg(1,kk,k)
9170 #endif
9171       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9172       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9173       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9174       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9175       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9176       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9177       vv(1)=pizda(1,1)-pizda(2,2)
9178       vv(2)=pizda(1,2)+pizda(2,1)
9179       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9180 #ifdef MOMENT
9181       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9182 #else
9183       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9184 #endif
9185 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9186 C Derivatives in gamma(j-1) or gamma(l-1)
9187       if (j.gt.1) then
9188 #ifdef MOMENT
9189         s1=dipderg(3,jj,i)*dip(1,kk,k)
9190 #endif
9191         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9192         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9193         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9194         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9195         vv(1)=pizda(1,1)-pizda(2,2)
9196         vv(2)=pizda(1,2)+pizda(2,1)
9197         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9198 #ifdef MOMENT
9199         if (swap) then
9200           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9201         else
9202           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9203         endif
9204 #endif
9205         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9206 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9207       endif
9208 C Derivatives in gamma(l-1) or gamma(j-1)
9209       if (l.gt.1) then
9210 #ifdef MOMENT
9211         s1=dip(1,jj,i)*dipderg(3,kk,k)
9212 #endif
9213         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9214         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9215         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9216         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9217         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9218         vv(1)=pizda(1,1)-pizda(2,2)
9219         vv(2)=pizda(1,2)+pizda(2,1)
9220         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9221 #ifdef MOMENT
9222         if (swap) then
9223           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9224         else
9225           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9226         endif
9227 #endif
9228         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9229 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9230       endif
9231 C Cartesian derivatives.
9232       if (lprn) then
9233         write (2,*) 'In eello6_graph2'
9234         do iii=1,2
9235           write (2,*) 'iii=',iii
9236           do kkk=1,5
9237             write (2,*) 'kkk=',kkk
9238             do jjj=1,2
9239               write (2,'(3(2f10.5),5x)')
9240      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9241             enddo
9242           enddo
9243         enddo
9244       endif
9245       do iii=1,2
9246         do kkk=1,5
9247           do lll=1,3
9248 #ifdef MOMENT
9249             if (iii.eq.1) then
9250               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9251             else
9252               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9253             endif
9254 #endif
9255             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9256      &        auxvec(1))
9257             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9258             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9259      &        auxvec(1))
9260             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9261             call transpose2(EUg(1,1,k),auxmat(1,1))
9262             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9263      &        pizda(1,1))
9264             vv(1)=pizda(1,1)-pizda(2,2)
9265             vv(2)=pizda(1,2)+pizda(2,1)
9266             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9267 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9268 #ifdef MOMENT
9269             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9270 #else
9271             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9272 #endif
9273             if (swap) then
9274               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9275             else
9276               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9277             endif
9278           enddo
9279         enddo
9280       enddo
9281       return
9282       end
9283 c----------------------------------------------------------------------------
9284       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9285       implicit real*8 (a-h,o-z)
9286       include 'DIMENSIONS'
9287       include 'COMMON.IOUNITS'
9288       include 'COMMON.CHAIN'
9289       include 'COMMON.DERIV'
9290       include 'COMMON.INTERACT'
9291       include 'COMMON.CONTACTS'
9292       include 'COMMON.TORSION'
9293       include 'COMMON.VAR'
9294       include 'COMMON.GEO'
9295       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9296       logical swap
9297 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9298 C                                                                              C
9299 C      Parallel       Antiparallel                                             C
9300 C                                                                              C
9301 C          o             o                                                     C
9302 C         /l\   /   \   /j\                                                    C
9303 C        /   \ /     \ /   \                                                   C
9304 C       /| o |o       o| o |\                                                  C
9305 C       j|/k\|  /      |/k\|l /                                                C
9306 C        /   \ /       /   \ /                                                 C
9307 C       /     o       /     o                                                  C
9308 C       i             i                                                        C
9309 C                                                                              C
9310 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9311 C
9312 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9313 C           energy moment and not to the cluster cumulant.
9314       iti=itortyp(itype(i))
9315       if (j.lt.nres-1) then
9316         itj1=itortyp(itype(j+1))
9317       else
9318         itj1=ntortyp
9319       endif
9320       itk=itortyp(itype(k))
9321       itk1=itortyp(itype(k+1))
9322       if (l.lt.nres-1) then
9323         itl1=itortyp(itype(l+1))
9324       else
9325         itl1=ntortyp
9326       endif
9327 #ifdef MOMENT
9328       s1=dip(4,jj,i)*dip(4,kk,k)
9329 #endif
9330       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9331       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9332       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9333       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9334       call transpose2(EE(1,1,itk),auxmat(1,1))
9335       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9336       vv(1)=pizda(1,1)+pizda(2,2)
9337       vv(2)=pizda(2,1)-pizda(1,2)
9338       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9339 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9340 cd     & "sum",-(s2+s3+s4)
9341 #ifdef MOMENT
9342       eello6_graph3=-(s1+s2+s3+s4)
9343 #else
9344       eello6_graph3=-(s2+s3+s4)
9345 #endif
9346 c      eello6_graph3=-s4
9347 C Derivatives in gamma(k-1)
9348       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9349       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9350       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9351       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9352 C Derivatives in gamma(l-1)
9353       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9354       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9355       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9356       vv(1)=pizda(1,1)+pizda(2,2)
9357       vv(2)=pizda(2,1)-pizda(1,2)
9358       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9359       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9360 C Cartesian derivatives.
9361       do iii=1,2
9362         do kkk=1,5
9363           do lll=1,3
9364 #ifdef MOMENT
9365             if (iii.eq.1) then
9366               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9367             else
9368               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9369             endif
9370 #endif
9371             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9372      &        auxvec(1))
9373             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9374             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9375      &        auxvec(1))
9376             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9377             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9378      &        pizda(1,1))
9379             vv(1)=pizda(1,1)+pizda(2,2)
9380             vv(2)=pizda(2,1)-pizda(1,2)
9381             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9382 #ifdef MOMENT
9383             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9384 #else
9385             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9386 #endif
9387             if (swap) then
9388               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9389             else
9390               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9391             endif
9392 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9393           enddo
9394         enddo
9395       enddo
9396       return
9397       end
9398 c----------------------------------------------------------------------------
9399       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9400       implicit real*8 (a-h,o-z)
9401       include 'DIMENSIONS'
9402       include 'COMMON.IOUNITS'
9403       include 'COMMON.CHAIN'
9404       include 'COMMON.DERIV'
9405       include 'COMMON.INTERACT'
9406       include 'COMMON.CONTACTS'
9407       include 'COMMON.TORSION'
9408       include 'COMMON.VAR'
9409       include 'COMMON.GEO'
9410       include 'COMMON.FFIELD'
9411       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9412      & auxvec1(2),auxmat1(2,2)
9413       logical swap
9414 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9415 C                                                                              C
9416 C      Parallel       Antiparallel                                             C
9417 C                                                                              C
9418 C          o             o                                                     C
9419 C         /l\   /   \   /j\                                                    C
9420 C        /   \ /     \ /   \                                                   C
9421 C       /| o |o       o| o |\                                                  C
9422 C     \ j|/k\|      \  |/k\|l                                                  C
9423 C      \ /   \       \ /   \                                                   C
9424 C       o     \       o     \                                                  C
9425 C       i             i                                                        C
9426 C                                                                              C
9427 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9428 C
9429 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9430 C           energy moment and not to the cluster cumulant.
9431 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9432       iti=itortyp(itype(i))
9433       itj=itortyp(itype(j))
9434       if (j.lt.nres-1) then
9435         itj1=itortyp(itype(j+1))
9436       else
9437         itj1=ntortyp
9438       endif
9439       itk=itortyp(itype(k))
9440       if (k.lt.nres-1) then
9441         itk1=itortyp(itype(k+1))
9442       else
9443         itk1=ntortyp
9444       endif
9445       itl=itortyp(itype(l))
9446       if (l.lt.nres-1) then
9447         itl1=itortyp(itype(l+1))
9448       else
9449         itl1=ntortyp
9450       endif
9451 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9452 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9453 cd     & ' itl',itl,' itl1',itl1
9454 #ifdef MOMENT
9455       if (imat.eq.1) then
9456         s1=dip(3,jj,i)*dip(3,kk,k)
9457       else
9458         s1=dip(2,jj,j)*dip(2,kk,l)
9459       endif
9460 #endif
9461       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9462       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9463       if (j.eq.l+1) then
9464         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9465         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9466       else
9467         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9468         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9469       endif
9470       call transpose2(EUg(1,1,k),auxmat(1,1))
9471       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9472       vv(1)=pizda(1,1)-pizda(2,2)
9473       vv(2)=pizda(2,1)+pizda(1,2)
9474       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9475 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9476 #ifdef MOMENT
9477       eello6_graph4=-(s1+s2+s3+s4)
9478 #else
9479       eello6_graph4=-(s2+s3+s4)
9480 #endif
9481 C Derivatives in gamma(i-1)
9482       if (i.gt.1) then
9483 #ifdef MOMENT
9484         if (imat.eq.1) then
9485           s1=dipderg(2,jj,i)*dip(3,kk,k)
9486         else
9487           s1=dipderg(4,jj,j)*dip(2,kk,l)
9488         endif
9489 #endif
9490         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9491         if (j.eq.l+1) then
9492           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9493           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9494         else
9495           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9496           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9497         endif
9498         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9499         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9500 cd          write (2,*) 'turn6 derivatives'
9501 #ifdef MOMENT
9502           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9503 #else
9504           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9505 #endif
9506         else
9507 #ifdef MOMENT
9508           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9509 #else
9510           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9511 #endif
9512         endif
9513       endif
9514 C Derivatives in gamma(k-1)
9515 #ifdef MOMENT
9516       if (imat.eq.1) then
9517         s1=dip(3,jj,i)*dipderg(2,kk,k)
9518       else
9519         s1=dip(2,jj,j)*dipderg(4,kk,l)
9520       endif
9521 #endif
9522       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9523       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9524       if (j.eq.l+1) then
9525         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9526         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9527       else
9528         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9529         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9530       endif
9531       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9532       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9533       vv(1)=pizda(1,1)-pizda(2,2)
9534       vv(2)=pizda(2,1)+pizda(1,2)
9535       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9536       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9537 #ifdef MOMENT
9538         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9539 #else
9540         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9541 #endif
9542       else
9543 #ifdef MOMENT
9544         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9545 #else
9546         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9547 #endif
9548       endif
9549 C Derivatives in gamma(j-1) or gamma(l-1)
9550       if (l.eq.j+1 .and. l.gt.1) then
9551         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9552         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9553         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9554         vv(1)=pizda(1,1)-pizda(2,2)
9555         vv(2)=pizda(2,1)+pizda(1,2)
9556         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9557         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9558       else if (j.gt.1) then
9559         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9560         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9561         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9562         vv(1)=pizda(1,1)-pizda(2,2)
9563         vv(2)=pizda(2,1)+pizda(1,2)
9564         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9565         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9566           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9567         else
9568           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9569         endif
9570       endif
9571 C Cartesian derivatives.
9572       do iii=1,2
9573         do kkk=1,5
9574           do lll=1,3
9575 #ifdef MOMENT
9576             if (iii.eq.1) then
9577               if (imat.eq.1) then
9578                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9579               else
9580                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9581               endif
9582             else
9583               if (imat.eq.1) then
9584                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9585               else
9586                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9587               endif
9588             endif
9589 #endif
9590             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9591      &        auxvec(1))
9592             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9593             if (j.eq.l+1) then
9594               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9595      &          b1(1,j+1),auxvec(1))
9596               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9597             else
9598               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9599      &          b1(1,l+1),auxvec(1))
9600               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9601             endif
9602             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9603      &        pizda(1,1))
9604             vv(1)=pizda(1,1)-pizda(2,2)
9605             vv(2)=pizda(2,1)+pizda(1,2)
9606             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9607             if (swap) then
9608               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9609 #ifdef MOMENT
9610                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9611      &             -(s1+s2+s4)
9612 #else
9613                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9614      &             -(s2+s4)
9615 #endif
9616                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9617               else
9618 #ifdef MOMENT
9619                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9620 #else
9621                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9622 #endif
9623                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9624               endif
9625             else
9626 #ifdef MOMENT
9627               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9628 #else
9629               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9630 #endif
9631               if (l.eq.j+1) then
9632                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9633               else
9634                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9635               endif
9636             endif
9637           enddo
9638         enddo
9639       enddo
9640       return
9641       end
9642 c----------------------------------------------------------------------------
9643       double precision function eello_turn6(i,jj,kk)
9644       implicit real*8 (a-h,o-z)
9645       include 'DIMENSIONS'
9646       include 'COMMON.IOUNITS'
9647       include 'COMMON.CHAIN'
9648       include 'COMMON.DERIV'
9649       include 'COMMON.INTERACT'
9650       include 'COMMON.CONTACTS'
9651       include 'COMMON.TORSION'
9652       include 'COMMON.VAR'
9653       include 'COMMON.GEO'
9654       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9655      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9656      &  ggg1(3),ggg2(3)
9657       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9658      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9659 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9660 C           the respective energy moment and not to the cluster cumulant.
9661       s1=0.0d0
9662       s8=0.0d0
9663       s13=0.0d0
9664 c
9665       eello_turn6=0.0d0
9666       j=i+4
9667       k=i+1
9668       l=i+3
9669       iti=itortyp(itype(i))
9670       itk=itortyp(itype(k))
9671       itk1=itortyp(itype(k+1))
9672       itl=itortyp(itype(l))
9673       itj=itortyp(itype(j))
9674 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9675 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9676 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9677 cd        eello6=0.0d0
9678 cd        return
9679 cd      endif
9680 cd      write (iout,*)
9681 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9682 cd     &   ' and',k,l
9683 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9684       do iii=1,2
9685         do kkk=1,5
9686           do lll=1,3
9687             derx_turn(lll,kkk,iii)=0.0d0
9688           enddo
9689         enddo
9690       enddo
9691 cd      eij=1.0d0
9692 cd      ekl=1.0d0
9693 cd      ekont=1.0d0
9694       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9695 cd      eello6_5=0.0d0
9696 cd      write (2,*) 'eello6_5',eello6_5
9697 #ifdef MOMENT
9698       call transpose2(AEA(1,1,1),auxmat(1,1))
9699       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9700       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9701       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9702 #endif
9703       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9704       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9705       s2 = scalar2(b1(1,k),vtemp1(1))
9706 #ifdef MOMENT
9707       call transpose2(AEA(1,1,2),atemp(1,1))
9708       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9709       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9710       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9711 #endif
9712       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9713       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9714       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9715 #ifdef MOMENT
9716       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9717       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9718       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9719       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9720       ss13 = scalar2(b1(1,k),vtemp4(1))
9721       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9722 #endif
9723 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9724 c      s1=0.0d0
9725 c      s2=0.0d0
9726 c      s8=0.0d0
9727 c      s12=0.0d0
9728 c      s13=0.0d0
9729       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9730 C Derivatives in gamma(i+2)
9731       s1d =0.0d0
9732       s8d =0.0d0
9733 #ifdef MOMENT
9734       call transpose2(AEA(1,1,1),auxmatd(1,1))
9735       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9736       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9737       call transpose2(AEAderg(1,1,2),atempd(1,1))
9738       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9739       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9740 #endif
9741       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9742       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9743       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9744 c      s1d=0.0d0
9745 c      s2d=0.0d0
9746 c      s8d=0.0d0
9747 c      s12d=0.0d0
9748 c      s13d=0.0d0
9749       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9750 C Derivatives in gamma(i+3)
9751 #ifdef MOMENT
9752       call transpose2(AEA(1,1,1),auxmatd(1,1))
9753       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9754       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9755       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9756 #endif
9757       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9758       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9759       s2d = scalar2(b1(1,k),vtemp1d(1))
9760 #ifdef MOMENT
9761       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9762       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9763 #endif
9764       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9765 #ifdef MOMENT
9766       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9767       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9768       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9769 #endif
9770 c      s1d=0.0d0
9771 c      s2d=0.0d0
9772 c      s8d=0.0d0
9773 c      s12d=0.0d0
9774 c      s13d=0.0d0
9775 #ifdef MOMENT
9776       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9777      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9778 #else
9779       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9780      &               -0.5d0*ekont*(s2d+s12d)
9781 #endif
9782 C Derivatives in gamma(i+4)
9783       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9784       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9785       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9786 #ifdef MOMENT
9787       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9788       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9789       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9790 #endif
9791 c      s1d=0.0d0
9792 c      s2d=0.0d0
9793 c      s8d=0.0d0
9794 C      s12d=0.0d0
9795 c      s13d=0.0d0
9796 #ifdef MOMENT
9797       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9798 #else
9799       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9800 #endif
9801 C Derivatives in gamma(i+5)
9802 #ifdef MOMENT
9803       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9804       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9805       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9806 #endif
9807       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9808       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9809       s2d = scalar2(b1(1,k),vtemp1d(1))
9810 #ifdef MOMENT
9811       call transpose2(AEA(1,1,2),atempd(1,1))
9812       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9813       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9814 #endif
9815       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9816       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9817 #ifdef MOMENT
9818       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9819       ss13d = scalar2(b1(1,k),vtemp4d(1))
9820       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9821 #endif
9822 c      s1d=0.0d0
9823 c      s2d=0.0d0
9824 c      s8d=0.0d0
9825 c      s12d=0.0d0
9826 c      s13d=0.0d0
9827 #ifdef MOMENT
9828       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9829      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9830 #else
9831       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9832      &               -0.5d0*ekont*(s2d+s12d)
9833 #endif
9834 C Cartesian derivatives
9835       do iii=1,2
9836         do kkk=1,5
9837           do lll=1,3
9838 #ifdef MOMENT
9839             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9840             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9841             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9842 #endif
9843             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9844             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9845      &          vtemp1d(1))
9846             s2d = scalar2(b1(1,k),vtemp1d(1))
9847 #ifdef MOMENT
9848             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9849             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9850             s8d = -(atempd(1,1)+atempd(2,2))*
9851      &           scalar2(cc(1,1,itl),vtemp2(1))
9852 #endif
9853             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9854      &           auxmatd(1,1))
9855             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9856             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9857 c      s1d=0.0d0
9858 c      s2d=0.0d0
9859 c      s8d=0.0d0
9860 c      s12d=0.0d0
9861 c      s13d=0.0d0
9862 #ifdef MOMENT
9863             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9864      &        - 0.5d0*(s1d+s2d)
9865 #else
9866             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9867      &        - 0.5d0*s2d
9868 #endif
9869 #ifdef MOMENT
9870             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9871      &        - 0.5d0*(s8d+s12d)
9872 #else
9873             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9874      &        - 0.5d0*s12d
9875 #endif
9876           enddo
9877         enddo
9878       enddo
9879 #ifdef MOMENT
9880       do kkk=1,5
9881         do lll=1,3
9882           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9883      &      achuj_tempd(1,1))
9884           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9885           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9886           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9887           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9888           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9889      &      vtemp4d(1))
9890           ss13d = scalar2(b1(1,k),vtemp4d(1))
9891           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9892           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9893         enddo
9894       enddo
9895 #endif
9896 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9897 cd     &  16*eel_turn6_num
9898 cd      goto 1112
9899       if (j.lt.nres-1) then
9900         j1=j+1
9901         j2=j-1
9902       else
9903         j1=j-1
9904         j2=j-2
9905       endif
9906       if (l.lt.nres-1) then
9907         l1=l+1
9908         l2=l-1
9909       else
9910         l1=l-1
9911         l2=l-2
9912       endif
9913       do ll=1,3
9914 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9915 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9916 cgrad        ghalf=0.5d0*ggg1(ll)
9917 cd        ghalf=0.0d0
9918         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9919         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9920         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9921      &    +ekont*derx_turn(ll,2,1)
9922         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9923         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9924      &    +ekont*derx_turn(ll,4,1)
9925         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9926         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9927         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9928 cgrad        ghalf=0.5d0*ggg2(ll)
9929 cd        ghalf=0.0d0
9930         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9931      &    +ekont*derx_turn(ll,2,2)
9932         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9933         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9934      &    +ekont*derx_turn(ll,4,2)
9935         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9936         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9937         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9938       enddo
9939 cd      goto 1112
9940 cgrad      do m=i+1,j-1
9941 cgrad        do ll=1,3
9942 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9943 cgrad        enddo
9944 cgrad      enddo
9945 cgrad      do m=k+1,l-1
9946 cgrad        do ll=1,3
9947 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9948 cgrad        enddo
9949 cgrad      enddo
9950 cgrad1112  continue
9951 cgrad      do m=i+2,j2
9952 cgrad        do ll=1,3
9953 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9954 cgrad        enddo
9955 cgrad      enddo
9956 cgrad      do m=k+2,l2
9957 cgrad        do ll=1,3
9958 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9959 cgrad        enddo
9960 cgrad      enddo
9961 cd      do iii=1,nres-3
9962 cd        write (2,*) iii,g_corr6_loc(iii)
9963 cd      enddo
9964       eello_turn6=ekont*eel_turn6
9965 cd      write (2,*) 'ekont',ekont
9966 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9967       return
9968       end
9969
9970 C-----------------------------------------------------------------------------
9971       double precision function scalar(u,v)
9972 !DIR$ INLINEALWAYS scalar
9973 #ifndef OSF
9974 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9975 #endif
9976       implicit none
9977       double precision u(3),v(3)
9978 cd      double precision sc
9979 cd      integer i
9980 cd      sc=0.0d0
9981 cd      do i=1,3
9982 cd        sc=sc+u(i)*v(i)
9983 cd      enddo
9984 cd      scalar=sc
9985
9986       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9987       return
9988       end
9989 crc-------------------------------------------------
9990       SUBROUTINE MATVEC2(A1,V1,V2)
9991 !DIR$ INLINEALWAYS MATVEC2
9992 #ifndef OSF
9993 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9994 #endif
9995       implicit real*8 (a-h,o-z)
9996       include 'DIMENSIONS'
9997       DIMENSION A1(2,2),V1(2),V2(2)
9998 c      DO 1 I=1,2
9999 c        VI=0.0
10000 c        DO 3 K=1,2
10001 c    3     VI=VI+A1(I,K)*V1(K)
10002 c        Vaux(I)=VI
10003 c    1 CONTINUE
10004
10005       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10006       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10007
10008       v2(1)=vaux1
10009       v2(2)=vaux2
10010       END
10011 C---------------------------------------
10012       SUBROUTINE MATMAT2(A1,A2,A3)
10013 #ifndef OSF
10014 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10015 #endif
10016       implicit real*8 (a-h,o-z)
10017       include 'DIMENSIONS'
10018       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10019 c      DIMENSION AI3(2,2)
10020 c        DO  J=1,2
10021 c          A3IJ=0.0
10022 c          DO K=1,2
10023 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10024 c          enddo
10025 c          A3(I,J)=A3IJ
10026 c       enddo
10027 c      enddo
10028
10029       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10030       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10031       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10032       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10033
10034       A3(1,1)=AI3_11
10035       A3(2,1)=AI3_21
10036       A3(1,2)=AI3_12
10037       A3(2,2)=AI3_22
10038       END
10039
10040 c-------------------------------------------------------------------------
10041       double precision function scalar2(u,v)
10042 !DIR$ INLINEALWAYS scalar2
10043       implicit none
10044       double precision u(2),v(2)
10045       double precision sc
10046       integer i
10047       scalar2=u(1)*v(1)+u(2)*v(2)
10048       return
10049       end
10050
10051 C-----------------------------------------------------------------------------
10052
10053       subroutine transpose2(a,at)
10054 !DIR$ INLINEALWAYS transpose2
10055 #ifndef OSF
10056 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10057 #endif
10058       implicit none
10059       double precision a(2,2),at(2,2)
10060       at(1,1)=a(1,1)
10061       at(1,2)=a(2,1)
10062       at(2,1)=a(1,2)
10063       at(2,2)=a(2,2)
10064       return
10065       end
10066 c--------------------------------------------------------------------------
10067       subroutine transpose(n,a,at)
10068       implicit none
10069       integer n,i,j
10070       double precision a(n,n),at(n,n)
10071       do i=1,n
10072         do j=1,n
10073           at(j,i)=a(i,j)
10074         enddo
10075       enddo
10076       return
10077       end
10078 C---------------------------------------------------------------------------
10079       subroutine prodmat3(a1,a2,kk,transp,prod)
10080 !DIR$ INLINEALWAYS prodmat3
10081 #ifndef OSF
10082 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10083 #endif
10084       implicit none
10085       integer i,j
10086       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10087       logical transp
10088 crc      double precision auxmat(2,2),prod_(2,2)
10089
10090       if (transp) then
10091 crc        call transpose2(kk(1,1),auxmat(1,1))
10092 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10093 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10094
10095            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10096      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10097            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10098      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10099            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10100      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10101            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10102      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10103
10104       else
10105 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10106 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10107
10108            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10109      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10110            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10111      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10112            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10113      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10114            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10115      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10116
10117       endif
10118 c      call transpose2(a2(1,1),a2t(1,1))
10119
10120 crc      print *,transp
10121 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10122 crc      print *,((prod(i,j),i=1,2),j=1,2)
10123
10124       return
10125       end
10126 CCC----------------------------------------------
10127       subroutine Eliptransfer(eliptran)
10128       implicit real*8 (a-h,o-z)
10129       include 'DIMENSIONS'
10130       include 'COMMON.GEO'
10131       include 'COMMON.VAR'
10132       include 'COMMON.LOCAL'
10133       include 'COMMON.CHAIN'
10134       include 'COMMON.DERIV'
10135       include 'COMMON.NAMES'
10136       include 'COMMON.INTERACT'
10137       include 'COMMON.IOUNITS'
10138       include 'COMMON.CALC'
10139       include 'COMMON.CONTROL'
10140       include 'COMMON.SPLITELE'
10141       include 'COMMON.SBRIDGE'
10142 C this is done by Adasko
10143 C      print *,"wchodze"
10144 C structure of box:
10145 C      water
10146 C--bordliptop-- buffore starts
10147 C--bufliptop--- here true lipid starts
10148 C      lipid
10149 C--buflipbot--- lipid ends buffore starts
10150 C--bordlipbot--buffore ends
10151       eliptran=0.0
10152       do i=ilip_start,ilip_end
10153 C       do i=1,1
10154         if (itype(i).eq.ntyp1) cycle
10155
10156         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10157         if (positi.le.0) positi=positi+boxzsize
10158 C        print *,i
10159 C first for peptide groups
10160 c for each residue check if it is in lipid or lipid water border area
10161        if ((positi.gt.bordlipbot)
10162      &.and.(positi.lt.bordliptop)) then
10163 C the energy transfer exist
10164         if (positi.lt.buflipbot) then
10165 C what fraction I am in
10166          fracinbuf=1.0d0-
10167      &        ((positi-bordlipbot)/lipbufthick)
10168 C lipbufthick is thickenes of lipid buffore
10169          sslip=sscalelip(fracinbuf)
10170          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10171          eliptran=eliptran+sslip*pepliptran
10172          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10173          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10174 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10175
10176 C        print *,"doing sccale for lower part"
10177 C         print *,i,sslip,fracinbuf,ssgradlip
10178         elseif (positi.gt.bufliptop) then
10179          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10180          sslip=sscalelip(fracinbuf)
10181          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10182          eliptran=eliptran+sslip*pepliptran
10183          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10184          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10185 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10186 C          print *, "doing sscalefor top part"
10187 C         print *,i,sslip,fracinbuf,ssgradlip
10188         else
10189          eliptran=eliptran+pepliptran
10190 C         print *,"I am in true lipid"
10191         endif
10192 C       else
10193 C       eliptran=elpitran+0.0 ! I am in water
10194        endif
10195        enddo
10196 C       print *, "nic nie bylo w lipidzie?"
10197 C now multiply all by the peptide group transfer factor
10198 C       eliptran=eliptran*pepliptran
10199 C now the same for side chains
10200 CV       do i=1,1
10201        do i=ilip_start,ilip_end
10202         if (itype(i).eq.ntyp1) cycle
10203         positi=(mod(c(3,i+nres),boxzsize))
10204         if (positi.le.0) positi=positi+boxzsize
10205 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10206 c for each residue check if it is in lipid or lipid water border area
10207 C       respos=mod(c(3,i+nres),boxzsize)
10208 C       print *,positi,bordlipbot,buflipbot
10209        if ((positi.gt.bordlipbot)
10210      & .and.(positi.lt.bordliptop)) then
10211 C the energy transfer exist
10212         if (positi.lt.buflipbot) then
10213          fracinbuf=1.0d0-
10214      &     ((positi-bordlipbot)/lipbufthick)
10215 C lipbufthick is thickenes of lipid buffore
10216          sslip=sscalelip(fracinbuf)
10217          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10218          eliptran=eliptran+sslip*liptranene(itype(i))
10219          gliptranx(3,i)=gliptranx(3,i)
10220      &+ssgradlip*liptranene(itype(i))
10221          gliptranc(3,i-1)= gliptranc(3,i-1)
10222      &+ssgradlip*liptranene(itype(i))
10223 C         print *,"doing sccale for lower part"
10224         elseif (positi.gt.bufliptop) then
10225          fracinbuf=1.0d0-
10226      &((bordliptop-positi)/lipbufthick)
10227          sslip=sscalelip(fracinbuf)
10228          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10229          eliptran=eliptran+sslip*liptranene(itype(i))
10230          gliptranx(3,i)=gliptranx(3,i)
10231      &+ssgradlip*liptranene(itype(i))
10232          gliptranc(3,i-1)= gliptranc(3,i-1)
10233      &+ssgradlip*liptranene(itype(i))
10234 C          print *, "doing sscalefor top part",sslip,fracinbuf
10235         else
10236          eliptran=eliptran+liptranene(itype(i))
10237 C         print *,"I am in true lipid"
10238         endif
10239         endif ! if in lipid or buffor
10240 C       else
10241 C       eliptran=elpitran+0.0 ! I am in water
10242        enddo
10243        return
10244        end
10245 C---------------------------------------------------------
10246 C AFM soubroutine for constant force
10247        subroutine AFMforce(Eafmforce)
10248        implicit real*8 (a-h,o-z)
10249       include 'DIMENSIONS'
10250       include 'COMMON.GEO'
10251       include 'COMMON.VAR'
10252       include 'COMMON.LOCAL'
10253       include 'COMMON.CHAIN'
10254       include 'COMMON.DERIV'
10255       include 'COMMON.NAMES'
10256       include 'COMMON.INTERACT'
10257       include 'COMMON.IOUNITS'
10258       include 'COMMON.CALC'
10259       include 'COMMON.CONTROL'
10260       include 'COMMON.SPLITELE'
10261       include 'COMMON.SBRIDGE'
10262       real*8 diffafm(3)
10263       dist=0.0d0
10264       Eafmforce=0.0d0
10265       do i=1,3
10266       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10267       dist=dist+diffafm(i)**2
10268       enddo
10269       dist=dsqrt(dist)
10270       Eafmforce=-forceAFMconst*(dist-distafminit)
10271       do i=1,3
10272       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10273       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10274       enddo
10275 C      print *,'AFM',Eafmforce
10276       return
10277       end
10278 C---------------------------------------------------------
10279 C AFM subroutine with pseudoconstant velocity
10280        subroutine AFMvel(Eafmforce)
10281        implicit real*8 (a-h,o-z)
10282       include 'DIMENSIONS'
10283       include 'COMMON.GEO'
10284       include 'COMMON.VAR'
10285       include 'COMMON.LOCAL'
10286       include 'COMMON.CHAIN'
10287       include 'COMMON.DERIV'
10288       include 'COMMON.NAMES'
10289       include 'COMMON.INTERACT'
10290       include 'COMMON.IOUNITS'
10291       include 'COMMON.CALC'
10292       include 'COMMON.CONTROL'
10293       include 'COMMON.SPLITELE'
10294       include 'COMMON.SBRIDGE'
10295       real*8 diffafm(3)
10296 C Only for check grad COMMENT if not used for checkgrad
10297 C      totT=3.0d0
10298 C--------------------------------------------------------
10299 C      print *,"wchodze"
10300       dist=0.0d0
10301       Eafmforce=0.0d0
10302       do i=1,3
10303       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10304       dist=dist+diffafm(i)**2
10305       enddo
10306       dist=dsqrt(dist)
10307       Eafmforce=0.5d0*forceAFMconst
10308      & *(distafminit+totTafm*velAFMconst-dist)**2
10309 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10310       do i=1,3
10311       gradafm(i,afmend-1)=-forceAFMconst*
10312      &(distafminit+totTafm*velAFMconst-dist)
10313      &*diffafm(i)/dist
10314       gradafm(i,afmbeg-1)=forceAFMconst*
10315      &(distafminit+totTafm*velAFMconst-dist)
10316      &*diffafm(i)/dist
10317       enddo
10318 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10319       return
10320       end
10321