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         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164      &   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         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2723           iti = itortyp(itype(i-2))
2724         else
2725           iti=ntortyp+1
2726         endif
2727 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2728         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2729           iti1 = itortyp(itype(i-1))
2730         else
2731           iti1=ntortyp+1
2732         endif
2733         b1(1,i-2)=b(3,iti)
2734         b1(2,i-2)=b(5,iti)
2735         b2(1,i-2)=b(2,iti)
2736         b2(2,i-2)=b(4,iti)
2737        b1tilde(1,i-2)=b1(1,i-2)
2738        b1tilde(2,i-2)=-b1(2,i-2)
2739        b2tilde(1,i-2)=b2(1,i-2)
2740        b2tilde(2,i-2)=-b2(2,i-2)
2741         EE(1,2,i-2)=eeold(1,2,iti)
2742         EE(2,1,i-2)=eeold(2,1,iti)
2743         EE(2,2,i-2)=eeold(2,2,iti)
2744         EE(1,1,i-2)=eeold(1,1,iti)
2745       enddo
2746 #endif
2747 #ifdef PARMAT
2748       do i=ivec_start+2,ivec_end+2
2749 #else
2750       do i=3,nres+1
2751 #endif
2752         if (i .lt. nres+1) then
2753           sin1=dsin(phi(i))
2754           cos1=dcos(phi(i))
2755           sintab(i-2)=sin1
2756           costab(i-2)=cos1
2757           obrot(1,i-2)=cos1
2758           obrot(2,i-2)=sin1
2759           sin2=dsin(2*phi(i))
2760           cos2=dcos(2*phi(i))
2761           sintab2(i-2)=sin2
2762           costab2(i-2)=cos2
2763           obrot2(1,i-2)=cos2
2764           obrot2(2,i-2)=sin2
2765           Ug(1,1,i-2)=-cos1
2766           Ug(1,2,i-2)=-sin1
2767           Ug(2,1,i-2)=-sin1
2768           Ug(2,2,i-2)= cos1
2769           Ug2(1,1,i-2)=-cos2
2770           Ug2(1,2,i-2)=-sin2
2771           Ug2(2,1,i-2)=-sin2
2772           Ug2(2,2,i-2)= cos2
2773         else
2774           costab(i-2)=1.0d0
2775           sintab(i-2)=0.0d0
2776           obrot(1,i-2)=1.0d0
2777           obrot(2,i-2)=0.0d0
2778           obrot2(1,i-2)=0.0d0
2779           obrot2(2,i-2)=0.0d0
2780           Ug(1,1,i-2)=1.0d0
2781           Ug(1,2,i-2)=0.0d0
2782           Ug(2,1,i-2)=0.0d0
2783           Ug(2,2,i-2)=1.0d0
2784           Ug2(1,1,i-2)=0.0d0
2785           Ug2(1,2,i-2)=0.0d0
2786           Ug2(2,1,i-2)=0.0d0
2787           Ug2(2,2,i-2)=0.0d0
2788         endif
2789         if (i .gt. 3 .and. i .lt. nres+1) then
2790           obrot_der(1,i-2)=-sin1
2791           obrot_der(2,i-2)= cos1
2792           Ugder(1,1,i-2)= sin1
2793           Ugder(1,2,i-2)=-cos1
2794           Ugder(2,1,i-2)=-cos1
2795           Ugder(2,2,i-2)=-sin1
2796           dwacos2=cos2+cos2
2797           dwasin2=sin2+sin2
2798           obrot2_der(1,i-2)=-dwasin2
2799           obrot2_der(2,i-2)= dwacos2
2800           Ug2der(1,1,i-2)= dwasin2
2801           Ug2der(1,2,i-2)=-dwacos2
2802           Ug2der(2,1,i-2)=-dwacos2
2803           Ug2der(2,2,i-2)=-dwasin2
2804         else
2805           obrot_der(1,i-2)=0.0d0
2806           obrot_der(2,i-2)=0.0d0
2807           Ugder(1,1,i-2)=0.0d0
2808           Ugder(1,2,i-2)=0.0d0
2809           Ugder(2,1,i-2)=0.0d0
2810           Ugder(2,2,i-2)=0.0d0
2811           obrot2_der(1,i-2)=0.0d0
2812           obrot2_der(2,i-2)=0.0d0
2813           Ug2der(1,1,i-2)=0.0d0
2814           Ug2der(1,2,i-2)=0.0d0
2815           Ug2der(2,1,i-2)=0.0d0
2816           Ug2der(2,2,i-2)=0.0d0
2817         endif
2818 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2819         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2820           iti = itortyp(itype(i-2))
2821         else
2822           iti=ntortyp
2823         endif
2824 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2825         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2826           iti1 = itortyp(itype(i-1))
2827         else
2828           iti1=ntortyp
2829         endif
2830 cd        write (iout,*) '*******i',i,' iti1',iti
2831 cd        write (iout,*) 'b1',b1(:,iti)
2832 cd        write (iout,*) 'b2',b2(:,iti)
2833 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2834 c        if (i .gt. iatel_s+2) then
2835         if (i .gt. nnt+2) then
2836           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2837 #ifdef NEWCORR
2838           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2839 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2840 #endif
2841 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2842 c     &    EE(1,2,iti),EE(2,2,iti)
2843           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2844           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2845 c          write(iout,*) "Macierz EUG",
2846 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2847 c     &    eug(2,2,i-2)
2848           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2849      &    then
2850           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2851           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2852           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2853           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2854           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2855           endif
2856         else
2857           do k=1,2
2858             Ub2(k,i-2)=0.0d0
2859             Ctobr(k,i-2)=0.0d0
2860             Dtobr2(k,i-2)=0.0d0
2861             do l=1,2
2862               EUg(l,k,i-2)=0.0d0
2863               CUg(l,k,i-2)=0.0d0
2864               DUg(l,k,i-2)=0.0d0
2865               DtUg2(l,k,i-2)=0.0d0
2866             enddo
2867           enddo
2868         endif
2869         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2870         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2871         do k=1,2
2872           muder(k,i-2)=Ub2der(k,i-2)
2873         enddo
2874 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2875         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2876           if (itype(i-1).le.ntyp) then
2877             iti1 = itortyp(itype(i-1))
2878           else
2879             iti1=ntortyp
2880           endif
2881         else
2882           iti1=ntortyp
2883         endif
2884         do k=1,2
2885           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2886         enddo
2887 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2888 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2889 cd        write (iout,*) 'mu1',mu1(:,i-2)
2890 cd        write (iout,*) 'mu2',mu2(:,i-2)
2891         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2892      &  then
2893         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2894         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2895         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2896         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2897         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2898 C Vectors and matrices dependent on a single virtual-bond dihedral.
2899         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2900         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2901         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2902         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2903         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2904         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2905         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2906         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2907         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2908         endif
2909       enddo
2910 C Matrices dependent on two consecutive virtual-bond dihedrals.
2911 C The order of matrices is from left to right.
2912       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2913      &then
2914 c      do i=max0(ivec_start,2),ivec_end
2915       do i=2,nres-1
2916         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2917         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2918         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2919         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2920         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2921         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2922         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2923         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2924       enddo
2925       endif
2926 #if defined(MPI) && defined(PARMAT)
2927 #ifdef DEBUG
2928 c      if (fg_rank.eq.0) then
2929         write (iout,*) "Arrays UG and UGDER before GATHER"
2930         do i=1,nres-1
2931           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2932      &     ((ug(l,k,i),l=1,2),k=1,2),
2933      &     ((ugder(l,k,i),l=1,2),k=1,2)
2934         enddo
2935         write (iout,*) "Arrays UG2 and UG2DER"
2936         do i=1,nres-1
2937           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2938      &     ((ug2(l,k,i),l=1,2),k=1,2),
2939      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2940         enddo
2941         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2942         do i=1,nres-1
2943           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2944      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2945      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2946         enddo
2947         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2948         do i=1,nres-1
2949           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2950      &     costab(i),sintab(i),costab2(i),sintab2(i)
2951         enddo
2952         write (iout,*) "Array MUDER"
2953         do i=1,nres-1
2954           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2955         enddo
2956 c      endif
2957 #endif
2958       if (nfgtasks.gt.1) then
2959         time00=MPI_Wtime()
2960 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2961 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2962 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2963 #ifdef MATGATHER
2964         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2965      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2966      &   FG_COMM1,IERR)
2967         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2968      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2969      &   FG_COMM1,IERR)
2970         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2971      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2972      &   FG_COMM1,IERR)
2973         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2974      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2975      &   FG_COMM1,IERR)
2976         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2977      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2978      &   FG_COMM1,IERR)
2979         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2980      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2981      &   FG_COMM1,IERR)
2982         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2983      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2984      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2985         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2986      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2987      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2988         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2989      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2990      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2991         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2992      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2993      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2994         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2995      &  then
2996         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2997      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2998      &   FG_COMM1,IERR)
2999         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3000      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3001      &   FG_COMM1,IERR)
3002         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3003      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3004      &   FG_COMM1,IERR)
3005        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3006      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3007      &   FG_COMM1,IERR)
3008         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3009      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3010      &   FG_COMM1,IERR)
3011         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3012      &   ivec_count(fg_rank1),
3013      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3014      &   FG_COMM1,IERR)
3015         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3016      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3017      &   FG_COMM1,IERR)
3018         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3019      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3020      &   FG_COMM1,IERR)
3021         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3022      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3023      &   FG_COMM1,IERR)
3024         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3025      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3026      &   FG_COMM1,IERR)
3027         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3028      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3029      &   FG_COMM1,IERR)
3030         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3031      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3032      &   FG_COMM1,IERR)
3033         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3034      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3035      &   FG_COMM1,IERR)
3036         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3037      &   ivec_count(fg_rank1),
3038      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3042      &   FG_COMM1,IERR)
3043        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3048      &   FG_COMM1,IERR)
3049        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3050      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3051      &   FG_COMM1,IERR)
3052         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3053      &   ivec_count(fg_rank1),
3054      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3055      &   FG_COMM1,IERR)
3056         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3057      &   ivec_count(fg_rank1),
3058      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3061      &   ivec_count(fg_rank1),
3062      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3063      &   MPI_MAT2,FG_COMM1,IERR)
3064         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3065      &   ivec_count(fg_rank1),
3066      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3067      &   MPI_MAT2,FG_COMM1,IERR)
3068         endif
3069 #else
3070 c Passes matrix info through the ring
3071       isend=fg_rank1
3072       irecv=fg_rank1-1
3073       if (irecv.lt.0) irecv=nfgtasks1-1
3074       iprev=irecv
3075       inext=fg_rank1+1
3076       if (inext.ge.nfgtasks1) inext=0
3077       do i=1,nfgtasks1-1
3078 c        write (iout,*) "isend",isend," irecv",irecv
3079 c        call flush(iout)
3080         lensend=lentyp(isend)
3081         lenrecv=lentyp(irecv)
3082 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3083 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3084 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3085 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3086 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3087 c        write (iout,*) "Gather ROTAT1"
3088 c        call flush(iout)
3089 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3090 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3091 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3092 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3093 c        write (iout,*) "Gather ROTAT2"
3094 c        call flush(iout)
3095         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3096      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3097      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3098      &   iprev,4400+irecv,FG_COMM,status,IERR)
3099 c        write (iout,*) "Gather ROTAT_OLD"
3100 c        call flush(iout)
3101         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3102      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3103      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3104      &   iprev,5500+irecv,FG_COMM,status,IERR)
3105 c        write (iout,*) "Gather PRECOMP11"
3106 c        call flush(iout)
3107         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3108      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3109      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3110      &   iprev,6600+irecv,FG_COMM,status,IERR)
3111 c        write (iout,*) "Gather PRECOMP12"
3112 c        call flush(iout)
3113         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3114      &  then
3115         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3116      &   MPI_ROTAT2(lensend),inext,7700+isend,
3117      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3118      &   iprev,7700+irecv,FG_COMM,status,IERR)
3119 c        write (iout,*) "Gather PRECOMP21"
3120 c        call flush(iout)
3121         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3122      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3123      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3124      &   iprev,8800+irecv,FG_COMM,status,IERR)
3125 c        write (iout,*) "Gather PRECOMP22"
3126 c        call flush(iout)
3127         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3128      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3129      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3130      &   MPI_PRECOMP23(lenrecv),
3131      &   iprev,9900+irecv,FG_COMM,status,IERR)
3132 c        write (iout,*) "Gather PRECOMP23"
3133 c        call flush(iout)
3134         endif
3135         isend=irecv
3136         irecv=irecv-1
3137         if (irecv.lt.0) irecv=nfgtasks1-1
3138       enddo
3139 #endif
3140         time_gather=time_gather+MPI_Wtime()-time00
3141       endif
3142 #ifdef DEBUG
3143 c      if (fg_rank.eq.0) then
3144         write (iout,*) "Arrays UG and UGDER"
3145         do i=1,nres-1
3146           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3147      &     ((ug(l,k,i),l=1,2),k=1,2),
3148      &     ((ugder(l,k,i),l=1,2),k=1,2)
3149         enddo
3150         write (iout,*) "Arrays UG2 and UG2DER"
3151         do i=1,nres-1
3152           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3153      &     ((ug2(l,k,i),l=1,2),k=1,2),
3154      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3155         enddo
3156         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3157         do i=1,nres-1
3158           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3159      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3160      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3161         enddo
3162         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3163         do i=1,nres-1
3164           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3165      &     costab(i),sintab(i),costab2(i),sintab2(i)
3166         enddo
3167         write (iout,*) "Array MUDER"
3168         do i=1,nres-1
3169           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3170         enddo
3171 c      endif
3172 #endif
3173 #endif
3174 cd      do i=1,nres
3175 cd        iti = itortyp(itype(i))
3176 cd        write (iout,*) i
3177 cd        do j=1,2
3178 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3179 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3180 cd        enddo
3181 cd      enddo
3182       return
3183       end
3184 C--------------------------------------------------------------------------
3185       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3186 C
3187 C This subroutine calculates the average interaction energy and its gradient
3188 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3189 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3190 C The potential depends both on the distance of peptide-group centers and on
3191 C the orientation of the CA-CA virtual bonds.
3192 C
3193       implicit real*8 (a-h,o-z)
3194 #ifdef MPI
3195       include 'mpif.h'
3196 #endif
3197       include 'DIMENSIONS'
3198       include 'COMMON.CONTROL'
3199       include 'COMMON.SETUP'
3200       include 'COMMON.IOUNITS'
3201       include 'COMMON.GEO'
3202       include 'COMMON.VAR'
3203       include 'COMMON.LOCAL'
3204       include 'COMMON.CHAIN'
3205       include 'COMMON.DERIV'
3206       include 'COMMON.INTERACT'
3207       include 'COMMON.CONTACTS'
3208       include 'COMMON.TORSION'
3209       include 'COMMON.VECTORS'
3210       include 'COMMON.FFIELD'
3211       include 'COMMON.TIME1'
3212       include 'COMMON.SPLITELE'
3213       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3214      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3215       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3216      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3217       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3218      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3219      &    num_conti,j1,j2
3220 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3221 #ifdef MOMENT
3222       double precision scal_el /1.0d0/
3223 #else
3224       double precision scal_el /0.5d0/
3225 #endif
3226 C 12/13/98
3227 C 13-go grudnia roku pamietnego...
3228       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3229      &                   0.0d0,1.0d0,0.0d0,
3230      &                   0.0d0,0.0d0,1.0d0/
3231 cd      write(iout,*) 'In EELEC'
3232 cd      do i=1,nloctyp
3233 cd        write(iout,*) 'Type',i
3234 cd        write(iout,*) 'B1',B1(:,i)
3235 cd        write(iout,*) 'B2',B2(:,i)
3236 cd        write(iout,*) 'CC',CC(:,:,i)
3237 cd        write(iout,*) 'DD',DD(:,:,i)
3238 cd        write(iout,*) 'EE',EE(:,:,i)
3239 cd      enddo
3240 cd      call check_vecgrad
3241 cd      stop
3242       if (icheckgrad.eq.1) then
3243         do i=1,nres-1
3244           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3245           do k=1,3
3246             dc_norm(k,i)=dc(k,i)*fac
3247           enddo
3248 c          write (iout,*) 'i',i,' fac',fac
3249         enddo
3250       endif
3251       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3252      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3253      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3254 c        call vec_and_deriv
3255 #ifdef TIMING
3256         time01=MPI_Wtime()
3257 #endif
3258         call set_matrices
3259 #ifdef TIMING
3260         time_mat=time_mat+MPI_Wtime()-time01
3261 #endif
3262       endif
3263 cd      do i=1,nres-1
3264 cd        write (iout,*) 'i=',i
3265 cd        do k=1,3
3266 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3267 cd        enddo
3268 cd        do k=1,3
3269 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3270 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3271 cd        enddo
3272 cd      enddo
3273       t_eelecij=0.0d0
3274       ees=0.0D0
3275       evdw1=0.0D0
3276       eel_loc=0.0d0
3277       eello_turn3=0.0d0
3278       eello_turn4=0.0d0
3279       ind=0
3280       do i=1,nres
3281         num_cont_hb(i)=0
3282       enddo
3283 cd      print '(a)','Enter EELEC'
3284 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3285       do i=1,nres
3286         gel_loc_loc(i)=0.0d0
3287         gcorr_loc(i)=0.0d0
3288       enddo
3289 c
3290 c
3291 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3292 C
3293 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3294 C
3295 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3296       do i=iturn3_start,iturn3_end
3297         if (i.le.1) cycle
3298 C        write(iout,*) "tu jest i",i
3299         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3300 C changes suggested by Ana to avoid out of bounds
3301      & .or.((i+4).gt.nres)
3302      & .or.((i-1).le.0)
3303 C end of changes by Ana
3304      &  .or. itype(i+2).eq.ntyp1
3305      &  .or. itype(i+3).eq.ntyp1) cycle
3306         if(i.gt.1)then
3307           if(itype(i-1).eq.ntyp1)cycle
3308         end if
3309         if(i.LT.nres-3)then
3310           if (itype(i+4).eq.ntyp1) cycle
3311         end if
3312         dxi=dc(1,i)
3313         dyi=dc(2,i)
3314         dzi=dc(3,i)
3315         dx_normi=dc_norm(1,i)
3316         dy_normi=dc_norm(2,i)
3317         dz_normi=dc_norm(3,i)
3318         xmedi=c(1,i)+0.5d0*dxi
3319         ymedi=c(2,i)+0.5d0*dyi
3320         zmedi=c(3,i)+0.5d0*dzi
3321           xmedi=mod(xmedi,boxxsize)
3322           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3323           ymedi=mod(ymedi,boxysize)
3324           if (ymedi.lt.0) ymedi=ymedi+boxysize
3325           zmedi=mod(zmedi,boxzsize)
3326           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3327         num_conti=0
3328         call eelecij(i,i+2,ees,evdw1,eel_loc)
3329         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3330         num_cont_hb(i)=num_conti
3331       enddo
3332       do i=iturn4_start,iturn4_end
3333         if (i.le.1) cycle
3334         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3335 C changes suggested by Ana to avoid out of bounds
3336      & .or.((i+5).gt.nres)
3337      & .or.((i-1).le.0)
3338 C end of changes suggested by Ana
3339      &    .or. itype(i+3).eq.ntyp1
3340      &    .or. itype(i+4).eq.ntyp1
3341      &    .or. itype(i+5).eq.ntyp1
3342      &    .or. itype(i).eq.ntyp1
3343      &    .or. itype(i-1).eq.ntyp1
3344      &                             ) cycle
3345         dxi=dc(1,i)
3346         dyi=dc(2,i)
3347         dzi=dc(3,i)
3348         dx_normi=dc_norm(1,i)
3349         dy_normi=dc_norm(2,i)
3350         dz_normi=dc_norm(3,i)
3351         xmedi=c(1,i)+0.5d0*dxi
3352         ymedi=c(2,i)+0.5d0*dyi
3353         zmedi=c(3,i)+0.5d0*dzi
3354 C Return atom into box, boxxsize is size of box in x dimension
3355 c  194   continue
3356 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3357 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3358 C Condition for being inside the proper box
3359 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3360 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3361 c        go to 194
3362 c        endif
3363 c  195   continue
3364 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3365 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3366 C Condition for being inside the proper box
3367 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3368 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3369 c        go to 195
3370 c        endif
3371 c  196   continue
3372 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3373 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3374 C Condition for being inside the proper box
3375 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3376 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3377 c        go to 196
3378 c        endif
3379           xmedi=mod(xmedi,boxxsize)
3380           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3381           ymedi=mod(ymedi,boxysize)
3382           if (ymedi.lt.0) ymedi=ymedi+boxysize
3383           zmedi=mod(zmedi,boxzsize)
3384           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3385
3386         num_conti=num_cont_hb(i)
3387 c        write(iout,*) "JESTEM W PETLI"
3388         call eelecij(i,i+3,ees,evdw1,eel_loc)
3389         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3390      &   call eturn4(i,eello_turn4)
3391         num_cont_hb(i)=num_conti
3392       enddo   ! i
3393 C Loop over all neighbouring boxes
3394 C      do xshift=-1,1
3395 C      do yshift=-1,1
3396 C      do zshift=-1,1
3397 c
3398 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3399 c
3400       do i=iatel_s,iatel_e
3401         if (i.le.1) cycle
3402         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3403 C changes suggested by Ana to avoid out of bounds
3404      & .or.((i+2).gt.nres)
3405      & .or.((i-1).le.0)
3406 C end of changes by Ana
3407      &  .or. itype(i+2).eq.ntyp1
3408      &  .or. itype(i-1).eq.ntyp1
3409      &                ) cycle
3410         dxi=dc(1,i)
3411         dyi=dc(2,i)
3412         dzi=dc(3,i)
3413         dx_normi=dc_norm(1,i)
3414         dy_normi=dc_norm(2,i)
3415         dz_normi=dc_norm(3,i)
3416         xmedi=c(1,i)+0.5d0*dxi
3417         ymedi=c(2,i)+0.5d0*dyi
3418         zmedi=c(3,i)+0.5d0*dzi
3419           xmedi=mod(xmedi,boxxsize)
3420           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3421           ymedi=mod(ymedi,boxysize)
3422           if (ymedi.lt.0) ymedi=ymedi+boxysize
3423           zmedi=mod(zmedi,boxzsize)
3424           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3425 C          xmedi=xmedi+xshift*boxxsize
3426 C          ymedi=ymedi+yshift*boxysize
3427 C          zmedi=zmedi+zshift*boxzsize
3428
3429 C Return tom into box, boxxsize is size of box in x dimension
3430 c  164   continue
3431 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3432 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3433 C Condition for being inside the proper box
3434 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3435 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3436 c        go to 164
3437 c        endif
3438 c  165   continue
3439 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3440 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3441 C Condition for being inside the proper box
3442 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3443 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3444 c        go to 165
3445 c        endif
3446 c  166   continue
3447 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3448 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3449 cC Condition for being inside the proper box
3450 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3451 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3452 c        go to 166
3453 c        endif
3454
3455 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3456         num_conti=num_cont_hb(i)
3457         do j=ielstart(i),ielend(i)
3458 C          write (iout,*) i,j
3459          if (j.le.1) cycle
3460           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3461 C changes suggested by Ana to avoid out of bounds
3462      & .or.((j+2).gt.nres)
3463      & .or.((j-1).le.0)
3464 C end of changes by Ana
3465      & .or.itype(j+2).eq.ntyp1
3466      & .or.itype(j-1).eq.ntyp1
3467      &) cycle
3468           call eelecij(i,j,ees,evdw1,eel_loc)
3469         enddo ! j
3470         num_cont_hb(i)=num_conti
3471       enddo   ! i
3472 C     enddo   ! zshift
3473 C      enddo   ! yshift
3474 C      enddo   ! xshift
3475
3476 c      write (iout,*) "Number of loop steps in EELEC:",ind
3477 cd      do i=1,nres
3478 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3479 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3480 cd      enddo
3481 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3482 ccc      eel_loc=eel_loc+eello_turn3
3483 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3484       return
3485       end
3486 C-------------------------------------------------------------------------------
3487       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3488       implicit real*8 (a-h,o-z)
3489       include 'DIMENSIONS'
3490 #ifdef MPI
3491       include "mpif.h"
3492 #endif
3493       include 'COMMON.CONTROL'
3494       include 'COMMON.IOUNITS'
3495       include 'COMMON.GEO'
3496       include 'COMMON.VAR'
3497       include 'COMMON.LOCAL'
3498       include 'COMMON.CHAIN'
3499       include 'COMMON.DERIV'
3500       include 'COMMON.INTERACT'
3501       include 'COMMON.CONTACTS'
3502       include 'COMMON.TORSION'
3503       include 'COMMON.VECTORS'
3504       include 'COMMON.FFIELD'
3505       include 'COMMON.TIME1'
3506       include 'COMMON.SPLITELE'
3507       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3508      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3509       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3510      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3511      &    gmuij2(4),gmuji2(4)
3512       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3513      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3514      &    num_conti,j1,j2
3515 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3516 #ifdef MOMENT
3517       double precision scal_el /1.0d0/
3518 #else
3519       double precision scal_el /0.5d0/
3520 #endif
3521 C 12/13/98
3522 C 13-go grudnia roku pamietnego...
3523       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3524      &                   0.0d0,1.0d0,0.0d0,
3525      &                   0.0d0,0.0d0,1.0d0/
3526 c          time00=MPI_Wtime()
3527 cd      write (iout,*) "eelecij",i,j
3528 c          ind=ind+1
3529           iteli=itel(i)
3530           itelj=itel(j)
3531           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3532           aaa=app(iteli,itelj)
3533           bbb=bpp(iteli,itelj)
3534           ael6i=ael6(iteli,itelj)
3535           ael3i=ael3(iteli,itelj)
3536           dxj=dc(1,j)
3537           dyj=dc(2,j)
3538           dzj=dc(3,j)
3539           dx_normj=dc_norm(1,j)
3540           dy_normj=dc_norm(2,j)
3541           dz_normj=dc_norm(3,j)
3542 C          xj=c(1,j)+0.5D0*dxj-xmedi
3543 C          yj=c(2,j)+0.5D0*dyj-ymedi
3544 C          zj=c(3,j)+0.5D0*dzj-zmedi
3545           xj=c(1,j)+0.5D0*dxj
3546           yj=c(2,j)+0.5D0*dyj
3547           zj=c(3,j)+0.5D0*dzj
3548           xj=mod(xj,boxxsize)
3549           if (xj.lt.0) xj=xj+boxxsize
3550           yj=mod(yj,boxysize)
3551           if (yj.lt.0) yj=yj+boxysize
3552           zj=mod(zj,boxzsize)
3553           if (zj.lt.0) zj=zj+boxzsize
3554           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3555       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3556       xj_safe=xj
3557       yj_safe=yj
3558       zj_safe=zj
3559       isubchap=0
3560       do xshift=-1,1
3561       do yshift=-1,1
3562       do zshift=-1,1
3563           xj=xj_safe+xshift*boxxsize
3564           yj=yj_safe+yshift*boxysize
3565           zj=zj_safe+zshift*boxzsize
3566           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3567           if(dist_temp.lt.dist_init) then
3568             dist_init=dist_temp
3569             xj_temp=xj
3570             yj_temp=yj
3571             zj_temp=zj
3572             isubchap=1
3573           endif
3574        enddo
3575        enddo
3576        enddo
3577        if (isubchap.eq.1) then
3578           xj=xj_temp-xmedi
3579           yj=yj_temp-ymedi
3580           zj=zj_temp-zmedi
3581        else
3582           xj=xj_safe-xmedi
3583           yj=yj_safe-ymedi
3584           zj=zj_safe-zmedi
3585        endif
3586 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3587 c  174   continue
3588 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3589 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3590 C Condition for being inside the proper box
3591 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3592 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3593 c        go to 174
3594 c        endif
3595 c  175   continue
3596 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3597 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3598 C Condition for being inside the proper box
3599 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3600 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3601 c        go to 175
3602 c        endif
3603 c  176   continue
3604 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3605 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3606 C Condition for being inside the proper box
3607 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3608 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3609 c        go to 176
3610 c        endif
3611 C        endif !endPBC condintion
3612 C        xj=xj-xmedi
3613 C        yj=yj-ymedi
3614 C        zj=zj-zmedi
3615           rij=xj*xj+yj*yj+zj*zj
3616
3617             sss=sscale(sqrt(rij))
3618             sssgrad=sscagrad(sqrt(rij))
3619 c            if (sss.gt.0.0d0) then
3620           rrmij=1.0D0/rij
3621           rij=dsqrt(rij)
3622           rmij=1.0D0/rij
3623           r3ij=rrmij*rmij
3624           r6ij=r3ij*r3ij
3625           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3626           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3627           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3628           fac=cosa-3.0D0*cosb*cosg
3629           ev1=aaa*r6ij*r6ij
3630 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3631           if (j.eq.i+2) ev1=scal_el*ev1
3632           ev2=bbb*r6ij
3633           fac3=ael6i*r6ij
3634           fac4=ael3i*r3ij
3635           evdwij=(ev1+ev2)
3636           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3637           el2=fac4*fac
3638 C MARYSIA
3639           eesij=(el1+el2)
3640 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3641           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3642           ees=ees+eesij
3643           evdw1=evdw1+evdwij*sss
3644 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3645 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3646 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3647 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3648
3649           if (energy_dec) then
3650               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3651      &'evdw1',i,j,evdwij
3652      &,iteli,itelj,aaa,evdw1
3653               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3654           endif
3655
3656 C
3657 C Calculate contributions to the Cartesian gradient.
3658 C
3659 #ifdef SPLITELE
3660           facvdw=-6*rrmij*(ev1+evdwij)*sss
3661           facel=-3*rrmij*(el1+eesij)
3662           fac1=fac
3663           erij(1)=xj*rmij
3664           erij(2)=yj*rmij
3665           erij(3)=zj*rmij
3666 *
3667 * Radial derivatives. First process both termini of the fragment (i,j)
3668 *
3669           ggg(1)=facel*xj
3670           ggg(2)=facel*yj
3671           ggg(3)=facel*zj
3672 c          do k=1,3
3673 c            ghalf=0.5D0*ggg(k)
3674 c            gelc(k,i)=gelc(k,i)+ghalf
3675 c            gelc(k,j)=gelc(k,j)+ghalf
3676 c          enddo
3677 c 9/28/08 AL Gradient compotents will be summed only at the end
3678           do k=1,3
3679             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3680             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3681           enddo
3682 *
3683 * Loop over residues i+1 thru j-1.
3684 *
3685 cgrad          do k=i+1,j-1
3686 cgrad            do l=1,3
3687 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3688 cgrad            enddo
3689 cgrad          enddo
3690           if (sss.gt.0.0) then
3691           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3692           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3693           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3694           else
3695           ggg(1)=0.0
3696           ggg(2)=0.0
3697           ggg(3)=0.0
3698           endif
3699 c          do k=1,3
3700 c            ghalf=0.5D0*ggg(k)
3701 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3702 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3703 c          enddo
3704 c 9/28/08 AL Gradient compotents will be summed only at the end
3705           do k=1,3
3706             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3707             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3708           enddo
3709 *
3710 * Loop over residues i+1 thru j-1.
3711 *
3712 cgrad          do k=i+1,j-1
3713 cgrad            do l=1,3
3714 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3715 cgrad            enddo
3716 cgrad          enddo
3717 #else
3718 C MARYSIA
3719           facvdw=(ev1+evdwij)*sss
3720           facel=(el1+eesij)
3721           fac1=fac
3722           fac=-3*rrmij*(facvdw+facvdw+facel)
3723           erij(1)=xj*rmij
3724           erij(2)=yj*rmij
3725           erij(3)=zj*rmij
3726 *
3727 * Radial derivatives. First process both termini of the fragment (i,j)
3728 *
3729           ggg(1)=fac*xj
3730           ggg(2)=fac*yj
3731           ggg(3)=fac*zj
3732 c          do k=1,3
3733 c            ghalf=0.5D0*ggg(k)
3734 c            gelc(k,i)=gelc(k,i)+ghalf
3735 c            gelc(k,j)=gelc(k,j)+ghalf
3736 c          enddo
3737 c 9/28/08 AL Gradient compotents will be summed only at the end
3738           do k=1,3
3739             gelc_long(k,j)=gelc(k,j)+ggg(k)
3740             gelc_long(k,i)=gelc(k,i)-ggg(k)
3741           enddo
3742 *
3743 * Loop over residues i+1 thru j-1.
3744 *
3745 cgrad          do k=i+1,j-1
3746 cgrad            do l=1,3
3747 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3748 cgrad            enddo
3749 cgrad          enddo
3750 c 9/28/08 AL Gradient compotents will be summed only at the end
3751           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3752           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3753           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3754           do k=1,3
3755             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3756             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3757           enddo
3758 #endif
3759 *
3760 * Angular part
3761 *
3762           ecosa=2.0D0*fac3*fac1+fac4
3763           fac4=-3.0D0*fac4
3764           fac3=-6.0D0*fac3
3765           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3766           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3767           do k=1,3
3768             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3769             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3770           enddo
3771 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3772 cd   &          (dcosg(k),k=1,3)
3773           do k=1,3
3774             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3775           enddo
3776 c          do k=1,3
3777 c            ghalf=0.5D0*ggg(k)
3778 c            gelc(k,i)=gelc(k,i)+ghalf
3779 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3780 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3781 c            gelc(k,j)=gelc(k,j)+ghalf
3782 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3783 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3784 c          enddo
3785 cgrad          do k=i+1,j-1
3786 cgrad            do l=1,3
3787 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3788 cgrad            enddo
3789 cgrad          enddo
3790           do k=1,3
3791             gelc(k,i)=gelc(k,i)
3792      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3793      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3794             gelc(k,j)=gelc(k,j)
3795      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3796      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3797             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3798             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3799           enddo
3800 C MARYSIA
3801 c          endif !sscale
3802           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3803      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3804      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3805 C
3806 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3807 C   energy of a peptide unit is assumed in the form of a second-order
3808 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3809 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3810 C   are computed for EVERY pair of non-contiguous peptide groups.
3811 C
3812
3813           if (j.lt.nres-1) then
3814             j1=j+1
3815             j2=j-1
3816           else
3817             j1=j-1
3818             j2=j-2
3819           endif
3820           kkk=0
3821           lll=0
3822           do k=1,2
3823             do l=1,2
3824               kkk=kkk+1
3825               muij(kkk)=mu(k,i)*mu(l,j)
3826 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3827 #ifdef NEWCORR
3828              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3829 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3830              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3831              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3832 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3833              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3834 #endif
3835             enddo
3836           enddo
3837 cd         write (iout,*) 'EELEC: i',i,' j',j
3838 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3839 cd          write(iout,*) 'muij',muij
3840           ury=scalar(uy(1,i),erij)
3841           urz=scalar(uz(1,i),erij)
3842           vry=scalar(uy(1,j),erij)
3843           vrz=scalar(uz(1,j),erij)
3844           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3845           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3846           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3847           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3848           fac=dsqrt(-ael6i)*r3ij
3849           a22=a22*fac
3850           a23=a23*fac
3851           a32=a32*fac
3852           a33=a33*fac
3853 cd          write (iout,'(4i5,4f10.5)')
3854 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3855 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3856 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3857 cd     &      uy(:,j),uz(:,j)
3858 cd          write (iout,'(4f10.5)')
3859 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3860 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3861 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3862 cd           write (iout,'(9f10.5/)')
3863 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3864 C Derivatives of the elements of A in virtual-bond vectors
3865           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3866           do k=1,3
3867             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3868             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3869             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3870             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3871             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3872             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3873             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3874             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3875             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3876             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3877             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3878             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3879           enddo
3880 C Compute radial contributions to the gradient
3881           facr=-3.0d0*rrmij
3882           a22der=a22*facr
3883           a23der=a23*facr
3884           a32der=a32*facr
3885           a33der=a33*facr
3886           agg(1,1)=a22der*xj
3887           agg(2,1)=a22der*yj
3888           agg(3,1)=a22der*zj
3889           agg(1,2)=a23der*xj
3890           agg(2,2)=a23der*yj
3891           agg(3,2)=a23der*zj
3892           agg(1,3)=a32der*xj
3893           agg(2,3)=a32der*yj
3894           agg(3,3)=a32der*zj
3895           agg(1,4)=a33der*xj
3896           agg(2,4)=a33der*yj
3897           agg(3,4)=a33der*zj
3898 C Add the contributions coming from er
3899           fac3=-3.0d0*fac
3900           do k=1,3
3901             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3902             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3903             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3904             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3905           enddo
3906           do k=1,3
3907 C Derivatives in DC(i)
3908 cgrad            ghalf1=0.5d0*agg(k,1)
3909 cgrad            ghalf2=0.5d0*agg(k,2)
3910 cgrad            ghalf3=0.5d0*agg(k,3)
3911 cgrad            ghalf4=0.5d0*agg(k,4)
3912             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3913      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3914             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3915      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3916             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3917      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3918             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3919      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3920 C Derivatives in DC(i+1)
3921             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3922      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3923             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3924      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3925             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3926      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3927             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3928      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3929 C Derivatives in DC(j)
3930             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3931      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3932             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3933      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3934             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3935      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3936             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3937      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3938 C Derivatives in DC(j+1) or DC(nres-1)
3939             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3940      &      -3.0d0*vryg(k,3)*ury)
3941             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3942      &      -3.0d0*vrzg(k,3)*ury)
3943             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3944      &      -3.0d0*vryg(k,3)*urz)
3945             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3946      &      -3.0d0*vrzg(k,3)*urz)
3947 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3948 cgrad              do l=1,4
3949 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3950 cgrad              enddo
3951 cgrad            endif
3952           enddo
3953           acipa(1,1)=a22
3954           acipa(1,2)=a23
3955           acipa(2,1)=a32
3956           acipa(2,2)=a33
3957           a22=-a22
3958           a23=-a23
3959           do l=1,2
3960             do k=1,3
3961               agg(k,l)=-agg(k,l)
3962               aggi(k,l)=-aggi(k,l)
3963               aggi1(k,l)=-aggi1(k,l)
3964               aggj(k,l)=-aggj(k,l)
3965               aggj1(k,l)=-aggj1(k,l)
3966             enddo
3967           enddo
3968           if (j.lt.nres-1) then
3969             a22=-a22
3970             a32=-a32
3971             do l=1,3,2
3972               do k=1,3
3973                 agg(k,l)=-agg(k,l)
3974                 aggi(k,l)=-aggi(k,l)
3975                 aggi1(k,l)=-aggi1(k,l)
3976                 aggj(k,l)=-aggj(k,l)
3977                 aggj1(k,l)=-aggj1(k,l)
3978               enddo
3979             enddo
3980           else
3981             a22=-a22
3982             a23=-a23
3983             a32=-a32
3984             a33=-a33
3985             do l=1,4
3986               do k=1,3
3987                 agg(k,l)=-agg(k,l)
3988                 aggi(k,l)=-aggi(k,l)
3989                 aggi1(k,l)=-aggi1(k,l)
3990                 aggj(k,l)=-aggj(k,l)
3991                 aggj1(k,l)=-aggj1(k,l)
3992               enddo
3993             enddo
3994           endif
3995           ENDIF ! WCORR
3996           IF (wel_loc.gt.0.0d0) THEN
3997 C Contribution to the local-electrostatic energy coming from the i-j pair
3998           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3999      &     +a33*muij(4)
4000 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4001 c     &                     ' eel_loc_ij',eel_loc_ij
4002 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4003 C Calculate patrial derivative for theta angle
4004 #ifdef NEWCORR
4005          geel_loc_ij=a22*gmuij1(1)
4006      &     +a23*gmuij1(2)
4007      &     +a32*gmuij1(3)
4008      &     +a33*gmuij1(4)
4009 c         write(iout,*) "derivative over thatai"
4010 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4011 c     &   a33*gmuij1(4)
4012          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4013      &      geel_loc_ij*wel_loc
4014 c         write(iout,*) "derivative over thatai-1"
4015 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4016 c     &   a33*gmuij2(4)
4017          geel_loc_ij=
4018      &     a22*gmuij2(1)
4019      &     +a23*gmuij2(2)
4020      &     +a32*gmuij2(3)
4021      &     +a33*gmuij2(4)
4022          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4023      &      geel_loc_ij*wel_loc
4024 c  Derivative over j residue
4025          geel_loc_ji=a22*gmuji1(1)
4026      &     +a23*gmuji1(2)
4027      &     +a32*gmuji1(3)
4028      &     +a33*gmuji1(4)
4029 c         write(iout,*) "derivative over thataj"
4030 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4031 c     &   a33*gmuji1(4)
4032
4033         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4034      &      geel_loc_ji*wel_loc
4035          geel_loc_ji=
4036      &     +a22*gmuji2(1)
4037      &     +a23*gmuji2(2)
4038      &     +a32*gmuji2(3)
4039      &     +a33*gmuji2(4)
4040 c         write(iout,*) "derivative over thataj-1"
4041 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4042 c     &   a33*gmuji2(4)
4043          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4044      &      geel_loc_ji*wel_loc
4045 #endif
4046 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4047
4048           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4049      &            'eelloc',i,j,eel_loc_ij
4050 c           if (eel_loc_ij.ne.0)
4051 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4052 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4053
4054           eel_loc=eel_loc+eel_loc_ij
4055 C Partial derivatives in virtual-bond dihedral angles gamma
4056           if (i.gt.1)
4057      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4058      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4059      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4060           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4061      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4062      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4063 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4064           do l=1,3
4065             ggg(l)=agg(l,1)*muij(1)+
4066      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4067             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4068             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4069 cgrad            ghalf=0.5d0*ggg(l)
4070 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4071 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4072           enddo
4073 cgrad          do k=i+1,j2
4074 cgrad            do l=1,3
4075 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4076 cgrad            enddo
4077 cgrad          enddo
4078 C Remaining derivatives of eello
4079           do l=1,3
4080             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4081      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4082             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4083      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4084             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4085      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4086             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4087      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4088           enddo
4089           ENDIF
4090 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4091 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4092           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4093      &       .and. num_conti.le.maxconts) then
4094 c            write (iout,*) i,j," entered corr"
4095 C
4096 C Calculate the contact function. The ith column of the array JCONT will
4097 C contain the numbers of atoms that make contacts with the atom I (of numbers
4098 C greater than I). The arrays FACONT and GACONT will contain the values of
4099 C the contact function and its derivative.
4100 c           r0ij=1.02D0*rpp(iteli,itelj)
4101 c           r0ij=1.11D0*rpp(iteli,itelj)
4102             r0ij=2.20D0*rpp(iteli,itelj)
4103 c           r0ij=1.55D0*rpp(iteli,itelj)
4104             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4105             if (fcont.gt.0.0D0) then
4106               num_conti=num_conti+1
4107               if (num_conti.gt.maxconts) then
4108                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4109      &                         ' will skip next contacts for this conf.'
4110               else
4111                 jcont_hb(num_conti,i)=j
4112 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4113 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4114                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4115      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4116 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4117 C  terms.
4118                 d_cont(num_conti,i)=rij
4119 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4120 C     --- Electrostatic-interaction matrix ---
4121                 a_chuj(1,1,num_conti,i)=a22
4122                 a_chuj(1,2,num_conti,i)=a23
4123                 a_chuj(2,1,num_conti,i)=a32
4124                 a_chuj(2,2,num_conti,i)=a33
4125 C     --- Gradient of rij
4126                 do kkk=1,3
4127                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4128                 enddo
4129                 kkll=0
4130                 do k=1,2
4131                   do l=1,2
4132                     kkll=kkll+1
4133                     do m=1,3
4134                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4135                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4136                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4137                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4138                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4139                     enddo
4140                   enddo
4141                 enddo
4142                 ENDIF
4143                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4144 C Calculate contact energies
4145                 cosa4=4.0D0*cosa
4146                 wij=cosa-3.0D0*cosb*cosg
4147                 cosbg1=cosb+cosg
4148                 cosbg2=cosb-cosg
4149 c               fac3=dsqrt(-ael6i)/r0ij**3
4150                 fac3=dsqrt(-ael6i)*r3ij
4151 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4152                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4153                 if (ees0tmp.gt.0) then
4154                   ees0pij=dsqrt(ees0tmp)
4155                 else
4156                   ees0pij=0
4157                 endif
4158 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4159                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4160                 if (ees0tmp.gt.0) then
4161                   ees0mij=dsqrt(ees0tmp)
4162                 else
4163                   ees0mij=0
4164                 endif
4165 c               ees0mij=0.0D0
4166                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4167                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4168 C Diagnostics. Comment out or remove after debugging!
4169 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4170 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4171 c               ees0m(num_conti,i)=0.0D0
4172 C End diagnostics.
4173 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4174 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4175 C Angular derivatives of the contact function
4176                 ees0pij1=fac3/ees0pij
4177                 ees0mij1=fac3/ees0mij
4178                 fac3p=-3.0D0*fac3*rrmij
4179                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4180                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4181 c               ees0mij1=0.0D0
4182                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4183                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4184                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4185                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4186                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4187                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4188                 ecosap=ecosa1+ecosa2
4189                 ecosbp=ecosb1+ecosb2
4190                 ecosgp=ecosg1+ecosg2
4191                 ecosam=ecosa1-ecosa2
4192                 ecosbm=ecosb1-ecosb2
4193                 ecosgm=ecosg1-ecosg2
4194 C Diagnostics
4195 c               ecosap=ecosa1
4196 c               ecosbp=ecosb1
4197 c               ecosgp=ecosg1
4198 c               ecosam=0.0D0
4199 c               ecosbm=0.0D0
4200 c               ecosgm=0.0D0
4201 C End diagnostics
4202                 facont_hb(num_conti,i)=fcont
4203                 fprimcont=fprimcont/rij
4204 cd              facont_hb(num_conti,i)=1.0D0
4205 C Following line is for diagnostics.
4206 cd              fprimcont=0.0D0
4207                 do k=1,3
4208                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4209                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4210                 enddo
4211                 do k=1,3
4212                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4213                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4214                 enddo
4215                 gggp(1)=gggp(1)+ees0pijp*xj
4216                 gggp(2)=gggp(2)+ees0pijp*yj
4217                 gggp(3)=gggp(3)+ees0pijp*zj
4218                 gggm(1)=gggm(1)+ees0mijp*xj
4219                 gggm(2)=gggm(2)+ees0mijp*yj
4220                 gggm(3)=gggm(3)+ees0mijp*zj
4221 C Derivatives due to the contact function
4222                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4223                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4224                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4225                 do k=1,3
4226 c
4227 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4228 c          following the change of gradient-summation algorithm.
4229 c
4230 cgrad                  ghalfp=0.5D0*gggp(k)
4231 cgrad                  ghalfm=0.5D0*gggm(k)
4232                   gacontp_hb1(k,num_conti,i)=!ghalfp
4233      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4234      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4235                   gacontp_hb2(k,num_conti,i)=!ghalfp
4236      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4237      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4238                   gacontp_hb3(k,num_conti,i)=gggp(k)
4239                   gacontm_hb1(k,num_conti,i)=!ghalfm
4240      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4241      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4242                   gacontm_hb2(k,num_conti,i)=!ghalfm
4243      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4244      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4245                   gacontm_hb3(k,num_conti,i)=gggm(k)
4246                 enddo
4247 C Diagnostics. Comment out or remove after debugging!
4248 cdiag           do k=1,3
4249 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4250 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4251 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4252 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4253 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4254 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4255 cdiag           enddo
4256               ENDIF ! wcorr
4257               endif  ! num_conti.le.maxconts
4258             endif  ! fcont.gt.0
4259           endif    ! j.gt.i+1
4260           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4261             do k=1,4
4262               do l=1,3
4263                 ghalf=0.5d0*agg(l,k)
4264                 aggi(l,k)=aggi(l,k)+ghalf
4265                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4266                 aggj(l,k)=aggj(l,k)+ghalf
4267               enddo
4268             enddo
4269             if (j.eq.nres-1 .and. i.lt.j-2) then
4270               do k=1,4
4271                 do l=1,3
4272                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4273                 enddo
4274               enddo
4275             endif
4276           endif
4277 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4278       return
4279       end
4280 C-----------------------------------------------------------------------------
4281       subroutine eturn3(i,eello_turn3)
4282 C Third- and fourth-order contributions from turns
4283       implicit real*8 (a-h,o-z)
4284       include 'DIMENSIONS'
4285       include 'COMMON.IOUNITS'
4286       include 'COMMON.GEO'
4287       include 'COMMON.VAR'
4288       include 'COMMON.LOCAL'
4289       include 'COMMON.CHAIN'
4290       include 'COMMON.DERIV'
4291       include 'COMMON.INTERACT'
4292       include 'COMMON.CONTACTS'
4293       include 'COMMON.TORSION'
4294       include 'COMMON.VECTORS'
4295       include 'COMMON.FFIELD'
4296       include 'COMMON.CONTROL'
4297       dimension ggg(3)
4298       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4299      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4300      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4301      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4302      &  auxgmat2(2,2),auxgmatt2(2,2)
4303       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4304      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4305       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4306      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4307      &    num_conti,j1,j2
4308       j=i+2
4309 c      write (iout,*) "eturn3",i,j,j1,j2
4310       a_temp(1,1)=a22
4311       a_temp(1,2)=a23
4312       a_temp(2,1)=a32
4313       a_temp(2,2)=a33
4314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4315 C
4316 C               Third-order contributions
4317 C
4318 C                 (i+2)o----(i+3)
4319 C                      | |
4320 C                      | |
4321 C                 (i+1)o----i
4322 C
4323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4324 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4325         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4326 c auxalary matices for theta gradient
4327 c auxalary matrix for i+1 and constant i+2
4328         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4329 c auxalary matrix for i+2 and constant i+1
4330         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4331         call transpose2(auxmat(1,1),auxmat1(1,1))
4332         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4333         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4334         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4335         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4336         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4337         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4338 C Derivatives in theta
4339         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4340      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4341         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4342      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4343
4344         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4345      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4346 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4347 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4348 cd     &    ' eello_turn3_num',4*eello_turn3_num
4349 C Derivatives in gamma(i)
4350         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4351         call transpose2(auxmat2(1,1),auxmat3(1,1))
4352         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4353         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4354 C Derivatives in gamma(i+1)
4355         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4356         call transpose2(auxmat2(1,1),auxmat3(1,1))
4357         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4358         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4359      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4360 C Cartesian derivatives
4361         do l=1,3
4362 c            ghalf1=0.5d0*agg(l,1)
4363 c            ghalf2=0.5d0*agg(l,2)
4364 c            ghalf3=0.5d0*agg(l,3)
4365 c            ghalf4=0.5d0*agg(l,4)
4366           a_temp(1,1)=aggi(l,1)!+ghalf1
4367           a_temp(1,2)=aggi(l,2)!+ghalf2
4368           a_temp(2,1)=aggi(l,3)!+ghalf3
4369           a_temp(2,2)=aggi(l,4)!+ghalf4
4370           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4371           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4372      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4373           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4374           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4375           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4376           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4377           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4378           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4379      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4380           a_temp(1,1)=aggj(l,1)!+ghalf1
4381           a_temp(1,2)=aggj(l,2)!+ghalf2
4382           a_temp(2,1)=aggj(l,3)!+ghalf3
4383           a_temp(2,2)=aggj(l,4)!+ghalf4
4384           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4385           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4386      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4387           a_temp(1,1)=aggj1(l,1)
4388           a_temp(1,2)=aggj1(l,2)
4389           a_temp(2,1)=aggj1(l,3)
4390           a_temp(2,2)=aggj1(l,4)
4391           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4392           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4393      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4394         enddo
4395       return
4396       end
4397 C-------------------------------------------------------------------------------
4398       subroutine eturn4(i,eello_turn4)
4399 C Third- and fourth-order contributions from turns
4400       implicit real*8 (a-h,o-z)
4401       include 'DIMENSIONS'
4402       include 'COMMON.IOUNITS'
4403       include 'COMMON.GEO'
4404       include 'COMMON.VAR'
4405       include 'COMMON.LOCAL'
4406       include 'COMMON.CHAIN'
4407       include 'COMMON.DERIV'
4408       include 'COMMON.INTERACT'
4409       include 'COMMON.CONTACTS'
4410       include 'COMMON.TORSION'
4411       include 'COMMON.VECTORS'
4412       include 'COMMON.FFIELD'
4413       include 'COMMON.CONTROL'
4414       dimension ggg(3)
4415       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4416      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4417      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4418      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4419      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4420      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4421      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4422       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4423      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4424       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4425      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4426      &    num_conti,j1,j2
4427       j=i+3
4428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4429 C
4430 C               Fourth-order contributions
4431 C
4432 C                 (i+3)o----(i+4)
4433 C                     /  |
4434 C               (i+2)o   |
4435 C                     \  |
4436 C                 (i+1)o----i
4437 C
4438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4439 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4440 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4441 c        write(iout,*)"WCHODZE W PROGRAM"
4442         a_temp(1,1)=a22
4443         a_temp(1,2)=a23
4444         a_temp(2,1)=a32
4445         a_temp(2,2)=a33
4446         iti1=itortyp(itype(i+1))
4447         iti2=itortyp(itype(i+2))
4448         iti3=itortyp(itype(i+3))
4449 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4450         call transpose2(EUg(1,1,i+1),e1t(1,1))
4451         call transpose2(Eug(1,1,i+2),e2t(1,1))
4452         call transpose2(Eug(1,1,i+3),e3t(1,1))
4453 C Ematrix derivative in theta
4454         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4455         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4456         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4457         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4458 c       eta1 in derivative theta
4459         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4460         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4461 c       auxgvec is derivative of Ub2 so i+3 theta
4462         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4463 c       auxalary matrix of E i+1
4464         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4465 c        s1=0.0
4466 c        gs1=0.0
4467         s1=scalar2(b1(1,i+2),auxvec(1))
4468 c derivative of theta i+2 with constant i+3
4469         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4470 c derivative of theta i+2 with constant i+2
4471         gs32=scalar2(b1(1,i+2),auxgvec(1))
4472 c derivative of E matix in theta of i+1
4473         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4474
4475         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4476 c       ea31 in derivative theta
4477         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4478         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4479 c auxilary matrix auxgvec of Ub2 with constant E matirx
4480         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4481 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4482         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4483
4484 c        s2=0.0
4485 c        gs2=0.0
4486         s2=scalar2(b1(1,i+1),auxvec(1))
4487 c derivative of theta i+1 with constant i+3
4488         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4489 c derivative of theta i+2 with constant i+1
4490         gs21=scalar2(b1(1,i+1),auxgvec(1))
4491 c derivative of theta i+3 with constant i+1
4492         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4493 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4494 c     &  gtb1(1,i+1)
4495         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4496 c two derivatives over diffetent matrices
4497 c gtae3e2 is derivative over i+3
4498         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4499 c ae3gte2 is derivative over i+2
4500         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4501         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4502 c three possible derivative over theta E matices
4503 c i+1
4504         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4505 c i+2
4506         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4507 c i+3
4508         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4509         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4510
4511         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4512         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4513         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4514
4515         eello_turn4=eello_turn4-(s1+s2+s3)
4516 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4517         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4518      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4519 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4520 cd     &    ' eello_turn4_num',8*eello_turn4_num
4521 #ifdef NEWCORR
4522         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4523      &                  -(gs13+gsE13+gsEE1)*wturn4
4524         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4525      &                    -(gs23+gs21+gsEE2)*wturn4
4526         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4527      &                    -(gs32+gsE31+gsEE3)*wturn4
4528 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4529 c     &   gs2
4530 #endif
4531         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4532      &      'eturn4',i,j,-(s1+s2+s3)
4533 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4534 c     &    ' eello_turn4_num',8*eello_turn4_num
4535 C Derivatives in gamma(i)
4536         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4537         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4538         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4539         s1=scalar2(b1(1,i+2),auxvec(1))
4540         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4541         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4542         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4543 C Derivatives in gamma(i+1)
4544         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4545         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4546         s2=scalar2(b1(1,i+1),auxvec(1))
4547         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4548         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4549         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4550         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4551 C Derivatives in gamma(i+2)
4552         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4553         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4554         s1=scalar2(b1(1,i+2),auxvec(1))
4555         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4556         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4557         s2=scalar2(b1(1,i+1),auxvec(1))
4558         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4559         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4560         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4561         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4562 C Cartesian derivatives
4563 C Derivatives of this turn contributions in DC(i+2)
4564         if (j.lt.nres-1) then
4565           do l=1,3
4566             a_temp(1,1)=agg(l,1)
4567             a_temp(1,2)=agg(l,2)
4568             a_temp(2,1)=agg(l,3)
4569             a_temp(2,2)=agg(l,4)
4570             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4571             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4572             s1=scalar2(b1(1,i+2),auxvec(1))
4573             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4574             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4575             s2=scalar2(b1(1,i+1),auxvec(1))
4576             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4577             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4578             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4579             ggg(l)=-(s1+s2+s3)
4580             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4581           enddo
4582         endif
4583 C Remaining derivatives of this turn contribution
4584         do l=1,3
4585           a_temp(1,1)=aggi(l,1)
4586           a_temp(1,2)=aggi(l,2)
4587           a_temp(2,1)=aggi(l,3)
4588           a_temp(2,2)=aggi(l,4)
4589           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4590           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4591           s1=scalar2(b1(1,i+2),auxvec(1))
4592           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4593           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4594           s2=scalar2(b1(1,i+1),auxvec(1))
4595           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4596           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4597           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4598           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4599           a_temp(1,1)=aggi1(l,1)
4600           a_temp(1,2)=aggi1(l,2)
4601           a_temp(2,1)=aggi1(l,3)
4602           a_temp(2,2)=aggi1(l,4)
4603           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4604           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4605           s1=scalar2(b1(1,i+2),auxvec(1))
4606           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4607           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4608           s2=scalar2(b1(1,i+1),auxvec(1))
4609           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4610           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4611           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4612           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4613           a_temp(1,1)=aggj(l,1)
4614           a_temp(1,2)=aggj(l,2)
4615           a_temp(2,1)=aggj(l,3)
4616           a_temp(2,2)=aggj(l,4)
4617           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4618           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4619           s1=scalar2(b1(1,i+2),auxvec(1))
4620           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4621           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4622           s2=scalar2(b1(1,i+1),auxvec(1))
4623           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4624           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4625           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4626           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4627           a_temp(1,1)=aggj1(l,1)
4628           a_temp(1,2)=aggj1(l,2)
4629           a_temp(2,1)=aggj1(l,3)
4630           a_temp(2,2)=aggj1(l,4)
4631           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4632           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4633           s1=scalar2(b1(1,i+2),auxvec(1))
4634           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4635           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4636           s2=scalar2(b1(1,i+1),auxvec(1))
4637           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4638           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4639           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4640 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4641           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4642         enddo
4643       return
4644       end
4645 C-----------------------------------------------------------------------------
4646       subroutine vecpr(u,v,w)
4647       implicit real*8(a-h,o-z)
4648       dimension u(3),v(3),w(3)
4649       w(1)=u(2)*v(3)-u(3)*v(2)
4650       w(2)=-u(1)*v(3)+u(3)*v(1)
4651       w(3)=u(1)*v(2)-u(2)*v(1)
4652       return
4653       end
4654 C-----------------------------------------------------------------------------
4655       subroutine unormderiv(u,ugrad,unorm,ungrad)
4656 C This subroutine computes the derivatives of a normalized vector u, given
4657 C the derivatives computed without normalization conditions, ugrad. Returns
4658 C ungrad.
4659       implicit none
4660       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4661       double precision vec(3)
4662       double precision scalar
4663       integer i,j
4664 c      write (2,*) 'ugrad',ugrad
4665 c      write (2,*) 'u',u
4666       do i=1,3
4667         vec(i)=scalar(ugrad(1,i),u(1))
4668       enddo
4669 c      write (2,*) 'vec',vec
4670       do i=1,3
4671         do j=1,3
4672           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4673         enddo
4674       enddo
4675 c      write (2,*) 'ungrad',ungrad
4676       return
4677       end
4678 C-----------------------------------------------------------------------------
4679       subroutine escp_soft_sphere(evdw2,evdw2_14)
4680 C
4681 C This subroutine calculates the excluded-volume interaction energy between
4682 C peptide-group centers and side chains and its gradient in virtual-bond and
4683 C side-chain vectors.
4684 C
4685       implicit real*8 (a-h,o-z)
4686       include 'DIMENSIONS'
4687       include 'COMMON.GEO'
4688       include 'COMMON.VAR'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.CHAIN'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.INTERACT'
4693       include 'COMMON.FFIELD'
4694       include 'COMMON.IOUNITS'
4695       include 'COMMON.CONTROL'
4696       dimension ggg(3)
4697       evdw2=0.0D0
4698       evdw2_14=0.0d0
4699       r0_scp=4.5d0
4700 cd    print '(a)','Enter ESCP'
4701 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4702 C      do xshift=-1,1
4703 C      do yshift=-1,1
4704 C      do zshift=-1,1
4705       do i=iatscp_s,iatscp_e
4706         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4707         iteli=itel(i)
4708         xi=0.5D0*(c(1,i)+c(1,i+1))
4709         yi=0.5D0*(c(2,i)+c(2,i+1))
4710         zi=0.5D0*(c(3,i)+c(3,i+1))
4711 C Return atom into box, boxxsize is size of box in x dimension
4712 c  134   continue
4713 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4714 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4715 C Condition for being inside the proper box
4716 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4717 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4718 c        go to 134
4719 c        endif
4720 c  135   continue
4721 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4722 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4723 C Condition for being inside the proper box
4724 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4725 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4726 c        go to 135
4727 c c       endif
4728 c  136   continue
4729 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4730 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4731 cC Condition for being inside the proper box
4732 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4733 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4734 c        go to 136
4735 c        endif
4736           xi=mod(xi,boxxsize)
4737           if (xi.lt.0) xi=xi+boxxsize
4738           yi=mod(yi,boxysize)
4739           if (yi.lt.0) yi=yi+boxysize
4740           zi=mod(zi,boxzsize)
4741           if (zi.lt.0) zi=zi+boxzsize
4742 C          xi=xi+xshift*boxxsize
4743 C          yi=yi+yshift*boxysize
4744 C          zi=zi+zshift*boxzsize
4745         do iint=1,nscp_gr(i)
4746
4747         do j=iscpstart(i,iint),iscpend(i,iint)
4748           if (itype(j).eq.ntyp1) cycle
4749           itypj=iabs(itype(j))
4750 C Uncomment following three lines for SC-p interactions
4751 c         xj=c(1,nres+j)-xi
4752 c         yj=c(2,nres+j)-yi
4753 c         zj=c(3,nres+j)-zi
4754 C Uncomment following three lines for Ca-p interactions
4755           xj=c(1,j)
4756           yj=c(2,j)
4757           zj=c(3,j)
4758 c  174   continue
4759 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4760 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4761 C Condition for being inside the proper box
4762 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4763 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4764 c        go to 174
4765 c        endif
4766 c  175   continue
4767 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4768 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4769 cC Condition for being inside the proper box
4770 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4771 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4772 c        go to 175
4773 c        endif
4774 c  176   continue
4775 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4776 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4777 C Condition for being inside the proper box
4778 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4779 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4780 c        go to 176
4781           xj=mod(xj,boxxsize)
4782           if (xj.lt.0) xj=xj+boxxsize
4783           yj=mod(yj,boxysize)
4784           if (yj.lt.0) yj=yj+boxysize
4785           zj=mod(zj,boxzsize)
4786           if (zj.lt.0) zj=zj+boxzsize
4787       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4788       xj_safe=xj
4789       yj_safe=yj
4790       zj_safe=zj
4791       subchap=0
4792       do xshift=-1,1
4793       do yshift=-1,1
4794       do zshift=-1,1
4795           xj=xj_safe+xshift*boxxsize
4796           yj=yj_safe+yshift*boxysize
4797           zj=zj_safe+zshift*boxzsize
4798           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4799           if(dist_temp.lt.dist_init) then
4800             dist_init=dist_temp
4801             xj_temp=xj
4802             yj_temp=yj
4803             zj_temp=zj
4804             subchap=1
4805           endif
4806        enddo
4807        enddo
4808        enddo
4809        if (subchap.eq.1) then
4810           xj=xj_temp-xi
4811           yj=yj_temp-yi
4812           zj=zj_temp-zi
4813        else
4814           xj=xj_safe-xi
4815           yj=yj_safe-yi
4816           zj=zj_safe-zi
4817        endif
4818 c c       endif
4819 C          xj=xj-xi
4820 C          yj=yj-yi
4821 C          zj=zj-zi
4822           rij=xj*xj+yj*yj+zj*zj
4823
4824           r0ij=r0_scp
4825           r0ijsq=r0ij*r0ij
4826           if (rij.lt.r0ijsq) then
4827             evdwij=0.25d0*(rij-r0ijsq)**2
4828             fac=rij-r0ijsq
4829           else
4830             evdwij=0.0d0
4831             fac=0.0d0
4832           endif
4833           evdw2=evdw2+evdwij
4834 C
4835 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4836 C
4837           ggg(1)=xj*fac
4838           ggg(2)=yj*fac
4839           ggg(3)=zj*fac
4840 cgrad          if (j.lt.i) then
4841 cd          write (iout,*) 'j<i'
4842 C Uncomment following three lines for SC-p interactions
4843 c           do k=1,3
4844 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4845 c           enddo
4846 cgrad          else
4847 cd          write (iout,*) 'j>i'
4848 cgrad            do k=1,3
4849 cgrad              ggg(k)=-ggg(k)
4850 C Uncomment following line for SC-p interactions
4851 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4852 cgrad            enddo
4853 cgrad          endif
4854 cgrad          do k=1,3
4855 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4856 cgrad          enddo
4857 cgrad          kstart=min0(i+1,j)
4858 cgrad          kend=max0(i-1,j-1)
4859 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4860 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4861 cgrad          do k=kstart,kend
4862 cgrad            do l=1,3
4863 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4864 cgrad            enddo
4865 cgrad          enddo
4866           do k=1,3
4867             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4868             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4869           enddo
4870         enddo
4871
4872         enddo ! iint
4873       enddo ! i
4874 C      enddo !zshift
4875 C      enddo !yshift
4876 C      enddo !xshift
4877       return
4878       end
4879 C-----------------------------------------------------------------------------
4880       subroutine escp(evdw2,evdw2_14)
4881 C
4882 C This subroutine calculates the excluded-volume interaction energy between
4883 C peptide-group centers and side chains and its gradient in virtual-bond and
4884 C side-chain vectors.
4885 C
4886       implicit real*8 (a-h,o-z)
4887       include 'DIMENSIONS'
4888       include 'COMMON.GEO'
4889       include 'COMMON.VAR'
4890       include 'COMMON.LOCAL'
4891       include 'COMMON.CHAIN'
4892       include 'COMMON.DERIV'
4893       include 'COMMON.INTERACT'
4894       include 'COMMON.FFIELD'
4895       include 'COMMON.IOUNITS'
4896       include 'COMMON.CONTROL'
4897       include 'COMMON.SPLITELE'
4898       dimension ggg(3)
4899       evdw2=0.0D0
4900       evdw2_14=0.0d0
4901 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4902 cd    print '(a)','Enter ESCP'
4903 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4904 C      do xshift=-1,1
4905 C      do yshift=-1,1
4906 C      do zshift=-1,1
4907       do i=iatscp_s,iatscp_e
4908         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4909         iteli=itel(i)
4910         xi=0.5D0*(c(1,i)+c(1,i+1))
4911         yi=0.5D0*(c(2,i)+c(2,i+1))
4912         zi=0.5D0*(c(3,i)+c(3,i+1))
4913           xi=mod(xi,boxxsize)
4914           if (xi.lt.0) xi=xi+boxxsize
4915           yi=mod(yi,boxysize)
4916           if (yi.lt.0) yi=yi+boxysize
4917           zi=mod(zi,boxzsize)
4918           if (zi.lt.0) zi=zi+boxzsize
4919 c          xi=xi+xshift*boxxsize
4920 c          yi=yi+yshift*boxysize
4921 c          zi=zi+zshift*boxzsize
4922 c        print *,xi,yi,zi,'polozenie i'
4923 C Return atom into box, boxxsize is size of box in x dimension
4924 c  134   continue
4925 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4926 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4927 C Condition for being inside the proper box
4928 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4929 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4930 c        go to 134
4931 c        endif
4932 c  135   continue
4933 c          print *,xi,boxxsize,"pierwszy"
4934
4935 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4936 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4937 C Condition for being inside the proper box
4938 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4939 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4940 c        go to 135
4941 c        endif
4942 c  136   continue
4943 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4944 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4945 C Condition for being inside the proper box
4946 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4947 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4948 c        go to 136
4949 c        endif
4950         do iint=1,nscp_gr(i)
4951
4952         do j=iscpstart(i,iint),iscpend(i,iint)
4953           itypj=iabs(itype(j))
4954           if (itypj.eq.ntyp1) cycle
4955 C Uncomment following three lines for SC-p interactions
4956 c         xj=c(1,nres+j)-xi
4957 c         yj=c(2,nres+j)-yi
4958 c         zj=c(3,nres+j)-zi
4959 C Uncomment following three lines for Ca-p interactions
4960           xj=c(1,j)
4961           yj=c(2,j)
4962           zj=c(3,j)
4963           xj=mod(xj,boxxsize)
4964           if (xj.lt.0) xj=xj+boxxsize
4965           yj=mod(yj,boxysize)
4966           if (yj.lt.0) yj=yj+boxysize
4967           zj=mod(zj,boxzsize)
4968           if (zj.lt.0) zj=zj+boxzsize
4969 c  174   continue
4970 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4971 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4972 C Condition for being inside the proper box
4973 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4974 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4975 c        go to 174
4976 c        endif
4977 c  175   continue
4978 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4979 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4980 cC Condition for being inside the proper box
4981 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4982 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4983 c        go to 175
4984 c        endif
4985 c  176   continue
4986 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4987 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4988 C Condition for being inside the proper box
4989 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4990 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4991 c        go to 176
4992 c        endif
4993 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4994       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4995       xj_safe=xj
4996       yj_safe=yj
4997       zj_safe=zj
4998       subchap=0
4999       do xshift=-1,1
5000       do yshift=-1,1
5001       do zshift=-1,1
5002           xj=xj_safe+xshift*boxxsize
5003           yj=yj_safe+yshift*boxysize
5004           zj=zj_safe+zshift*boxzsize
5005           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5006           if(dist_temp.lt.dist_init) then
5007             dist_init=dist_temp
5008             xj_temp=xj
5009             yj_temp=yj
5010             zj_temp=zj
5011             subchap=1
5012           endif
5013        enddo
5014        enddo
5015        enddo
5016        if (subchap.eq.1) then
5017           xj=xj_temp-xi
5018           yj=yj_temp-yi
5019           zj=zj_temp-zi
5020        else
5021           xj=xj_safe-xi
5022           yj=yj_safe-yi
5023           zj=zj_safe-zi
5024        endif
5025 c          print *,xj,yj,zj,'polozenie j'
5026           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5027 c          print *,rrij
5028           sss=sscale(1.0d0/(dsqrt(rrij)))
5029 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5030 c          if (sss.eq.0) print *,'czasem jest OK'
5031           if (sss.le.0.0d0) cycle
5032           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5033           fac=rrij**expon2
5034           e1=fac*fac*aad(itypj,iteli)
5035           e2=fac*bad(itypj,iteli)
5036           if (iabs(j-i) .le. 2) then
5037             e1=scal14*e1
5038             e2=scal14*e2
5039             evdw2_14=evdw2_14+(e1+e2)*sss
5040           endif
5041           evdwij=e1+e2
5042           evdw2=evdw2+evdwij*sss
5043           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5044      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5045      &       bad(itypj,iteli)
5046 C
5047 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5048 C
5049           fac=-(evdwij+e1)*rrij*sss
5050           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5051           ggg(1)=xj*fac
5052           ggg(2)=yj*fac
5053           ggg(3)=zj*fac
5054 cgrad          if (j.lt.i) then
5055 cd          write (iout,*) 'j<i'
5056 C Uncomment following three lines for SC-p interactions
5057 c           do k=1,3
5058 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5059 c           enddo
5060 cgrad          else
5061 cd          write (iout,*) 'j>i'
5062 cgrad            do k=1,3
5063 cgrad              ggg(k)=-ggg(k)
5064 C Uncomment following line for SC-p interactions
5065 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5066 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5067 cgrad            enddo
5068 cgrad          endif
5069 cgrad          do k=1,3
5070 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5071 cgrad          enddo
5072 cgrad          kstart=min0(i+1,j)
5073 cgrad          kend=max0(i-1,j-1)
5074 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5075 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5076 cgrad          do k=kstart,kend
5077 cgrad            do l=1,3
5078 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5079 cgrad            enddo
5080 cgrad          enddo
5081           do k=1,3
5082             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5083             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5084           enddo
5085 c        endif !endif for sscale cutoff
5086         enddo ! j
5087
5088         enddo ! iint
5089       enddo ! i
5090 c      enddo !zshift
5091 c      enddo !yshift
5092 c      enddo !xshift
5093       do i=1,nct
5094         do j=1,3
5095           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5096           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5097           gradx_scp(j,i)=expon*gradx_scp(j,i)
5098         enddo
5099       enddo
5100 C******************************************************************************
5101 C
5102 C                              N O T E !!!
5103 C
5104 C To save time the factor EXPON has been extracted from ALL components
5105 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5106 C use!
5107 C
5108 C******************************************************************************
5109       return
5110       end
5111 C--------------------------------------------------------------------------
5112       subroutine edis(ehpb)
5113 C
5114 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5115 C
5116       implicit real*8 (a-h,o-z)
5117       include 'DIMENSIONS'
5118       include 'COMMON.SBRIDGE'
5119       include 'COMMON.CHAIN'
5120       include 'COMMON.DERIV'
5121       include 'COMMON.VAR'
5122       include 'COMMON.INTERACT'
5123       include 'COMMON.IOUNITS'
5124       dimension ggg(3)
5125       ehpb=0.0D0
5126 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5127 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5128       if (link_end.eq.0) return
5129       do i=link_start,link_end
5130 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5131 C CA-CA distance used in regularization of structure.
5132         ii=ihpb(i)
5133         jj=jhpb(i)
5134 C iii and jjj point to the residues for which the distance is assigned.
5135         if (ii.gt.nres) then
5136           iii=ii-nres
5137           jjj=jj-nres
5138         else
5139           iii=ii
5140           jjj=jj
5141         endif
5142 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5143 c     &    dhpb(i),dhpb1(i),forcon(i)
5144 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5145 C    distance and angle dependent SS bond potential.
5146 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5147 C     & iabs(itype(jjj)).eq.1) then
5148 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5149 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5150         if (.not.dyn_ss .and. i.le.nss) then
5151 C 15/02/13 CC dynamic SSbond - additional check
5152          if (ii.gt.nres
5153      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5154           call ssbond_ene(iii,jjj,eij)
5155           ehpb=ehpb+2*eij
5156          endif
5157 cd          write (iout,*) "eij",eij
5158         else
5159 C Calculate the distance between the two points and its difference from the
5160 C target distance.
5161           dd=dist(ii,jj)
5162             rdis=dd-dhpb(i)
5163 C Get the force constant corresponding to this distance.
5164             waga=forcon(i)
5165 C Calculate the contribution to energy.
5166             ehpb=ehpb+waga*rdis*rdis
5167 C
5168 C Evaluate gradient.
5169 C
5170             fac=waga*rdis/dd
5171 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5172 cd   &   ' waga=',waga,' fac=',fac
5173             do j=1,3
5174               ggg(j)=fac*(c(j,jj)-c(j,ii))
5175             enddo
5176 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5177 C If this is a SC-SC distance, we need to calculate the contributions to the
5178 C Cartesian gradient in the SC vectors (ghpbx).
5179           if (iii.lt.ii) then
5180           do j=1,3
5181             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5182             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5183           enddo
5184           endif
5185 cgrad        do j=iii,jjj-1
5186 cgrad          do k=1,3
5187 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5188 cgrad          enddo
5189 cgrad        enddo
5190           do k=1,3
5191             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5192             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5193           enddo
5194         endif
5195       enddo
5196       ehpb=0.5D0*ehpb
5197       return
5198       end
5199 C--------------------------------------------------------------------------
5200       subroutine ssbond_ene(i,j,eij)
5201 C
5202 C Calculate the distance and angle dependent SS-bond potential energy
5203 C using a free-energy function derived based on RHF/6-31G** ab initio
5204 C calculations of diethyl disulfide.
5205 C
5206 C A. Liwo and U. Kozlowska, 11/24/03
5207 C
5208       implicit real*8 (a-h,o-z)
5209       include 'DIMENSIONS'
5210       include 'COMMON.SBRIDGE'
5211       include 'COMMON.CHAIN'
5212       include 'COMMON.DERIV'
5213       include 'COMMON.LOCAL'
5214       include 'COMMON.INTERACT'
5215       include 'COMMON.VAR'
5216       include 'COMMON.IOUNITS'
5217       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5218       itypi=iabs(itype(i))
5219       xi=c(1,nres+i)
5220       yi=c(2,nres+i)
5221       zi=c(3,nres+i)
5222       dxi=dc_norm(1,nres+i)
5223       dyi=dc_norm(2,nres+i)
5224       dzi=dc_norm(3,nres+i)
5225 c      dsci_inv=dsc_inv(itypi)
5226       dsci_inv=vbld_inv(nres+i)
5227       itypj=iabs(itype(j))
5228 c      dscj_inv=dsc_inv(itypj)
5229       dscj_inv=vbld_inv(nres+j)
5230       xj=c(1,nres+j)-xi
5231       yj=c(2,nres+j)-yi
5232       zj=c(3,nres+j)-zi
5233       dxj=dc_norm(1,nres+j)
5234       dyj=dc_norm(2,nres+j)
5235       dzj=dc_norm(3,nres+j)
5236       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5237       rij=dsqrt(rrij)
5238       erij(1)=xj*rij
5239       erij(2)=yj*rij
5240       erij(3)=zj*rij
5241       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5242       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5243       om12=dxi*dxj+dyi*dyj+dzi*dzj
5244       do k=1,3
5245         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5246         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5247       enddo
5248       rij=1.0d0/rij
5249       deltad=rij-d0cm
5250       deltat1=1.0d0-om1
5251       deltat2=1.0d0+om2
5252       deltat12=om2-om1+2.0d0
5253       cosphi=om12-om1*om2
5254       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5255      &  +akct*deltad*deltat12
5256      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5257 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5258 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5259 c     &  " deltat12",deltat12," eij",eij
5260       ed=2*akcm*deltad+akct*deltat12
5261       pom1=akct*deltad
5262       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5263       eom1=-2*akth*deltat1-pom1-om2*pom2
5264       eom2= 2*akth*deltat2+pom1-om1*pom2
5265       eom12=pom2
5266       do k=1,3
5267         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5268         ghpbx(k,i)=ghpbx(k,i)-ggk
5269      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5270      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5271         ghpbx(k,j)=ghpbx(k,j)+ggk
5272      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5273      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5274         ghpbc(k,i)=ghpbc(k,i)-ggk
5275         ghpbc(k,j)=ghpbc(k,j)+ggk
5276       enddo
5277 C
5278 C Calculate the components of the gradient in DC and X
5279 C
5280 cgrad      do k=i,j-1
5281 cgrad        do l=1,3
5282 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5283 cgrad        enddo
5284 cgrad      enddo
5285       return
5286       end
5287 C--------------------------------------------------------------------------
5288       subroutine ebond(estr)
5289 c
5290 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5291 c
5292       implicit real*8 (a-h,o-z)
5293       include 'DIMENSIONS'
5294       include 'COMMON.LOCAL'
5295       include 'COMMON.GEO'
5296       include 'COMMON.INTERACT'
5297       include 'COMMON.DERIV'
5298       include 'COMMON.VAR'
5299       include 'COMMON.CHAIN'
5300       include 'COMMON.IOUNITS'
5301       include 'COMMON.NAMES'
5302       include 'COMMON.FFIELD'
5303       include 'COMMON.CONTROL'
5304       include 'COMMON.SETUP'
5305       double precision u(3),ud(3)
5306       estr=0.0d0
5307       estr1=0.0d0
5308       do i=ibondp_start,ibondp_end
5309         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5310 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5311 c          do j=1,3
5312 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5313 c     &      *dc(j,i-1)/vbld(i)
5314 c          enddo
5315 c          if (energy_dec) write(iout,*)
5316 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5317 c        else
5318 C       Checking if it involves dummy (NH3+ or COO-) group
5319          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5320 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5321         diff = vbld(i)-vbldpDUM
5322          else
5323 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5324         diff = vbld(i)-vbldp0
5325          endif
5326         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5327      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5328         estr=estr+diff*diff
5329         do j=1,3
5330           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5331         enddo
5332 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5333 c        endif
5334       enddo
5335       estr=0.5d0*AKP*estr+estr1
5336 c
5337 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5338 c
5339       do i=ibond_start,ibond_end
5340         iti=iabs(itype(i))
5341         if (iti.ne.10 .and. iti.ne.ntyp1) then
5342           nbi=nbondterm(iti)
5343           if (nbi.eq.1) then
5344             diff=vbld(i+nres)-vbldsc0(1,iti)
5345             if (energy_dec)  write (iout,*)
5346      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5347      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5348             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5349             do j=1,3
5350               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5351             enddo
5352           else
5353             do j=1,nbi
5354               diff=vbld(i+nres)-vbldsc0(j,iti)
5355               ud(j)=aksc(j,iti)*diff
5356               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5357             enddo
5358             uprod=u(1)
5359             do j=2,nbi
5360               uprod=uprod*u(j)
5361             enddo
5362             usum=0.0d0
5363             usumsqder=0.0d0
5364             do j=1,nbi
5365               uprod1=1.0d0
5366               uprod2=1.0d0
5367               do k=1,nbi
5368                 if (k.ne.j) then
5369                   uprod1=uprod1*u(k)
5370                   uprod2=uprod2*u(k)*u(k)
5371                 endif
5372               enddo
5373               usum=usum+uprod1
5374               usumsqder=usumsqder+ud(j)*uprod2
5375             enddo
5376             estr=estr+uprod/usum
5377             do j=1,3
5378              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5379             enddo
5380           endif
5381         endif
5382       enddo
5383       return
5384       end
5385 #ifdef CRYST_THETA
5386 C--------------------------------------------------------------------------
5387       subroutine ebend(etheta)
5388 C
5389 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5390 C angles gamma and its derivatives in consecutive thetas and gammas.
5391 C
5392       implicit real*8 (a-h,o-z)
5393       include 'DIMENSIONS'
5394       include 'COMMON.LOCAL'
5395       include 'COMMON.GEO'
5396       include 'COMMON.INTERACT'
5397       include 'COMMON.DERIV'
5398       include 'COMMON.VAR'
5399       include 'COMMON.CHAIN'
5400       include 'COMMON.IOUNITS'
5401       include 'COMMON.NAMES'
5402       include 'COMMON.FFIELD'
5403       include 'COMMON.CONTROL'
5404       common /calcthet/ term1,term2,termm,diffak,ratak,
5405      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5406      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5407       double precision y(2),z(2)
5408       delta=0.02d0*pi
5409 c      time11=dexp(-2*time)
5410 c      time12=1.0d0
5411       etheta=0.0D0
5412 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5413       do i=ithet_start,ithet_end
5414         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5415      &  .or.itype(i).eq.ntyp1) cycle
5416 C Zero the energy function and its derivative at 0 or pi.
5417         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5418         it=itype(i-1)
5419         ichir1=isign(1,itype(i-2))
5420         ichir2=isign(1,itype(i))
5421          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5422          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5423          if (itype(i-1).eq.10) then
5424           itype1=isign(10,itype(i-2))
5425           ichir11=isign(1,itype(i-2))
5426           ichir12=isign(1,itype(i-2))
5427           itype2=isign(10,itype(i))
5428           ichir21=isign(1,itype(i))
5429           ichir22=isign(1,itype(i))
5430          endif
5431
5432         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5433 #ifdef OSF
5434           phii=phi(i)
5435           if (phii.ne.phii) phii=150.0
5436 #else
5437           phii=phi(i)
5438 #endif
5439           y(1)=dcos(phii)
5440           y(2)=dsin(phii)
5441         else
5442           y(1)=0.0D0
5443           y(2)=0.0D0
5444         endif
5445         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5446 #ifdef OSF
5447           phii1=phi(i+1)
5448           if (phii1.ne.phii1) phii1=150.0
5449           phii1=pinorm(phii1)
5450           z(1)=cos(phii1)
5451 #else
5452           phii1=phi(i+1)
5453 #endif
5454           z(1)=dcos(phii1)
5455           z(2)=dsin(phii1)
5456         else
5457           z(1)=0.0D0
5458           z(2)=0.0D0
5459         endif
5460 C Calculate the "mean" value of theta from the part of the distribution
5461 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5462 C In following comments this theta will be referred to as t_c.
5463         thet_pred_mean=0.0d0
5464         do k=1,2
5465             athetk=athet(k,it,ichir1,ichir2)
5466             bthetk=bthet(k,it,ichir1,ichir2)
5467           if (it.eq.10) then
5468              athetk=athet(k,itype1,ichir11,ichir12)
5469              bthetk=bthet(k,itype2,ichir21,ichir22)
5470           endif
5471          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5472 c         write(iout,*) 'chuj tu', y(k),z(k)
5473         enddo
5474         dthett=thet_pred_mean*ssd
5475         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5476 C Derivatives of the "mean" values in gamma1 and gamma2.
5477         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5478      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5479          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5480      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5481          if (it.eq.10) then
5482       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5483      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5484         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5485      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5486          endif
5487         if (theta(i).gt.pi-delta) then
5488           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5489      &         E_tc0)
5490           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5491           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5492           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5493      &        E_theta)
5494           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5495      &        E_tc)
5496         else if (theta(i).lt.delta) then
5497           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5498           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5499           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5500      &        E_theta)
5501           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5502           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5503      &        E_tc)
5504         else
5505           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5506      &        E_theta,E_tc)
5507         endif
5508         etheta=etheta+ethetai
5509         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5510      &      'ebend',i,ethetai,theta(i),itype(i)
5511         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5512         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5513         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5514       enddo
5515 C Ufff.... We've done all this!!!
5516       return
5517       end
5518 C---------------------------------------------------------------------------
5519       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5520      &     E_tc)
5521       implicit real*8 (a-h,o-z)
5522       include 'DIMENSIONS'
5523       include 'COMMON.LOCAL'
5524       include 'COMMON.IOUNITS'
5525       common /calcthet/ term1,term2,termm,diffak,ratak,
5526      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5527      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5528 C Calculate the contributions to both Gaussian lobes.
5529 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5530 C The "polynomial part" of the "standard deviation" of this part of
5531 C the distributioni.
5532 ccc        write (iout,*) thetai,thet_pred_mean
5533         sig=polthet(3,it)
5534         do j=2,0,-1
5535           sig=sig*thet_pred_mean+polthet(j,it)
5536         enddo
5537 C Derivative of the "interior part" of the "standard deviation of the"
5538 C gamma-dependent Gaussian lobe in t_c.
5539         sigtc=3*polthet(3,it)
5540         do j=2,1,-1
5541           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5542         enddo
5543         sigtc=sig*sigtc
5544 C Set the parameters of both Gaussian lobes of the distribution.
5545 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5546         fac=sig*sig+sigc0(it)
5547         sigcsq=fac+fac
5548         sigc=1.0D0/sigcsq
5549 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5550         sigsqtc=-4.0D0*sigcsq*sigtc
5551 c       print *,i,sig,sigtc,sigsqtc
5552 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5553         sigtc=-sigtc/(fac*fac)
5554 C Following variable is sigma(t_c)**(-2)
5555         sigcsq=sigcsq*sigcsq
5556         sig0i=sig0(it)
5557         sig0inv=1.0D0/sig0i**2
5558         delthec=thetai-thet_pred_mean
5559         delthe0=thetai-theta0i
5560         term1=-0.5D0*sigcsq*delthec*delthec
5561         term2=-0.5D0*sig0inv*delthe0*delthe0
5562 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5563 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5564 C NaNs in taking the logarithm. We extract the largest exponent which is added
5565 C to the energy (this being the log of the distribution) at the end of energy
5566 C term evaluation for this virtual-bond angle.
5567         if (term1.gt.term2) then
5568           termm=term1
5569           term2=dexp(term2-termm)
5570           term1=1.0d0
5571         else
5572           termm=term2
5573           term1=dexp(term1-termm)
5574           term2=1.0d0
5575         endif
5576 C The ratio between the gamma-independent and gamma-dependent lobes of
5577 C the distribution is a Gaussian function of thet_pred_mean too.
5578         diffak=gthet(2,it)-thet_pred_mean
5579         ratak=diffak/gthet(3,it)**2
5580         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5581 C Let's differentiate it in thet_pred_mean NOW.
5582         aktc=ak*ratak
5583 C Now put together the distribution terms to make complete distribution.
5584         termexp=term1+ak*term2
5585         termpre=sigc+ak*sig0i
5586 C Contribution of the bending energy from this theta is just the -log of
5587 C the sum of the contributions from the two lobes and the pre-exponential
5588 C factor. Simple enough, isn't it?
5589         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5590 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5591 C NOW the derivatives!!!
5592 C 6/6/97 Take into account the deformation.
5593         E_theta=(delthec*sigcsq*term1
5594      &       +ak*delthe0*sig0inv*term2)/termexp
5595         E_tc=((sigtc+aktc*sig0i)/termpre
5596      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5597      &       aktc*term2)/termexp)
5598       return
5599       end
5600 c-----------------------------------------------------------------------------
5601       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'COMMON.LOCAL'
5605       include 'COMMON.IOUNITS'
5606       common /calcthet/ term1,term2,termm,diffak,ratak,
5607      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5608      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5609       delthec=thetai-thet_pred_mean
5610       delthe0=thetai-theta0i
5611 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5612       t3 = thetai-thet_pred_mean
5613       t6 = t3**2
5614       t9 = term1
5615       t12 = t3*sigcsq
5616       t14 = t12+t6*sigsqtc
5617       t16 = 1.0d0
5618       t21 = thetai-theta0i
5619       t23 = t21**2
5620       t26 = term2
5621       t27 = t21*t26
5622       t32 = termexp
5623       t40 = t32**2
5624       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5625      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5626      & *(-t12*t9-ak*sig0inv*t27)
5627       return
5628       end
5629 #else
5630 C--------------------------------------------------------------------------
5631       subroutine ebend(etheta)
5632 C
5633 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5634 C angles gamma and its derivatives in consecutive thetas and gammas.
5635 C ab initio-derived potentials from
5636 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5637 C
5638       implicit real*8 (a-h,o-z)
5639       include 'DIMENSIONS'
5640       include 'COMMON.LOCAL'
5641       include 'COMMON.GEO'
5642       include 'COMMON.INTERACT'
5643       include 'COMMON.DERIV'
5644       include 'COMMON.VAR'
5645       include 'COMMON.CHAIN'
5646       include 'COMMON.IOUNITS'
5647       include 'COMMON.NAMES'
5648       include 'COMMON.FFIELD'
5649       include 'COMMON.CONTROL'
5650       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5651      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5652      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5653      & sinph1ph2(maxdouble,maxdouble)
5654       logical lprn /.false./, lprn1 /.false./
5655       etheta=0.0D0
5656       do i=ithet_start,ithet_end
5657 c        print *,i,itype(i-1),itype(i),itype(i-2)
5658         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5659      &  .or.itype(i).eq.ntyp1) cycle
5660 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5661
5662         if (iabs(itype(i+1)).eq.20) iblock=2
5663         if (iabs(itype(i+1)).ne.20) iblock=1
5664         dethetai=0.0d0
5665         dephii=0.0d0
5666         dephii1=0.0d0
5667         theti2=0.5d0*theta(i)
5668         ityp2=ithetyp((itype(i-1)))
5669         do k=1,nntheterm
5670           coskt(k)=dcos(k*theti2)
5671           sinkt(k)=dsin(k*theti2)
5672         enddo
5673         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5674 #ifdef OSF
5675           phii=phi(i)
5676           if (phii.ne.phii) phii=150.0
5677 #else
5678           phii=phi(i)
5679 #endif
5680           ityp1=ithetyp((itype(i-2)))
5681 C propagation of chirality for glycine type
5682           do k=1,nsingle
5683             cosph1(k)=dcos(k*phii)
5684             sinph1(k)=dsin(k*phii)
5685           enddo
5686         else
5687           phii=0.0d0
5688           ityp1=nthetyp+1
5689           do k=1,nsingle
5690             cosph1(k)=0.0d0
5691             sinph1(k)=0.0d0
5692           enddo
5693         endif
5694         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5695 #ifdef OSF
5696           phii1=phi(i+1)
5697           if (phii1.ne.phii1) phii1=150.0
5698           phii1=pinorm(phii1)
5699 #else
5700           phii1=phi(i+1)
5701 #endif
5702           ityp3=ithetyp((itype(i)))
5703           do k=1,nsingle
5704             cosph2(k)=dcos(k*phii1)
5705             sinph2(k)=dsin(k*phii1)
5706           enddo
5707         else
5708           phii1=0.0d0
5709           ityp3=nthetyp+1
5710           do k=1,nsingle
5711             cosph2(k)=0.0d0
5712             sinph2(k)=0.0d0
5713           enddo
5714         endif
5715         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5716         do k=1,ndouble
5717           do l=1,k-1
5718             ccl=cosph1(l)*cosph2(k-l)
5719             ssl=sinph1(l)*sinph2(k-l)
5720             scl=sinph1(l)*cosph2(k-l)
5721             csl=cosph1(l)*sinph2(k-l)
5722             cosph1ph2(l,k)=ccl-ssl
5723             cosph1ph2(k,l)=ccl+ssl
5724             sinph1ph2(l,k)=scl+csl
5725             sinph1ph2(k,l)=scl-csl
5726           enddo
5727         enddo
5728         if (lprn) then
5729         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5730      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5731         write (iout,*) "coskt and sinkt"
5732         do k=1,nntheterm
5733           write (iout,*) k,coskt(k),sinkt(k)
5734         enddo
5735         endif
5736         do k=1,ntheterm
5737           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5738           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5739      &      *coskt(k)
5740           if (lprn)
5741      &    write (iout,*) "k",k,"
5742      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5743      &     " ethetai",ethetai
5744         enddo
5745         if (lprn) then
5746         write (iout,*) "cosph and sinph"
5747         do k=1,nsingle
5748           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5749         enddo
5750         write (iout,*) "cosph1ph2 and sinph2ph2"
5751         do k=2,ndouble
5752           do l=1,k-1
5753             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5754      &         sinph1ph2(l,k),sinph1ph2(k,l)
5755           enddo
5756         enddo
5757         write(iout,*) "ethetai",ethetai
5758         endif
5759         do m=1,ntheterm2
5760           do k=1,nsingle
5761             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5762      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5763      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5764      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5765             ethetai=ethetai+sinkt(m)*aux
5766             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5767             dephii=dephii+k*sinkt(m)*(
5768      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5769      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5770             dephii1=dephii1+k*sinkt(m)*(
5771      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5772      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5773             if (lprn)
5774      &      write (iout,*) "m",m," k",k," bbthet",
5775      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5776      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5777      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5778      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5779           enddo
5780         enddo
5781         if (lprn)
5782      &  write(iout,*) "ethetai",ethetai
5783         do m=1,ntheterm3
5784           do k=2,ndouble
5785             do l=1,k-1
5786               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5787      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5788      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5789      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5790               ethetai=ethetai+sinkt(m)*aux
5791               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5792               dephii=dephii+l*sinkt(m)*(
5793      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5794      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5795      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5796      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5797               dephii1=dephii1+(k-l)*sinkt(m)*(
5798      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5799      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5800      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5801      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5802               if (lprn) then
5803               write (iout,*) "m",m," k",k," l",l," ffthet",
5804      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5805      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5806      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5807      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5808      &            " ethetai",ethetai
5809               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5810      &            cosph1ph2(k,l)*sinkt(m),
5811      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5812               endif
5813             enddo
5814           enddo
5815         enddo
5816 10      continue
5817 c        lprn1=.true.
5818         if (lprn1)
5819      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5820      &   i,theta(i)*rad2deg,phii*rad2deg,
5821      &   phii1*rad2deg,ethetai
5822 c        lprn1=.false.
5823         etheta=etheta+ethetai
5824         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5825         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5826         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5827       enddo
5828       return
5829       end
5830 #endif
5831 #ifdef CRYST_SC
5832 c-----------------------------------------------------------------------------
5833       subroutine esc(escloc)
5834 C Calculate the local energy of a side chain and its derivatives in the
5835 C corresponding virtual-bond valence angles THETA and the spherical angles
5836 C ALPHA and OMEGA.
5837       implicit real*8 (a-h,o-z)
5838       include 'DIMENSIONS'
5839       include 'COMMON.GEO'
5840       include 'COMMON.LOCAL'
5841       include 'COMMON.VAR'
5842       include 'COMMON.INTERACT'
5843       include 'COMMON.DERIV'
5844       include 'COMMON.CHAIN'
5845       include 'COMMON.IOUNITS'
5846       include 'COMMON.NAMES'
5847       include 'COMMON.FFIELD'
5848       include 'COMMON.CONTROL'
5849       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5850      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5851       common /sccalc/ time11,time12,time112,theti,it,nlobit
5852       delta=0.02d0*pi
5853       escloc=0.0D0
5854 c     write (iout,'(a)') 'ESC'
5855       do i=loc_start,loc_end
5856         it=itype(i)
5857         if (it.eq.ntyp1) cycle
5858         if (it.eq.10) goto 1
5859         nlobit=nlob(iabs(it))
5860 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5861 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5862         theti=theta(i+1)-pipol
5863         x(1)=dtan(theti)
5864         x(2)=alph(i)
5865         x(3)=omeg(i)
5866
5867         if (x(2).gt.pi-delta) then
5868           xtemp(1)=x(1)
5869           xtemp(2)=pi-delta
5870           xtemp(3)=x(3)
5871           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5872           xtemp(2)=pi
5873           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5874           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5875      &        escloci,dersc(2))
5876           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5877      &        ddersc0(1),dersc(1))
5878           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5879      &        ddersc0(3),dersc(3))
5880           xtemp(2)=pi-delta
5881           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5882           xtemp(2)=pi
5883           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5884           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5885      &            dersc0(2),esclocbi,dersc02)
5886           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5887      &            dersc12,dersc01)
5888           call splinthet(x(2),0.5d0*delta,ss,ssd)
5889           dersc0(1)=dersc01
5890           dersc0(2)=dersc02
5891           dersc0(3)=0.0d0
5892           do k=1,3
5893             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5894           enddo
5895           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5896 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5897 c    &             esclocbi,ss,ssd
5898           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5899 c         escloci=esclocbi
5900 c         write (iout,*) escloci
5901         else if (x(2).lt.delta) then
5902           xtemp(1)=x(1)
5903           xtemp(2)=delta
5904           xtemp(3)=x(3)
5905           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5906           xtemp(2)=0.0d0
5907           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5908           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5909      &        escloci,dersc(2))
5910           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5911      &        ddersc0(1),dersc(1))
5912           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5913      &        ddersc0(3),dersc(3))
5914           xtemp(2)=delta
5915           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5916           xtemp(2)=0.0d0
5917           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5918           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5919      &            dersc0(2),esclocbi,dersc02)
5920           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5921      &            dersc12,dersc01)
5922           dersc0(1)=dersc01
5923           dersc0(2)=dersc02
5924           dersc0(3)=0.0d0
5925           call splinthet(x(2),0.5d0*delta,ss,ssd)
5926           do k=1,3
5927             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5928           enddo
5929           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5930 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5931 c    &             esclocbi,ss,ssd
5932           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5933 c         write (iout,*) escloci
5934         else
5935           call enesc(x,escloci,dersc,ddummy,.false.)
5936         endif
5937
5938         escloc=escloc+escloci
5939         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5940      &     'escloc',i,escloci
5941 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5942
5943         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5944      &   wscloc*dersc(1)
5945         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5946         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5947     1   continue
5948       enddo
5949       return
5950       end
5951 C---------------------------------------------------------------------------
5952       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5953       implicit real*8 (a-h,o-z)
5954       include 'DIMENSIONS'
5955       include 'COMMON.GEO'
5956       include 'COMMON.LOCAL'
5957       include 'COMMON.IOUNITS'
5958       common /sccalc/ time11,time12,time112,theti,it,nlobit
5959       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5960       double precision contr(maxlob,-1:1)
5961       logical mixed
5962 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5963         escloc_i=0.0D0
5964         do j=1,3
5965           dersc(j)=0.0D0
5966           if (mixed) ddersc(j)=0.0d0
5967         enddo
5968         x3=x(3)
5969
5970 C Because of periodicity of the dependence of the SC energy in omega we have
5971 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5972 C To avoid underflows, first compute & store the exponents.
5973
5974         do iii=-1,1
5975
5976           x(3)=x3+iii*dwapi
5977
5978           do j=1,nlobit
5979             do k=1,3
5980               z(k)=x(k)-censc(k,j,it)
5981             enddo
5982             do k=1,3
5983               Axk=0.0D0
5984               do l=1,3
5985                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5986               enddo
5987               Ax(k,j,iii)=Axk
5988             enddo
5989             expfac=0.0D0
5990             do k=1,3
5991               expfac=expfac+Ax(k,j,iii)*z(k)
5992             enddo
5993             contr(j,iii)=expfac
5994           enddo ! j
5995
5996         enddo ! iii
5997
5998         x(3)=x3
5999 C As in the case of ebend, we want to avoid underflows in exponentiation and
6000 C subsequent NaNs and INFs in energy calculation.
6001 C Find the largest exponent
6002         emin=contr(1,-1)
6003         do iii=-1,1
6004           do j=1,nlobit
6005             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6006           enddo
6007         enddo
6008         emin=0.5D0*emin
6009 cd      print *,'it=',it,' emin=',emin
6010
6011 C Compute the contribution to SC energy and derivatives
6012         do iii=-1,1
6013
6014           do j=1,nlobit
6015 #ifdef OSF
6016             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6017             if(adexp.ne.adexp) adexp=1.0
6018             expfac=dexp(adexp)
6019 #else
6020             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6021 #endif
6022 cd          print *,'j=',j,' expfac=',expfac
6023             escloc_i=escloc_i+expfac
6024             do k=1,3
6025               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6026             enddo
6027             if (mixed) then
6028               do k=1,3,2
6029                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6030      &            +gaussc(k,2,j,it))*expfac
6031               enddo
6032             endif
6033           enddo
6034
6035         enddo ! iii
6036
6037         dersc(1)=dersc(1)/cos(theti)**2
6038         ddersc(1)=ddersc(1)/cos(theti)**2
6039         ddersc(3)=ddersc(3)
6040
6041         escloci=-(dlog(escloc_i)-emin)
6042         do j=1,3
6043           dersc(j)=dersc(j)/escloc_i
6044         enddo
6045         if (mixed) then
6046           do j=1,3,2
6047             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6048           enddo
6049         endif
6050       return
6051       end
6052 C------------------------------------------------------------------------------
6053       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6054       implicit real*8 (a-h,o-z)
6055       include 'DIMENSIONS'
6056       include 'COMMON.GEO'
6057       include 'COMMON.LOCAL'
6058       include 'COMMON.IOUNITS'
6059       common /sccalc/ time11,time12,time112,theti,it,nlobit
6060       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6061       double precision contr(maxlob)
6062       logical mixed
6063
6064       escloc_i=0.0D0
6065
6066       do j=1,3
6067         dersc(j)=0.0D0
6068       enddo
6069
6070       do j=1,nlobit
6071         do k=1,2
6072           z(k)=x(k)-censc(k,j,it)
6073         enddo
6074         z(3)=dwapi
6075         do k=1,3
6076           Axk=0.0D0
6077           do l=1,3
6078             Axk=Axk+gaussc(l,k,j,it)*z(l)
6079           enddo
6080           Ax(k,j)=Axk
6081         enddo
6082         expfac=0.0D0
6083         do k=1,3
6084           expfac=expfac+Ax(k,j)*z(k)
6085         enddo
6086         contr(j)=expfac
6087       enddo ! j
6088
6089 C As in the case of ebend, we want to avoid underflows in exponentiation and
6090 C subsequent NaNs and INFs in energy calculation.
6091 C Find the largest exponent
6092       emin=contr(1)
6093       do j=1,nlobit
6094         if (emin.gt.contr(j)) emin=contr(j)
6095       enddo
6096       emin=0.5D0*emin
6097
6098 C Compute the contribution to SC energy and derivatives
6099
6100       dersc12=0.0d0
6101       do j=1,nlobit
6102         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6103         escloc_i=escloc_i+expfac
6104         do k=1,2
6105           dersc(k)=dersc(k)+Ax(k,j)*expfac
6106         enddo
6107         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6108      &            +gaussc(1,2,j,it))*expfac
6109         dersc(3)=0.0d0
6110       enddo
6111
6112       dersc(1)=dersc(1)/cos(theti)**2
6113       dersc12=dersc12/cos(theti)**2
6114       escloci=-(dlog(escloc_i)-emin)
6115       do j=1,2
6116         dersc(j)=dersc(j)/escloc_i
6117       enddo
6118       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6119       return
6120       end
6121 #else
6122 c----------------------------------------------------------------------------------
6123       subroutine esc(escloc)
6124 C Calculate the local energy of a side chain and its derivatives in the
6125 C corresponding virtual-bond valence angles THETA and the spherical angles
6126 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6127 C added by Urszula Kozlowska. 07/11/2007
6128 C
6129       implicit real*8 (a-h,o-z)
6130       include 'DIMENSIONS'
6131       include 'COMMON.GEO'
6132       include 'COMMON.LOCAL'
6133       include 'COMMON.VAR'
6134       include 'COMMON.SCROT'
6135       include 'COMMON.INTERACT'
6136       include 'COMMON.DERIV'
6137       include 'COMMON.CHAIN'
6138       include 'COMMON.IOUNITS'
6139       include 'COMMON.NAMES'
6140       include 'COMMON.FFIELD'
6141       include 'COMMON.CONTROL'
6142       include 'COMMON.VECTORS'
6143       double precision x_prime(3),y_prime(3),z_prime(3)
6144      &    , sumene,dsc_i,dp2_i,x(65),
6145      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6146      &    de_dxx,de_dyy,de_dzz,de_dt
6147       double precision s1_t,s1_6_t,s2_t,s2_6_t
6148       double precision
6149      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6150      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6151      & dt_dCi(3),dt_dCi1(3)
6152       common /sccalc/ time11,time12,time112,theti,it,nlobit
6153       delta=0.02d0*pi
6154       escloc=0.0D0
6155       do i=loc_start,loc_end
6156         if (itype(i).eq.ntyp1) cycle
6157         costtab(i+1) =dcos(theta(i+1))
6158         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6159         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6160         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6161         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6162         cosfac=dsqrt(cosfac2)
6163         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6164         sinfac=dsqrt(sinfac2)
6165         it=iabs(itype(i))
6166         if (it.eq.10) goto 1
6167 c
6168 C  Compute the axes of tghe local cartesian coordinates system; store in
6169 c   x_prime, y_prime and z_prime
6170 c
6171         do j=1,3
6172           x_prime(j) = 0.00
6173           y_prime(j) = 0.00
6174           z_prime(j) = 0.00
6175         enddo
6176 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6177 C     &   dc_norm(3,i+nres)
6178         do j = 1,3
6179           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6180           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6181         enddo
6182         do j = 1,3
6183           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6184         enddo
6185 c       write (2,*) "i",i
6186 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6187 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6188 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6189 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6190 c      & " xy",scalar(x_prime(1),y_prime(1)),
6191 c      & " xz",scalar(x_prime(1),z_prime(1)),
6192 c      & " yy",scalar(y_prime(1),y_prime(1)),
6193 c      & " yz",scalar(y_prime(1),z_prime(1)),
6194 c      & " zz",scalar(z_prime(1),z_prime(1))
6195 c
6196 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6197 C to local coordinate system. Store in xx, yy, zz.
6198 c
6199         xx=0.0d0
6200         yy=0.0d0
6201         zz=0.0d0
6202         do j = 1,3
6203           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6204           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6205           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6206         enddo
6207
6208         xxtab(i)=xx
6209         yytab(i)=yy
6210         zztab(i)=zz
6211 C
6212 C Compute the energy of the ith side cbain
6213 C
6214 c        write (2,*) "xx",xx," yy",yy," zz",zz
6215         it=iabs(itype(i))
6216         do j = 1,65
6217           x(j) = sc_parmin(j,it)
6218         enddo
6219 #ifdef CHECK_COORD
6220 Cc diagnostics - remove later
6221         xx1 = dcos(alph(2))
6222         yy1 = dsin(alph(2))*dcos(omeg(2))
6223         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6224         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6225      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6226      &    xx1,yy1,zz1
6227 C,"  --- ", xx_w,yy_w,zz_w
6228 c end diagnostics
6229 #endif
6230         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6231      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6232      &   + x(10)*yy*zz
6233         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6234      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6235      & + x(20)*yy*zz
6236         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6237      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6238      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6239      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6240      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6241      &  +x(40)*xx*yy*zz
6242         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6243      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6244      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6245      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6246      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6247      &  +x(60)*xx*yy*zz
6248         dsc_i   = 0.743d0+x(61)
6249         dp2_i   = 1.9d0+x(62)
6250         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6251      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6252         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6253      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6254         s1=(1+x(63))/(0.1d0 + dscp1)
6255         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6256         s2=(1+x(65))/(0.1d0 + dscp2)
6257         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6258         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6259      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6260 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6261 c     &   sumene4,
6262 c     &   dscp1,dscp2,sumene
6263 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6264         escloc = escloc + sumene
6265 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6266 c     & ,zz,xx,yy
6267 c#define DEBUG
6268 #ifdef DEBUG
6269 C
6270 C This section to check the numerical derivatives of the energy of ith side
6271 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6272 C #define DEBUG in the code to turn it on.
6273 C
6274         write (2,*) "sumene               =",sumene
6275         aincr=1.0d-7
6276         xxsave=xx
6277         xx=xx+aincr
6278         write (2,*) xx,yy,zz
6279         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6280         de_dxx_num=(sumenep-sumene)/aincr
6281         xx=xxsave
6282         write (2,*) "xx+ sumene from enesc=",sumenep
6283         yysave=yy
6284         yy=yy+aincr
6285         write (2,*) xx,yy,zz
6286         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6287         de_dyy_num=(sumenep-sumene)/aincr
6288         yy=yysave
6289         write (2,*) "yy+ sumene from enesc=",sumenep
6290         zzsave=zz
6291         zz=zz+aincr
6292         write (2,*) xx,yy,zz
6293         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6294         de_dzz_num=(sumenep-sumene)/aincr
6295         zz=zzsave
6296         write (2,*) "zz+ sumene from enesc=",sumenep
6297         costsave=cost2tab(i+1)
6298         sintsave=sint2tab(i+1)
6299         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6300         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6301         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6302         de_dt_num=(sumenep-sumene)/aincr
6303         write (2,*) " t+ sumene from enesc=",sumenep
6304         cost2tab(i+1)=costsave
6305         sint2tab(i+1)=sintsave
6306 C End of diagnostics section.
6307 #endif
6308 C
6309 C Compute the gradient of esc
6310 C
6311 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6312         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6313         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6314         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6315         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6316         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6317         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6318         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6319         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6320         pom1=(sumene3*sint2tab(i+1)+sumene1)
6321      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6322         pom2=(sumene4*cost2tab(i+1)+sumene2)
6323      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6324         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6325         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6326      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6327      &  +x(40)*yy*zz
6328         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6329         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6330      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6331      &  +x(60)*yy*zz
6332         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6333      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6334      &        +(pom1+pom2)*pom_dx
6335 #ifdef DEBUG
6336         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6337 #endif
6338 C
6339         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6340         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6341      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6342      &  +x(40)*xx*zz
6343         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6344         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6345      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6346      &  +x(59)*zz**2 +x(60)*xx*zz
6347         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6348      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6349      &        +(pom1-pom2)*pom_dy
6350 #ifdef DEBUG
6351         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6352 #endif
6353 C
6354         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6355      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6356      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6357      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6358      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6359      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6360      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6361      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6362 #ifdef DEBUG
6363         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6364 #endif
6365 C
6366         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6367      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6368      &  +pom1*pom_dt1+pom2*pom_dt2
6369 #ifdef DEBUG
6370         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6371 #endif
6372 c#undef DEBUG
6373 c
6374 C
6375        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6376        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6377        cosfac2xx=cosfac2*xx
6378        sinfac2yy=sinfac2*yy
6379        do k = 1,3
6380          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6381      &      vbld_inv(i+1)
6382          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6383      &      vbld_inv(i)
6384          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6385          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6386 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6387 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6388 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6389 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6390          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6391          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6392          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6393          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6394          dZZ_Ci1(k)=0.0d0
6395          dZZ_Ci(k)=0.0d0
6396          do j=1,3
6397            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6398      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6399            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6400      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6401          enddo
6402
6403          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6404          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6405          dZZ_XYZ(k)=vbld_inv(i+nres)*
6406      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6407 c
6408          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6409          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6410        enddo
6411
6412        do k=1,3
6413          dXX_Ctab(k,i)=dXX_Ci(k)
6414          dXX_C1tab(k,i)=dXX_Ci1(k)
6415          dYY_Ctab(k,i)=dYY_Ci(k)
6416          dYY_C1tab(k,i)=dYY_Ci1(k)
6417          dZZ_Ctab(k,i)=dZZ_Ci(k)
6418          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6419          dXX_XYZtab(k,i)=dXX_XYZ(k)
6420          dYY_XYZtab(k,i)=dYY_XYZ(k)
6421          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6422        enddo
6423
6424        do k = 1,3
6425 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6426 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6427 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6428 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6429 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6430 c     &    dt_dci(k)
6431 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6432 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6433          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6434      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6435          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6436      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6437          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6438      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6439        enddo
6440 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6441 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6442
6443 C to check gradient call subroutine check_grad
6444
6445     1 continue
6446       enddo
6447       return
6448       end
6449 c------------------------------------------------------------------------------
6450       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6451       implicit none
6452       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6453      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6454       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6455      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6456      &   + x(10)*yy*zz
6457       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6458      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6459      & + x(20)*yy*zz
6460       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6461      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6462      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6463      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6464      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6465      &  +x(40)*xx*yy*zz
6466       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6467      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6468      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6469      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6470      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6471      &  +x(60)*xx*yy*zz
6472       dsc_i   = 0.743d0+x(61)
6473       dp2_i   = 1.9d0+x(62)
6474       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6475      &          *(xx*cost2+yy*sint2))
6476       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6477      &          *(xx*cost2-yy*sint2))
6478       s1=(1+x(63))/(0.1d0 + dscp1)
6479       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6480       s2=(1+x(65))/(0.1d0 + dscp2)
6481       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6482       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6483      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6484       enesc=sumene
6485       return
6486       end
6487 #endif
6488 c------------------------------------------------------------------------------
6489       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6490 C
6491 C This procedure calculates two-body contact function g(rij) and its derivative:
6492 C
6493 C           eps0ij                                     !       x < -1
6494 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6495 C            0                                         !       x > 1
6496 C
6497 C where x=(rij-r0ij)/delta
6498 C
6499 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6500 C
6501       implicit none
6502       double precision rij,r0ij,eps0ij,fcont,fprimcont
6503       double precision x,x2,x4,delta
6504 c     delta=0.02D0*r0ij
6505 c      delta=0.2D0*r0ij
6506       x=(rij-r0ij)/delta
6507       if (x.lt.-1.0D0) then
6508         fcont=eps0ij
6509         fprimcont=0.0D0
6510       else if (x.le.1.0D0) then
6511         x2=x*x
6512         x4=x2*x2
6513         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6514         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6515       else
6516         fcont=0.0D0
6517         fprimcont=0.0D0
6518       endif
6519       return
6520       end
6521 c------------------------------------------------------------------------------
6522       subroutine splinthet(theti,delta,ss,ssder)
6523       implicit real*8 (a-h,o-z)
6524       include 'DIMENSIONS'
6525       include 'COMMON.VAR'
6526       include 'COMMON.GEO'
6527       thetup=pi-delta
6528       thetlow=delta
6529       if (theti.gt.pipol) then
6530         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6531       else
6532         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6533         ssder=-ssder
6534       endif
6535       return
6536       end
6537 c------------------------------------------------------------------------------
6538       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6539       implicit none
6540       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6541       double precision ksi,ksi2,ksi3,a1,a2,a3
6542       a1=fprim0*delta/(f1-f0)
6543       a2=3.0d0-2.0d0*a1
6544       a3=a1-2.0d0
6545       ksi=(x-x0)/delta
6546       ksi2=ksi*ksi
6547       ksi3=ksi2*ksi
6548       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6549       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6550       return
6551       end
6552 c------------------------------------------------------------------------------
6553       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6554       implicit none
6555       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6556       double precision ksi,ksi2,ksi3,a1,a2,a3
6557       ksi=(x-x0)/delta
6558       ksi2=ksi*ksi
6559       ksi3=ksi2*ksi
6560       a1=fprim0x*delta
6561       a2=3*(f1x-f0x)-2*fprim0x*delta
6562       a3=fprim0x*delta-2*(f1x-f0x)
6563       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6564       return
6565       end
6566 C-----------------------------------------------------------------------------
6567 #ifdef CRYST_TOR
6568 C-----------------------------------------------------------------------------
6569       subroutine etor(etors,edihcnstr)
6570       implicit real*8 (a-h,o-z)
6571       include 'DIMENSIONS'
6572       include 'COMMON.VAR'
6573       include 'COMMON.GEO'
6574       include 'COMMON.LOCAL'
6575       include 'COMMON.TORSION'
6576       include 'COMMON.INTERACT'
6577       include 'COMMON.DERIV'
6578       include 'COMMON.CHAIN'
6579       include 'COMMON.NAMES'
6580       include 'COMMON.IOUNITS'
6581       include 'COMMON.FFIELD'
6582       include 'COMMON.TORCNSTR'
6583       include 'COMMON.CONTROL'
6584       logical lprn
6585 C Set lprn=.true. for debugging
6586       lprn=.false.
6587 c      lprn=.true.
6588       etors=0.0D0
6589       do i=iphi_start,iphi_end
6590       etors_ii=0.0D0
6591         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6592      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6593         itori=itortyp(itype(i-2))
6594         itori1=itortyp(itype(i-1))
6595         phii=phi(i)
6596         gloci=0.0D0
6597 C Proline-Proline pair is a special case...
6598         if (itori.eq.3 .and. itori1.eq.3) then
6599           if (phii.gt.-dwapi3) then
6600             cosphi=dcos(3*phii)
6601             fac=1.0D0/(1.0D0-cosphi)
6602             etorsi=v1(1,3,3)*fac
6603             etorsi=etorsi+etorsi
6604             etors=etors+etorsi-v1(1,3,3)
6605             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6606             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6607           endif
6608           do j=1,3
6609             v1ij=v1(j+1,itori,itori1)
6610             v2ij=v2(j+1,itori,itori1)
6611             cosphi=dcos(j*phii)
6612             sinphi=dsin(j*phii)
6613             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6614             if (energy_dec) etors_ii=etors_ii+
6615      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6616             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6617           enddo
6618         else
6619           do j=1,nterm_old
6620             v1ij=v1(j,itori,itori1)
6621             v2ij=v2(j,itori,itori1)
6622             cosphi=dcos(j*phii)
6623             sinphi=dsin(j*phii)
6624             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6625             if (energy_dec) etors_ii=etors_ii+
6626      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6627             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6628           enddo
6629         endif
6630         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6631              'etor',i,etors_ii
6632         if (lprn)
6633      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6634      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6635      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6636         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6637 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6638       enddo
6639 ! 6/20/98 - dihedral angle constraints
6640       edihcnstr=0.0d0
6641       do i=1,ndih_constr
6642         itori=idih_constr(i)
6643         phii=phi(itori)
6644         difi=phii-phi0(i)
6645         if (difi.gt.drange(i)) then
6646           difi=difi-drange(i)
6647           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6648           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6649         else if (difi.lt.-drange(i)) then
6650           difi=difi+drange(i)
6651           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6652           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6653         endif
6654 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6655 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6656       enddo
6657 !      write (iout,*) 'edihcnstr',edihcnstr
6658       return
6659       end
6660 c------------------------------------------------------------------------------
6661       subroutine etor_d(etors_d)
6662       etors_d=0.0d0
6663       return
6664       end
6665 c----------------------------------------------------------------------------
6666 #else
6667       subroutine etor(etors,edihcnstr)
6668       implicit real*8 (a-h,o-z)
6669       include 'DIMENSIONS'
6670       include 'COMMON.VAR'
6671       include 'COMMON.GEO'
6672       include 'COMMON.LOCAL'
6673       include 'COMMON.TORSION'
6674       include 'COMMON.INTERACT'
6675       include 'COMMON.DERIV'
6676       include 'COMMON.CHAIN'
6677       include 'COMMON.NAMES'
6678       include 'COMMON.IOUNITS'
6679       include 'COMMON.FFIELD'
6680       include 'COMMON.TORCNSTR'
6681       include 'COMMON.CONTROL'
6682       logical lprn
6683 C Set lprn=.true. for debugging
6684       lprn=.false.
6685 c     lprn=.true.
6686       etors=0.0D0
6687       do i=iphi_start,iphi_end
6688 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6689 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6690 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6691 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6692         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6693      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6694 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6695 C For introducing the NH3+ and COO- group please check the etor_d for reference
6696 C and guidance
6697         etors_ii=0.0D0
6698          if (iabs(itype(i)).eq.20) then
6699          iblock=2
6700          else
6701          iblock=1
6702          endif
6703         itori=itortyp(itype(i-2))
6704         itori1=itortyp(itype(i-1))
6705         phii=phi(i)
6706         gloci=0.0D0
6707 C Regular cosine and sine terms
6708         do j=1,nterm(itori,itori1,iblock)
6709           v1ij=v1(j,itori,itori1,iblock)
6710           v2ij=v2(j,itori,itori1,iblock)
6711           cosphi=dcos(j*phii)
6712           sinphi=dsin(j*phii)
6713           etors=etors+v1ij*cosphi+v2ij*sinphi
6714           if (energy_dec) etors_ii=etors_ii+
6715      &                v1ij*cosphi+v2ij*sinphi
6716           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6717         enddo
6718 C Lorentz terms
6719 C                         v1
6720 C  E = SUM ----------------------------------- - v1
6721 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6722 C
6723         cosphi=dcos(0.5d0*phii)
6724         sinphi=dsin(0.5d0*phii)
6725         do j=1,nlor(itori,itori1,iblock)
6726           vl1ij=vlor1(j,itori,itori1)
6727           vl2ij=vlor2(j,itori,itori1)
6728           vl3ij=vlor3(j,itori,itori1)
6729           pom=vl2ij*cosphi+vl3ij*sinphi
6730           pom1=1.0d0/(pom*pom+1.0d0)
6731           etors=etors+vl1ij*pom1
6732           if (energy_dec) etors_ii=etors_ii+
6733      &                vl1ij*pom1
6734           pom=-pom*pom1*pom1
6735           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6736         enddo
6737 C Subtract the constant term
6738         etors=etors-v0(itori,itori1,iblock)
6739           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6740      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6741         if (lprn)
6742      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6743      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6744      &  (v1(j,itori,itori1,iblock),j=1,6),
6745      &  (v2(j,itori,itori1,iblock),j=1,6)
6746         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6747 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6748       enddo
6749 ! 6/20/98 - dihedral angle constraints
6750       edihcnstr=0.0d0
6751 c      do i=1,ndih_constr
6752       do i=idihconstr_start,idihconstr_end
6753         itori=idih_constr(i)
6754         phii=phi(itori)
6755         difi=pinorm(phii-phi0(i))
6756         if (difi.gt.drange(i)) then
6757           difi=difi-drange(i)
6758           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6759           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6760         else if (difi.lt.-drange(i)) then
6761           difi=difi+drange(i)
6762           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6763           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6764         else
6765           difi=0.0
6766         endif
6767 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6768 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6769 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6770       enddo
6771 cd       write (iout,*) 'edihcnstr',edihcnstr
6772       return
6773       end
6774 c----------------------------------------------------------------------------
6775       subroutine etor_d(etors_d)
6776 C 6/23/01 Compute double torsional energy
6777       implicit real*8 (a-h,o-z)
6778       include 'DIMENSIONS'
6779       include 'COMMON.VAR'
6780       include 'COMMON.GEO'
6781       include 'COMMON.LOCAL'
6782       include 'COMMON.TORSION'
6783       include 'COMMON.INTERACT'
6784       include 'COMMON.DERIV'
6785       include 'COMMON.CHAIN'
6786       include 'COMMON.NAMES'
6787       include 'COMMON.IOUNITS'
6788       include 'COMMON.FFIELD'
6789       include 'COMMON.TORCNSTR'
6790       include 'COMMON.CONTROL'
6791       logical lprn
6792 C Set lprn=.true. for debugging
6793       lprn=.false.
6794 c     lprn=.true.
6795       etors_d=0.0D0
6796 c      write(iout,*) "a tu??"
6797       do i=iphid_start,iphid_end
6798 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6799 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6800 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6801 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6802 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6803          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6804      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6805      &  (itype(i+1).eq.ntyp1)) cycle
6806 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6807         etors_d_ii=0.0D0
6808         itori=itortyp(itype(i-2))
6809         itori1=itortyp(itype(i-1))
6810         itori2=itortyp(itype(i))
6811         phii=phi(i)
6812         phii1=phi(i+1)
6813         gloci1=0.0D0
6814         gloci2=0.0D0
6815         iblock=1
6816         if (iabs(itype(i+1)).eq.20) iblock=2
6817 C Iblock=2 Proline type
6818 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6819 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6820 C        if (itype(i+1).eq.ntyp1) iblock=3
6821 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6822 C IS or IS NOT need for this
6823 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6824 C        is (itype(i-3).eq.ntyp1) ntblock=2
6825 C        ntblock is N-terminal blocking group
6826
6827 C Regular cosine and sine terms
6828         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6829 C Example of changes for NH3+ blocking group
6830 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6831 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6832           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6833           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6834           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6835           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6836           cosphi1=dcos(j*phii)
6837           sinphi1=dsin(j*phii)
6838           cosphi2=dcos(j*phii1)
6839           sinphi2=dsin(j*phii1)
6840           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6841      &     v2cij*cosphi2+v2sij*sinphi2
6842           if (energy_dec) etors_d_ii=etors_d_ii+
6843      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6844           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6845           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6846         enddo
6847         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6848           do l=1,k-1
6849             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6850             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6851             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6852             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6853             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6854             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6855             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6856             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6857             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6858      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6859             if (energy_dec) etors_d_ii=etors_d_ii+
6860      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6861      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6862             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6863      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6864             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6865      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6866           enddo
6867         enddo
6868           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6869      &         'etor_d',i,etors_d_ii
6870         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6871         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6872       enddo
6873       return
6874       end
6875 #endif
6876 c------------------------------------------------------------------------------
6877       subroutine eback_sc_corr(esccor)
6878 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6879 c        conformational states; temporarily implemented as differences
6880 c        between UNRES torsional potentials (dependent on three types of
6881 c        residues) and the torsional potentials dependent on all 20 types
6882 c        of residues computed from AM1  energy surfaces of terminally-blocked
6883 c        amino-acid residues.
6884       implicit real*8 (a-h,o-z)
6885       include 'DIMENSIONS'
6886       include 'COMMON.VAR'
6887       include 'COMMON.GEO'
6888       include 'COMMON.LOCAL'
6889       include 'COMMON.TORSION'
6890       include 'COMMON.SCCOR'
6891       include 'COMMON.INTERACT'
6892       include 'COMMON.DERIV'
6893       include 'COMMON.CHAIN'
6894       include 'COMMON.NAMES'
6895       include 'COMMON.IOUNITS'
6896       include 'COMMON.FFIELD'
6897       include 'COMMON.CONTROL'
6898       logical lprn
6899 C Set lprn=.true. for debugging
6900       lprn=.false.
6901 c      lprn=.true.
6902 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6903       esccor=0.0D0
6904       do i=itau_start,itau_end
6905         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6906         esccor_ii=0.0D0
6907         isccori=isccortyp(itype(i-2))
6908         isccori1=isccortyp(itype(i-1))
6909 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6910         phii=phi(i)
6911         do intertyp=1,3 !intertyp
6912 cc Added 09 May 2012 (Adasko)
6913 cc  Intertyp means interaction type of backbone mainchain correlation:
6914 c   1 = SC...Ca...Ca...Ca
6915 c   2 = Ca...Ca...Ca...SC
6916 c   3 = SC...Ca...Ca...SCi
6917         gloci=0.0D0
6918         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6919      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6920      &      (itype(i-1).eq.ntyp1)))
6921      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6922      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6923      &     .or.(itype(i).eq.ntyp1)))
6924      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6925      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6926      &      (itype(i-3).eq.ntyp1)))) cycle
6927         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6928         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6929      & cycle
6930        do j=1,nterm_sccor(isccori,isccori1)
6931           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6932           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6933           cosphi=dcos(j*tauangle(intertyp,i))
6934           sinphi=dsin(j*tauangle(intertyp,i))
6935           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6936           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6937         enddo
6938 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6939         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6940         if (lprn)
6941      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6942      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6943      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6944      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6945         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6946        enddo !intertyp
6947       enddo
6948
6949       return
6950       end
6951 c----------------------------------------------------------------------------
6952       subroutine multibody(ecorr)
6953 C This subroutine calculates multi-body contributions to energy following
6954 C the idea of Skolnick et al. If side chains I and J make a contact and
6955 C at the same time side chains I+1 and J+1 make a contact, an extra
6956 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6957       implicit real*8 (a-h,o-z)
6958       include 'DIMENSIONS'
6959       include 'COMMON.IOUNITS'
6960       include 'COMMON.DERIV'
6961       include 'COMMON.INTERACT'
6962       include 'COMMON.CONTACTS'
6963       double precision gx(3),gx1(3)
6964       logical lprn
6965
6966 C Set lprn=.true. for debugging
6967       lprn=.false.
6968
6969       if (lprn) then
6970         write (iout,'(a)') 'Contact function values:'
6971         do i=nnt,nct-2
6972           write (iout,'(i2,20(1x,i2,f10.5))')
6973      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6974         enddo
6975       endif
6976       ecorr=0.0D0
6977       do i=nnt,nct
6978         do j=1,3
6979           gradcorr(j,i)=0.0D0
6980           gradxorr(j,i)=0.0D0
6981         enddo
6982       enddo
6983       do i=nnt,nct-2
6984
6985         DO ISHIFT = 3,4
6986
6987         i1=i+ishift
6988         num_conti=num_cont(i)
6989         num_conti1=num_cont(i1)
6990         do jj=1,num_conti
6991           j=jcont(jj,i)
6992           do kk=1,num_conti1
6993             j1=jcont(kk,i1)
6994             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6995 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6996 cd   &                   ' ishift=',ishift
6997 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6998 C The system gains extra energy.
6999               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7000             endif   ! j1==j+-ishift
7001           enddo     ! kk
7002         enddo       ! jj
7003
7004         ENDDO ! ISHIFT
7005
7006       enddo         ! i
7007       return
7008       end
7009 c------------------------------------------------------------------------------
7010       double precision function esccorr(i,j,k,l,jj,kk)
7011       implicit real*8 (a-h,o-z)
7012       include 'DIMENSIONS'
7013       include 'COMMON.IOUNITS'
7014       include 'COMMON.DERIV'
7015       include 'COMMON.INTERACT'
7016       include 'COMMON.CONTACTS'
7017       double precision gx(3),gx1(3)
7018       logical lprn
7019       lprn=.false.
7020       eij=facont(jj,i)
7021       ekl=facont(kk,k)
7022 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7023 C Calculate the multi-body contribution to energy.
7024 C Calculate multi-body contributions to the gradient.
7025 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7026 cd   & k,l,(gacont(m,kk,k),m=1,3)
7027       do m=1,3
7028         gx(m) =ekl*gacont(m,jj,i)
7029         gx1(m)=eij*gacont(m,kk,k)
7030         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7031         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7032         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7033         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7034       enddo
7035       do m=i,j-1
7036         do ll=1,3
7037           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7038         enddo
7039       enddo
7040       do m=k,l-1
7041         do ll=1,3
7042           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7043         enddo
7044       enddo
7045       esccorr=-eij*ekl
7046       return
7047       end
7048 c------------------------------------------------------------------------------
7049       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7050 C This subroutine calculates multi-body contributions to hydrogen-bonding
7051       implicit real*8 (a-h,o-z)
7052       include 'DIMENSIONS'
7053       include 'COMMON.IOUNITS'
7054 #ifdef MPI
7055       include "mpif.h"
7056       parameter (max_cont=maxconts)
7057       parameter (max_dim=26)
7058       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7059       double precision zapas(max_dim,maxconts,max_fg_procs),
7060      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7061       common /przechowalnia/ zapas
7062       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7063      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7064 #endif
7065       include 'COMMON.SETUP'
7066       include 'COMMON.FFIELD'
7067       include 'COMMON.DERIV'
7068       include 'COMMON.INTERACT'
7069       include 'COMMON.CONTACTS'
7070       include 'COMMON.CONTROL'
7071       include 'COMMON.LOCAL'
7072       double precision gx(3),gx1(3),time00
7073       logical lprn,ldone
7074
7075 C Set lprn=.true. for debugging
7076       lprn=.false.
7077 #ifdef MPI
7078       n_corr=0
7079       n_corr1=0
7080       if (nfgtasks.le.1) goto 30
7081       if (lprn) then
7082         write (iout,'(a)') 'Contact function values before RECEIVE:'
7083         do i=nnt,nct-2
7084           write (iout,'(2i3,50(1x,i2,f5.2))')
7085      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7086      &    j=1,num_cont_hb(i))
7087         enddo
7088       endif
7089       call flush(iout)
7090       do i=1,ntask_cont_from
7091         ncont_recv(i)=0
7092       enddo
7093       do i=1,ntask_cont_to
7094         ncont_sent(i)=0
7095       enddo
7096 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7097 c     & ntask_cont_to
7098 C Make the list of contacts to send to send to other procesors
7099 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7100 c      call flush(iout)
7101       do i=iturn3_start,iturn3_end
7102 c        write (iout,*) "make contact list turn3",i," num_cont",
7103 c     &    num_cont_hb(i)
7104         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7105       enddo
7106       do i=iturn4_start,iturn4_end
7107 c        write (iout,*) "make contact list turn4",i," num_cont",
7108 c     &   num_cont_hb(i)
7109         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7110       enddo
7111       do ii=1,nat_sent
7112         i=iat_sent(ii)
7113 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7114 c     &    num_cont_hb(i)
7115         do j=1,num_cont_hb(i)
7116         do k=1,4
7117           jjc=jcont_hb(j,i)
7118           iproc=iint_sent_local(k,jjc,ii)
7119 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7120           if (iproc.gt.0) then
7121             ncont_sent(iproc)=ncont_sent(iproc)+1
7122             nn=ncont_sent(iproc)
7123             zapas(1,nn,iproc)=i
7124             zapas(2,nn,iproc)=jjc
7125             zapas(3,nn,iproc)=facont_hb(j,i)
7126             zapas(4,nn,iproc)=ees0p(j,i)
7127             zapas(5,nn,iproc)=ees0m(j,i)
7128             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7129             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7130             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7131             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7132             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7133             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7134             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7135             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7136             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7137             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7138             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7139             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7140             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7141             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7142             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7143             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7144             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7145             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7146             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7147             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7148             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7149           endif
7150         enddo
7151         enddo
7152       enddo
7153       if (lprn) then
7154       write (iout,*)
7155      &  "Numbers of contacts to be sent to other processors",
7156      &  (ncont_sent(i),i=1,ntask_cont_to)
7157       write (iout,*) "Contacts sent"
7158       do ii=1,ntask_cont_to
7159         nn=ncont_sent(ii)
7160         iproc=itask_cont_to(ii)
7161         write (iout,*) nn," contacts to processor",iproc,
7162      &   " of CONT_TO_COMM group"
7163         do i=1,nn
7164           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7165         enddo
7166       enddo
7167       call flush(iout)
7168       endif
7169       CorrelType=477
7170       CorrelID=fg_rank+1
7171       CorrelType1=478
7172       CorrelID1=nfgtasks+fg_rank+1
7173       ireq=0
7174 C Receive the numbers of needed contacts from other processors
7175       do ii=1,ntask_cont_from
7176         iproc=itask_cont_from(ii)
7177         ireq=ireq+1
7178         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7179      &    FG_COMM,req(ireq),IERR)
7180       enddo
7181 c      write (iout,*) "IRECV ended"
7182 c      call flush(iout)
7183 C Send the number of contacts needed by other processors
7184       do ii=1,ntask_cont_to
7185         iproc=itask_cont_to(ii)
7186         ireq=ireq+1
7187         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7188      &    FG_COMM,req(ireq),IERR)
7189       enddo
7190 c      write (iout,*) "ISEND ended"
7191 c      write (iout,*) "number of requests (nn)",ireq
7192       call flush(iout)
7193       if (ireq.gt.0)
7194      &  call MPI_Waitall(ireq,req,status_array,ierr)
7195 c      write (iout,*)
7196 c     &  "Numbers of contacts to be received from other processors",
7197 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7198 c      call flush(iout)
7199 C Receive contacts
7200       ireq=0
7201       do ii=1,ntask_cont_from
7202         iproc=itask_cont_from(ii)
7203         nn=ncont_recv(ii)
7204 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7205 c     &   " of CONT_TO_COMM group"
7206         call flush(iout)
7207         if (nn.gt.0) then
7208           ireq=ireq+1
7209           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7210      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7211 c          write (iout,*) "ireq,req",ireq,req(ireq)
7212         endif
7213       enddo
7214 C Send the contacts to processors that need them
7215       do ii=1,ntask_cont_to
7216         iproc=itask_cont_to(ii)
7217         nn=ncont_sent(ii)
7218 c        write (iout,*) nn," contacts to processor",iproc,
7219 c     &   " of CONT_TO_COMM group"
7220         if (nn.gt.0) then
7221           ireq=ireq+1
7222           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7223      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7224 c          write (iout,*) "ireq,req",ireq,req(ireq)
7225 c          do i=1,nn
7226 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7227 c          enddo
7228         endif
7229       enddo
7230 c      write (iout,*) "number of requests (contacts)",ireq
7231 c      write (iout,*) "req",(req(i),i=1,4)
7232 c      call flush(iout)
7233       if (ireq.gt.0)
7234      & call MPI_Waitall(ireq,req,status_array,ierr)
7235       do iii=1,ntask_cont_from
7236         iproc=itask_cont_from(iii)
7237         nn=ncont_recv(iii)
7238         if (lprn) then
7239         write (iout,*) "Received",nn," contacts from processor",iproc,
7240      &   " of CONT_FROM_COMM group"
7241         call flush(iout)
7242         do i=1,nn
7243           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7244         enddo
7245         call flush(iout)
7246         endif
7247         do i=1,nn
7248           ii=zapas_recv(1,i,iii)
7249 c Flag the received contacts to prevent double-counting
7250           jj=-zapas_recv(2,i,iii)
7251 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7252 c          call flush(iout)
7253           nnn=num_cont_hb(ii)+1
7254           num_cont_hb(ii)=nnn
7255           jcont_hb(nnn,ii)=jj
7256           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7257           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7258           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7259           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7260           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7261           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7262           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7263           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7264           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7265           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7266           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7267           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7268           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7269           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7270           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7271           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7272           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7273           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7274           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7275           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7276           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7277           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7278           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7279           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7280         enddo
7281       enddo
7282       call flush(iout)
7283       if (lprn) then
7284         write (iout,'(a)') 'Contact function values after receive:'
7285         do i=nnt,nct-2
7286           write (iout,'(2i3,50(1x,i3,f5.2))')
7287      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7288      &    j=1,num_cont_hb(i))
7289         enddo
7290         call flush(iout)
7291       endif
7292    30 continue
7293 #endif
7294       if (lprn) then
7295         write (iout,'(a)') 'Contact function values:'
7296         do i=nnt,nct-2
7297           write (iout,'(2i3,50(1x,i3,f5.2))')
7298      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7299      &    j=1,num_cont_hb(i))
7300         enddo
7301       endif
7302       ecorr=0.0D0
7303 C Remove the loop below after debugging !!!
7304       do i=nnt,nct
7305         do j=1,3
7306           gradcorr(j,i)=0.0D0
7307           gradxorr(j,i)=0.0D0
7308         enddo
7309       enddo
7310 C Calculate the local-electrostatic correlation terms
7311       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7312         i1=i+1
7313         num_conti=num_cont_hb(i)
7314         num_conti1=num_cont_hb(i+1)
7315         do jj=1,num_conti
7316           j=jcont_hb(jj,i)
7317           jp=iabs(j)
7318           do kk=1,num_conti1
7319             j1=jcont_hb(kk,i1)
7320             jp1=iabs(j1)
7321 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7322 c     &         ' jj=',jj,' kk=',kk
7323             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7324      &          .or. j.lt.0 .and. j1.gt.0) .and.
7325      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7326 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7327 C The system gains extra energy.
7328               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7329               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7330      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7331               n_corr=n_corr+1
7332             else if (j1.eq.j) then
7333 C Contacts I-J and I-(J+1) occur simultaneously.
7334 C The system loses extra energy.
7335 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7336             endif
7337           enddo ! kk
7338           do kk=1,num_conti
7339             j1=jcont_hb(kk,i)
7340 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7341 c    &         ' jj=',jj,' kk=',kk
7342             if (j1.eq.j+1) then
7343 C Contacts I-J and (I+1)-J occur simultaneously.
7344 C The system loses extra energy.
7345 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7346             endif ! j1==j+1
7347           enddo ! kk
7348         enddo ! jj
7349       enddo ! i
7350       return
7351       end
7352 c------------------------------------------------------------------------------
7353       subroutine add_hb_contact(ii,jj,itask)
7354       implicit real*8 (a-h,o-z)
7355       include "DIMENSIONS"
7356       include "COMMON.IOUNITS"
7357       integer max_cont
7358       integer max_dim
7359       parameter (max_cont=maxconts)
7360       parameter (max_dim=26)
7361       include "COMMON.CONTACTS"
7362       double precision zapas(max_dim,maxconts,max_fg_procs),
7363      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7364       common /przechowalnia/ zapas
7365       integer i,j,ii,jj,iproc,itask(4),nn
7366 c      write (iout,*) "itask",itask
7367       do i=1,2
7368         iproc=itask(i)
7369         if (iproc.gt.0) then
7370           do j=1,num_cont_hb(ii)
7371             jjc=jcont_hb(j,ii)
7372 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7373             if (jjc.eq.jj) then
7374               ncont_sent(iproc)=ncont_sent(iproc)+1
7375               nn=ncont_sent(iproc)
7376               zapas(1,nn,iproc)=ii
7377               zapas(2,nn,iproc)=jjc
7378               zapas(3,nn,iproc)=facont_hb(j,ii)
7379               zapas(4,nn,iproc)=ees0p(j,ii)
7380               zapas(5,nn,iproc)=ees0m(j,ii)
7381               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7382               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7383               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7384               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7385               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7386               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7387               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7388               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7389               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7390               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7391               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7392               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7393               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7394               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7395               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7396               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7397               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7398               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7399               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7400               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7401               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7402               exit
7403             endif
7404           enddo
7405         endif
7406       enddo
7407       return
7408       end
7409 c------------------------------------------------------------------------------
7410       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7411      &  n_corr1)
7412 C This subroutine calculates multi-body contributions to hydrogen-bonding
7413       implicit real*8 (a-h,o-z)
7414       include 'DIMENSIONS'
7415       include 'COMMON.IOUNITS'
7416 #ifdef MPI
7417       include "mpif.h"
7418       parameter (max_cont=maxconts)
7419       parameter (max_dim=70)
7420       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7421       double precision zapas(max_dim,maxconts,max_fg_procs),
7422      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7423       common /przechowalnia/ zapas
7424       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7425      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7426 #endif
7427       include 'COMMON.SETUP'
7428       include 'COMMON.FFIELD'
7429       include 'COMMON.DERIV'
7430       include 'COMMON.LOCAL'
7431       include 'COMMON.INTERACT'
7432       include 'COMMON.CONTACTS'
7433       include 'COMMON.CHAIN'
7434       include 'COMMON.CONTROL'
7435       double precision gx(3),gx1(3)
7436       integer num_cont_hb_old(maxres)
7437       logical lprn,ldone
7438       double precision eello4,eello5,eelo6,eello_turn6
7439       external eello4,eello5,eello6,eello_turn6
7440 C Set lprn=.true. for debugging
7441       lprn=.false.
7442       eturn6=0.0d0
7443 #ifdef MPI
7444       do i=1,nres
7445         num_cont_hb_old(i)=num_cont_hb(i)
7446       enddo
7447       n_corr=0
7448       n_corr1=0
7449       if (nfgtasks.le.1) goto 30
7450       if (lprn) then
7451         write (iout,'(a)') 'Contact function values before RECEIVE:'
7452         do i=nnt,nct-2
7453           write (iout,'(2i3,50(1x,i2,f5.2))')
7454      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7455      &    j=1,num_cont_hb(i))
7456         enddo
7457       endif
7458       call flush(iout)
7459       do i=1,ntask_cont_from
7460         ncont_recv(i)=0
7461       enddo
7462       do i=1,ntask_cont_to
7463         ncont_sent(i)=0
7464       enddo
7465 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7466 c     & ntask_cont_to
7467 C Make the list of contacts to send to send to other procesors
7468       do i=iturn3_start,iturn3_end
7469 c        write (iout,*) "make contact list turn3",i," num_cont",
7470 c     &    num_cont_hb(i)
7471         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7472       enddo
7473       do i=iturn4_start,iturn4_end
7474 c        write (iout,*) "make contact list turn4",i," num_cont",
7475 c     &   num_cont_hb(i)
7476         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7477       enddo
7478       do ii=1,nat_sent
7479         i=iat_sent(ii)
7480 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7481 c     &    num_cont_hb(i)
7482         do j=1,num_cont_hb(i)
7483         do k=1,4
7484           jjc=jcont_hb(j,i)
7485           iproc=iint_sent_local(k,jjc,ii)
7486 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7487           if (iproc.ne.0) then
7488             ncont_sent(iproc)=ncont_sent(iproc)+1
7489             nn=ncont_sent(iproc)
7490             zapas(1,nn,iproc)=i
7491             zapas(2,nn,iproc)=jjc
7492             zapas(3,nn,iproc)=d_cont(j,i)
7493             ind=3
7494             do kk=1,3
7495               ind=ind+1
7496               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7497             enddo
7498             do kk=1,2
7499               do ll=1,2
7500                 ind=ind+1
7501                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7502               enddo
7503             enddo
7504             do jj=1,5
7505               do kk=1,3
7506                 do ll=1,2
7507                   do mm=1,2
7508                     ind=ind+1
7509                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7510                   enddo
7511                 enddo
7512               enddo
7513             enddo
7514           endif
7515         enddo
7516         enddo
7517       enddo
7518       if (lprn) then
7519       write (iout,*)
7520      &  "Numbers of contacts to be sent to other processors",
7521      &  (ncont_sent(i),i=1,ntask_cont_to)
7522       write (iout,*) "Contacts sent"
7523       do ii=1,ntask_cont_to
7524         nn=ncont_sent(ii)
7525         iproc=itask_cont_to(ii)
7526         write (iout,*) nn," contacts to processor",iproc,
7527      &   " of CONT_TO_COMM group"
7528         do i=1,nn
7529           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7530         enddo
7531       enddo
7532       call flush(iout)
7533       endif
7534       CorrelType=477
7535       CorrelID=fg_rank+1
7536       CorrelType1=478
7537       CorrelID1=nfgtasks+fg_rank+1
7538       ireq=0
7539 C Receive the numbers of needed contacts from other processors
7540       do ii=1,ntask_cont_from
7541         iproc=itask_cont_from(ii)
7542         ireq=ireq+1
7543         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7544      &    FG_COMM,req(ireq),IERR)
7545       enddo
7546 c      write (iout,*) "IRECV ended"
7547 c      call flush(iout)
7548 C Send the number of contacts needed by other processors
7549       do ii=1,ntask_cont_to
7550         iproc=itask_cont_to(ii)
7551         ireq=ireq+1
7552         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7553      &    FG_COMM,req(ireq),IERR)
7554       enddo
7555 c      write (iout,*) "ISEND ended"
7556 c      write (iout,*) "number of requests (nn)",ireq
7557       call flush(iout)
7558       if (ireq.gt.0)
7559      &  call MPI_Waitall(ireq,req,status_array,ierr)
7560 c      write (iout,*)
7561 c     &  "Numbers of contacts to be received from other processors",
7562 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7563 c      call flush(iout)
7564 C Receive contacts
7565       ireq=0
7566       do ii=1,ntask_cont_from
7567         iproc=itask_cont_from(ii)
7568         nn=ncont_recv(ii)
7569 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7570 c     &   " of CONT_TO_COMM group"
7571         call flush(iout)
7572         if (nn.gt.0) then
7573           ireq=ireq+1
7574           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7575      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7576 c          write (iout,*) "ireq,req",ireq,req(ireq)
7577         endif
7578       enddo
7579 C Send the contacts to processors that need them
7580       do ii=1,ntask_cont_to
7581         iproc=itask_cont_to(ii)
7582         nn=ncont_sent(ii)
7583 c        write (iout,*) nn," contacts to processor",iproc,
7584 c     &   " of CONT_TO_COMM group"
7585         if (nn.gt.0) then
7586           ireq=ireq+1
7587           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7588      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7589 c          write (iout,*) "ireq,req",ireq,req(ireq)
7590 c          do i=1,nn
7591 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7592 c          enddo
7593         endif
7594       enddo
7595 c      write (iout,*) "number of requests (contacts)",ireq
7596 c      write (iout,*) "req",(req(i),i=1,4)
7597 c      call flush(iout)
7598       if (ireq.gt.0)
7599      & call MPI_Waitall(ireq,req,status_array,ierr)
7600       do iii=1,ntask_cont_from
7601         iproc=itask_cont_from(iii)
7602         nn=ncont_recv(iii)
7603         if (lprn) then
7604         write (iout,*) "Received",nn," contacts from processor",iproc,
7605      &   " of CONT_FROM_COMM group"
7606         call flush(iout)
7607         do i=1,nn
7608           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7609         enddo
7610         call flush(iout)
7611         endif
7612         do i=1,nn
7613           ii=zapas_recv(1,i,iii)
7614 c Flag the received contacts to prevent double-counting
7615           jj=-zapas_recv(2,i,iii)
7616 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7617 c          call flush(iout)
7618           nnn=num_cont_hb(ii)+1
7619           num_cont_hb(ii)=nnn
7620           jcont_hb(nnn,ii)=jj
7621           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7622           ind=3
7623           do kk=1,3
7624             ind=ind+1
7625             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7626           enddo
7627           do kk=1,2
7628             do ll=1,2
7629               ind=ind+1
7630               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7631             enddo
7632           enddo
7633           do jj=1,5
7634             do kk=1,3
7635               do ll=1,2
7636                 do mm=1,2
7637                   ind=ind+1
7638                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7639                 enddo
7640               enddo
7641             enddo
7642           enddo
7643         enddo
7644       enddo
7645       call flush(iout)
7646       if (lprn) then
7647         write (iout,'(a)') 'Contact function values after receive:'
7648         do i=nnt,nct-2
7649           write (iout,'(2i3,50(1x,i3,5f6.3))')
7650      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7651      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7652         enddo
7653         call flush(iout)
7654       endif
7655    30 continue
7656 #endif
7657       if (lprn) then
7658         write (iout,'(a)') 'Contact function values:'
7659         do i=nnt,nct-2
7660           write (iout,'(2i3,50(1x,i2,5f6.3))')
7661      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7662      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7663         enddo
7664       endif
7665       ecorr=0.0D0
7666       ecorr5=0.0d0
7667       ecorr6=0.0d0
7668 C Remove the loop below after debugging !!!
7669       do i=nnt,nct
7670         do j=1,3
7671           gradcorr(j,i)=0.0D0
7672           gradxorr(j,i)=0.0D0
7673         enddo
7674       enddo
7675 C Calculate the dipole-dipole interaction energies
7676       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7677       do i=iatel_s,iatel_e+1
7678         num_conti=num_cont_hb(i)
7679         do jj=1,num_conti
7680           j=jcont_hb(jj,i)
7681 #ifdef MOMENT
7682           call dipole(i,j,jj)
7683 #endif
7684         enddo
7685       enddo
7686       endif
7687 C Calculate the local-electrostatic correlation terms
7688 c                write (iout,*) "gradcorr5 in eello5 before loop"
7689 c                do iii=1,nres
7690 c                  write (iout,'(i5,3f10.5)')
7691 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7692 c                enddo
7693       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7694 c        write (iout,*) "corr loop i",i
7695         i1=i+1
7696         num_conti=num_cont_hb(i)
7697         num_conti1=num_cont_hb(i+1)
7698         do jj=1,num_conti
7699           j=jcont_hb(jj,i)
7700           jp=iabs(j)
7701           do kk=1,num_conti1
7702             j1=jcont_hb(kk,i1)
7703             jp1=iabs(j1)
7704 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7705 c     &         ' jj=',jj,' kk=',kk
7706 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7707             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7708      &          .or. j.lt.0 .and. j1.gt.0) .and.
7709      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7710 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7711 C The system gains extra energy.
7712               n_corr=n_corr+1
7713               sqd1=dsqrt(d_cont(jj,i))
7714               sqd2=dsqrt(d_cont(kk,i1))
7715               sred_geom = sqd1*sqd2
7716               IF (sred_geom.lt.cutoff_corr) THEN
7717                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7718      &            ekont,fprimcont)
7719 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7720 cd     &         ' jj=',jj,' kk=',kk
7721                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7722                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7723                 do l=1,3
7724                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7725                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7726                 enddo
7727                 n_corr1=n_corr1+1
7728 cd               write (iout,*) 'sred_geom=',sred_geom,
7729 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7730 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7731 cd               write (iout,*) "g_contij",g_contij
7732 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7733 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7734                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7735                 if (wcorr4.gt.0.0d0)
7736      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7737                   if (energy_dec.and.wcorr4.gt.0.0d0)
7738      1                 write (iout,'(a6,4i5,0pf7.3)')
7739      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7740 c                write (iout,*) "gradcorr5 before eello5"
7741 c                do iii=1,nres
7742 c                  write (iout,'(i5,3f10.5)')
7743 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7744 c                enddo
7745                 if (wcorr5.gt.0.0d0)
7746      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7747 c                write (iout,*) "gradcorr5 after eello5"
7748 c                do iii=1,nres
7749 c                  write (iout,'(i5,3f10.5)')
7750 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7751 c                enddo
7752                   if (energy_dec.and.wcorr5.gt.0.0d0)
7753      1                 write (iout,'(a6,4i5,0pf7.3)')
7754      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7755 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7756 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7757                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7758      &               .or. wturn6.eq.0.0d0))then
7759 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7760                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7761                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7762      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7763 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7764 cd     &            'ecorr6=',ecorr6
7765 cd                write (iout,'(4e15.5)') sred_geom,
7766 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7767 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7768 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7769                 else if (wturn6.gt.0.0d0
7770      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7771 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7772                   eturn6=eturn6+eello_turn6(i,jj,kk)
7773                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7774      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7775 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7776                 endif
7777               ENDIF
7778 1111          continue
7779             endif
7780           enddo ! kk
7781         enddo ! jj
7782       enddo ! i
7783       do i=1,nres
7784         num_cont_hb(i)=num_cont_hb_old(i)
7785       enddo
7786 c                write (iout,*) "gradcorr5 in eello5"
7787 c                do iii=1,nres
7788 c                  write (iout,'(i5,3f10.5)')
7789 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7790 c                enddo
7791       return
7792       end
7793 c------------------------------------------------------------------------------
7794       subroutine add_hb_contact_eello(ii,jj,itask)
7795       implicit real*8 (a-h,o-z)
7796       include "DIMENSIONS"
7797       include "COMMON.IOUNITS"
7798       integer max_cont
7799       integer max_dim
7800       parameter (max_cont=maxconts)
7801       parameter (max_dim=70)
7802       include "COMMON.CONTACTS"
7803       double precision zapas(max_dim,maxconts,max_fg_procs),
7804      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7805       common /przechowalnia/ zapas
7806       integer i,j,ii,jj,iproc,itask(4),nn
7807 c      write (iout,*) "itask",itask
7808       do i=1,2
7809         iproc=itask(i)
7810         if (iproc.gt.0) then
7811           do j=1,num_cont_hb(ii)
7812             jjc=jcont_hb(j,ii)
7813 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7814             if (jjc.eq.jj) then
7815               ncont_sent(iproc)=ncont_sent(iproc)+1
7816               nn=ncont_sent(iproc)
7817               zapas(1,nn,iproc)=ii
7818               zapas(2,nn,iproc)=jjc
7819               zapas(3,nn,iproc)=d_cont(j,ii)
7820               ind=3
7821               do kk=1,3
7822                 ind=ind+1
7823                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7824               enddo
7825               do kk=1,2
7826                 do ll=1,2
7827                   ind=ind+1
7828                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7829                 enddo
7830               enddo
7831               do jj=1,5
7832                 do kk=1,3
7833                   do ll=1,2
7834                     do mm=1,2
7835                       ind=ind+1
7836                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7837                     enddo
7838                   enddo
7839                 enddo
7840               enddo
7841               exit
7842             endif
7843           enddo
7844         endif
7845       enddo
7846       return
7847       end
7848 c------------------------------------------------------------------------------
7849       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7850       implicit real*8 (a-h,o-z)
7851       include 'DIMENSIONS'
7852       include 'COMMON.IOUNITS'
7853       include 'COMMON.DERIV'
7854       include 'COMMON.INTERACT'
7855       include 'COMMON.CONTACTS'
7856       double precision gx(3),gx1(3)
7857       logical lprn
7858       lprn=.false.
7859       eij=facont_hb(jj,i)
7860       ekl=facont_hb(kk,k)
7861       ees0pij=ees0p(jj,i)
7862       ees0pkl=ees0p(kk,k)
7863       ees0mij=ees0m(jj,i)
7864       ees0mkl=ees0m(kk,k)
7865       ekont=eij*ekl
7866       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7867 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7868 C Following 4 lines for diagnostics.
7869 cd    ees0pkl=0.0D0
7870 cd    ees0pij=1.0D0
7871 cd    ees0mkl=0.0D0
7872 cd    ees0mij=1.0D0
7873 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7874 c     & 'Contacts ',i,j,
7875 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7876 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7877 c     & 'gradcorr_long'
7878 C Calculate the multi-body contribution to energy.
7879 c      ecorr=ecorr+ekont*ees
7880 C Calculate multi-body contributions to the gradient.
7881       coeffpees0pij=coeffp*ees0pij
7882       coeffmees0mij=coeffm*ees0mij
7883       coeffpees0pkl=coeffp*ees0pkl
7884       coeffmees0mkl=coeffm*ees0mkl
7885       do ll=1,3
7886 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7887         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7888      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7889      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7890         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7891      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7892      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7893 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7894         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7895      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7896      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7897         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7898      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7899      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7900         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7901      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7902      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7903         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7904         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7905         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7906      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7907      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7908         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7909         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7910 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7911       enddo
7912 c      write (iout,*)
7913 cgrad      do m=i+1,j-1
7914 cgrad        do ll=1,3
7915 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7916 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7917 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7918 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7919 cgrad        enddo
7920 cgrad      enddo
7921 cgrad      do m=k+1,l-1
7922 cgrad        do ll=1,3
7923 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7924 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7925 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7926 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7927 cgrad        enddo
7928 cgrad      enddo
7929 c      write (iout,*) "ehbcorr",ekont*ees
7930       ehbcorr=ekont*ees
7931       return
7932       end
7933 #ifdef MOMENT
7934 C---------------------------------------------------------------------------
7935       subroutine dipole(i,j,jj)
7936       implicit real*8 (a-h,o-z)
7937       include 'DIMENSIONS'
7938       include 'COMMON.IOUNITS'
7939       include 'COMMON.CHAIN'
7940       include 'COMMON.FFIELD'
7941       include 'COMMON.DERIV'
7942       include 'COMMON.INTERACT'
7943       include 'COMMON.CONTACTS'
7944       include 'COMMON.TORSION'
7945       include 'COMMON.VAR'
7946       include 'COMMON.GEO'
7947       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7948      &  auxmat(2,2)
7949       iti1 = itortyp(itype(i+1))
7950       if (j.lt.nres-1) then
7951         itj1 = itortyp(itype(j+1))
7952       else
7953         itj1=ntortyp
7954       endif
7955       do iii=1,2
7956         dipi(iii,1)=Ub2(iii,i)
7957         dipderi(iii)=Ub2der(iii,i)
7958         dipi(iii,2)=b1(iii,i+1)
7959         dipj(iii,1)=Ub2(iii,j)
7960         dipderj(iii)=Ub2der(iii,j)
7961         dipj(iii,2)=b1(iii,j+1)
7962       enddo
7963       kkk=0
7964       do iii=1,2
7965         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7966         do jjj=1,2
7967           kkk=kkk+1
7968           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7969         enddo
7970       enddo
7971       do kkk=1,5
7972         do lll=1,3
7973           mmm=0
7974           do iii=1,2
7975             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7976      &        auxvec(1))
7977             do jjj=1,2
7978               mmm=mmm+1
7979               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7980             enddo
7981           enddo
7982         enddo
7983       enddo
7984       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7985       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7986       do iii=1,2
7987         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7988       enddo
7989       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7990       do iii=1,2
7991         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7992       enddo
7993       return
7994       end
7995 #endif
7996 C---------------------------------------------------------------------------
7997       subroutine calc_eello(i,j,k,l,jj,kk)
7998 C
7999 C This subroutine computes matrices and vectors needed to calculate
8000 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8001 C
8002       implicit real*8 (a-h,o-z)
8003       include 'DIMENSIONS'
8004       include 'COMMON.IOUNITS'
8005       include 'COMMON.CHAIN'
8006       include 'COMMON.DERIV'
8007       include 'COMMON.INTERACT'
8008       include 'COMMON.CONTACTS'
8009       include 'COMMON.TORSION'
8010       include 'COMMON.VAR'
8011       include 'COMMON.GEO'
8012       include 'COMMON.FFIELD'
8013       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8014      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8015       logical lprn
8016       common /kutas/ lprn
8017 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8018 cd     & ' jj=',jj,' kk=',kk
8019 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8020 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8021 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8022       do iii=1,2
8023         do jjj=1,2
8024           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8025           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8026         enddo
8027       enddo
8028       call transpose2(aa1(1,1),aa1t(1,1))
8029       call transpose2(aa2(1,1),aa2t(1,1))
8030       do kkk=1,5
8031         do lll=1,3
8032           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8033      &      aa1tder(1,1,lll,kkk))
8034           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8035      &      aa2tder(1,1,lll,kkk))
8036         enddo
8037       enddo
8038       if (l.eq.j+1) then
8039 C parallel orientation of the two CA-CA-CA frames.
8040         if (i.gt.1) then
8041           iti=itortyp(itype(i))
8042         else
8043           iti=ntortyp
8044         endif
8045         itk1=itortyp(itype(k+1))
8046         itj=itortyp(itype(j))
8047         if (l.lt.nres-1) then
8048           itl1=itortyp(itype(l+1))
8049         else
8050           itl1=ntortyp
8051         endif
8052 C A1 kernel(j+1) A2T
8053 cd        do iii=1,2
8054 cd          write (iout,'(3f10.5,5x,3f10.5)')
8055 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8056 cd        enddo
8057         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8058      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8059      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8060 C Following matrices are needed only for 6-th order cumulants
8061         IF (wcorr6.gt.0.0d0) THEN
8062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8063      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8064      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8066      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8067      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8068      &   ADtEAderx(1,1,1,1,1,1))
8069         lprn=.false.
8070         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8071      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8072      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8073      &   ADtEA1derx(1,1,1,1,1,1))
8074         ENDIF
8075 C End 6-th order cumulants
8076 cd        lprn=.false.
8077 cd        if (lprn) then
8078 cd        write (2,*) 'In calc_eello6'
8079 cd        do iii=1,2
8080 cd          write (2,*) 'iii=',iii
8081 cd          do kkk=1,5
8082 cd            write (2,*) 'kkk=',kkk
8083 cd            do jjj=1,2
8084 cd              write (2,'(3(2f10.5),5x)')
8085 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8086 cd            enddo
8087 cd          enddo
8088 cd        enddo
8089 cd        endif
8090         call transpose2(EUgder(1,1,k),auxmat(1,1))
8091         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8092         call transpose2(EUg(1,1,k),auxmat(1,1))
8093         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8094         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8095         do iii=1,2
8096           do kkk=1,5
8097             do lll=1,3
8098               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8099      &          EAEAderx(1,1,lll,kkk,iii,1))
8100             enddo
8101           enddo
8102         enddo
8103 C A1T kernel(i+1) A2
8104         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8105      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8106      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8107 C Following matrices are needed only for 6-th order cumulants
8108         IF (wcorr6.gt.0.0d0) THEN
8109         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8110      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8111      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8112         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8113      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8114      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8115      &   ADtEAderx(1,1,1,1,1,2))
8116         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8117      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8118      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8119      &   ADtEA1derx(1,1,1,1,1,2))
8120         ENDIF
8121 C End 6-th order cumulants
8122         call transpose2(EUgder(1,1,l),auxmat(1,1))
8123         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8124         call transpose2(EUg(1,1,l),auxmat(1,1))
8125         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8126         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8127         do iii=1,2
8128           do kkk=1,5
8129             do lll=1,3
8130               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8131      &          EAEAderx(1,1,lll,kkk,iii,2))
8132             enddo
8133           enddo
8134         enddo
8135 C AEAb1 and AEAb2
8136 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8137 C They are needed only when the fifth- or the sixth-order cumulants are
8138 C indluded.
8139         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8140         call transpose2(AEA(1,1,1),auxmat(1,1))
8141         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8143         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8144         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8145         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8146         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8147         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8148         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8149         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8150         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8151         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8152         call transpose2(AEA(1,1,2),auxmat(1,1))
8153         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8154         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8155         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8156         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8157         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8158         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8159         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8160         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8161         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8162         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8163         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8164 C Calculate the Cartesian derivatives of the vectors.
8165         do iii=1,2
8166           do kkk=1,5
8167             do lll=1,3
8168               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8169               call matvec2(auxmat(1,1),b1(1,i),
8170      &          AEAb1derx(1,lll,kkk,iii,1,1))
8171               call matvec2(auxmat(1,1),Ub2(1,i),
8172      &          AEAb2derx(1,lll,kkk,iii,1,1))
8173               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8174      &          AEAb1derx(1,lll,kkk,iii,2,1))
8175               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8176      &          AEAb2derx(1,lll,kkk,iii,2,1))
8177               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8178               call matvec2(auxmat(1,1),b1(1,j),
8179      &          AEAb1derx(1,lll,kkk,iii,1,2))
8180               call matvec2(auxmat(1,1),Ub2(1,j),
8181      &          AEAb2derx(1,lll,kkk,iii,1,2))
8182               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8183      &          AEAb1derx(1,lll,kkk,iii,2,2))
8184               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8185      &          AEAb2derx(1,lll,kkk,iii,2,2))
8186             enddo
8187           enddo
8188         enddo
8189         ENDIF
8190 C End vectors
8191       else
8192 C Antiparallel orientation of the two CA-CA-CA frames.
8193         if (i.gt.1) then
8194           iti=itortyp(itype(i))
8195         else
8196           iti=ntortyp
8197         endif
8198         itk1=itortyp(itype(k+1))
8199         itl=itortyp(itype(l))
8200         itj=itortyp(itype(j))
8201         if (j.lt.nres-1) then
8202           itj1=itortyp(itype(j+1))
8203         else
8204           itj1=ntortyp
8205         endif
8206 C A2 kernel(j-1)T A1T
8207         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8208      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8209      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8210 C Following matrices are needed only for 6-th order cumulants
8211         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8212      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8213         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8214      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8215      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8216         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8217      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8218      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8219      &   ADtEAderx(1,1,1,1,1,1))
8220         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8221      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8222      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8223      &   ADtEA1derx(1,1,1,1,1,1))
8224         ENDIF
8225 C End 6-th order cumulants
8226         call transpose2(EUgder(1,1,k),auxmat(1,1))
8227         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8228         call transpose2(EUg(1,1,k),auxmat(1,1))
8229         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8230         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8231         do iii=1,2
8232           do kkk=1,5
8233             do lll=1,3
8234               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8235      &          EAEAderx(1,1,lll,kkk,iii,1))
8236             enddo
8237           enddo
8238         enddo
8239 C A2T kernel(i+1)T A1
8240         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8241      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8242      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8243 C Following matrices are needed only for 6-th order cumulants
8244         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8245      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8246         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8247      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8248      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8249         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8250      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8251      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8252      &   ADtEAderx(1,1,1,1,1,2))
8253         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8254      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8255      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8256      &   ADtEA1derx(1,1,1,1,1,2))
8257         ENDIF
8258 C End 6-th order cumulants
8259         call transpose2(EUgder(1,1,j),auxmat(1,1))
8260         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8261         call transpose2(EUg(1,1,j),auxmat(1,1))
8262         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8263         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8264         do iii=1,2
8265           do kkk=1,5
8266             do lll=1,3
8267               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8268      &          EAEAderx(1,1,lll,kkk,iii,2))
8269             enddo
8270           enddo
8271         enddo
8272 C AEAb1 and AEAb2
8273 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8274 C They are needed only when the fifth- or the sixth-order cumulants are
8275 C indluded.
8276         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8277      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8278         call transpose2(AEA(1,1,1),auxmat(1,1))
8279         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8280         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8281         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8282         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8283         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8284         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8285         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8286         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8287         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8288         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8289         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8290         call transpose2(AEA(1,1,2),auxmat(1,1))
8291         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8292         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8293         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8294         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8295         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8296         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8297         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8298         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8299         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8300         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8301         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8302 C Calculate the Cartesian derivatives of the vectors.
8303         do iii=1,2
8304           do kkk=1,5
8305             do lll=1,3
8306               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8307               call matvec2(auxmat(1,1),b1(1,i),
8308      &          AEAb1derx(1,lll,kkk,iii,1,1))
8309               call matvec2(auxmat(1,1),Ub2(1,i),
8310      &          AEAb2derx(1,lll,kkk,iii,1,1))
8311               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8312      &          AEAb1derx(1,lll,kkk,iii,2,1))
8313               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8314      &          AEAb2derx(1,lll,kkk,iii,2,1))
8315               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8316               call matvec2(auxmat(1,1),b1(1,l),
8317      &          AEAb1derx(1,lll,kkk,iii,1,2))
8318               call matvec2(auxmat(1,1),Ub2(1,l),
8319      &          AEAb2derx(1,lll,kkk,iii,1,2))
8320               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8321      &          AEAb1derx(1,lll,kkk,iii,2,2))
8322               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8323      &          AEAb2derx(1,lll,kkk,iii,2,2))
8324             enddo
8325           enddo
8326         enddo
8327         ENDIF
8328 C End vectors
8329       endif
8330       return
8331       end
8332 C---------------------------------------------------------------------------
8333       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8334      &  KK,KKderg,AKA,AKAderg,AKAderx)
8335       implicit none
8336       integer nderg
8337       logical transp
8338       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8339      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8340      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8341       integer iii,kkk,lll
8342       integer jjj,mmm
8343       logical lprn
8344       common /kutas/ lprn
8345       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8346       do iii=1,nderg
8347         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8348      &    AKAderg(1,1,iii))
8349       enddo
8350 cd      if (lprn) write (2,*) 'In kernel'
8351       do kkk=1,5
8352 cd        if (lprn) write (2,*) 'kkk=',kkk
8353         do lll=1,3
8354           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8355      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8356 cd          if (lprn) then
8357 cd            write (2,*) 'lll=',lll
8358 cd            write (2,*) 'iii=1'
8359 cd            do jjj=1,2
8360 cd              write (2,'(3(2f10.5),5x)')
8361 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8362 cd            enddo
8363 cd          endif
8364           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8365      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8366 cd          if (lprn) then
8367 cd            write (2,*) 'lll=',lll
8368 cd            write (2,*) 'iii=2'
8369 cd            do jjj=1,2
8370 cd              write (2,'(3(2f10.5),5x)')
8371 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8372 cd            enddo
8373 cd          endif
8374         enddo
8375       enddo
8376       return
8377       end
8378 C---------------------------------------------------------------------------
8379       double precision function eello4(i,j,k,l,jj,kk)
8380       implicit real*8 (a-h,o-z)
8381       include 'DIMENSIONS'
8382       include 'COMMON.IOUNITS'
8383       include 'COMMON.CHAIN'
8384       include 'COMMON.DERIV'
8385       include 'COMMON.INTERACT'
8386       include 'COMMON.CONTACTS'
8387       include 'COMMON.TORSION'
8388       include 'COMMON.VAR'
8389       include 'COMMON.GEO'
8390       double precision pizda(2,2),ggg1(3),ggg2(3)
8391 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8392 cd        eello4=0.0d0
8393 cd        return
8394 cd      endif
8395 cd      print *,'eello4:',i,j,k,l,jj,kk
8396 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8397 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8398 cold      eij=facont_hb(jj,i)
8399 cold      ekl=facont_hb(kk,k)
8400 cold      ekont=eij*ekl
8401       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8402 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8403       gcorr_loc(k-1)=gcorr_loc(k-1)
8404      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8405       if (l.eq.j+1) then
8406         gcorr_loc(l-1)=gcorr_loc(l-1)
8407      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8408       else
8409         gcorr_loc(j-1)=gcorr_loc(j-1)
8410      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8411       endif
8412       do iii=1,2
8413         do kkk=1,5
8414           do lll=1,3
8415             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8416      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8417 cd            derx(lll,kkk,iii)=0.0d0
8418           enddo
8419         enddo
8420       enddo
8421 cd      gcorr_loc(l-1)=0.0d0
8422 cd      gcorr_loc(j-1)=0.0d0
8423 cd      gcorr_loc(k-1)=0.0d0
8424 cd      eel4=1.0d0
8425 cd      write (iout,*)'Contacts have occurred for peptide groups',
8426 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8427 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8428       if (j.lt.nres-1) then
8429         j1=j+1
8430         j2=j-1
8431       else
8432         j1=j-1
8433         j2=j-2
8434       endif
8435       if (l.lt.nres-1) then
8436         l1=l+1
8437         l2=l-1
8438       else
8439         l1=l-1
8440         l2=l-2
8441       endif
8442       do ll=1,3
8443 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8444 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8445         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8446         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8447 cgrad        ghalf=0.5d0*ggg1(ll)
8448         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8449         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8450         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8451         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8452         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8453         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8454 cgrad        ghalf=0.5d0*ggg2(ll)
8455         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8456         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8457         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8458         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8459         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8460         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8461       enddo
8462 cgrad      do m=i+1,j-1
8463 cgrad        do ll=1,3
8464 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8465 cgrad        enddo
8466 cgrad      enddo
8467 cgrad      do m=k+1,l-1
8468 cgrad        do ll=1,3
8469 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8470 cgrad        enddo
8471 cgrad      enddo
8472 cgrad      do m=i+2,j2
8473 cgrad        do ll=1,3
8474 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8475 cgrad        enddo
8476 cgrad      enddo
8477 cgrad      do m=k+2,l2
8478 cgrad        do ll=1,3
8479 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8480 cgrad        enddo
8481 cgrad      enddo
8482 cd      do iii=1,nres-3
8483 cd        write (2,*) iii,gcorr_loc(iii)
8484 cd      enddo
8485       eello4=ekont*eel4
8486 cd      write (2,*) 'ekont',ekont
8487 cd      write (iout,*) 'eello4',ekont*eel4
8488       return
8489       end
8490 C---------------------------------------------------------------------------
8491       double precision function eello5(i,j,k,l,jj,kk)
8492       implicit real*8 (a-h,o-z)
8493       include 'DIMENSIONS'
8494       include 'COMMON.IOUNITS'
8495       include 'COMMON.CHAIN'
8496       include 'COMMON.DERIV'
8497       include 'COMMON.INTERACT'
8498       include 'COMMON.CONTACTS'
8499       include 'COMMON.TORSION'
8500       include 'COMMON.VAR'
8501       include 'COMMON.GEO'
8502       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8503       double precision ggg1(3),ggg2(3)
8504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8505 C                                                                              C
8506 C                            Parallel chains                                   C
8507 C                                                                              C
8508 C          o             o                   o             o                   C
8509 C         /l\           / \             \   / \           / \   /              C
8510 C        /   \         /   \             \ /   \         /   \ /               C
8511 C       j| o |l1       | o |              o| o |         | o |o                C
8512 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8513 C      \i/   \         /   \ /             /   \         /   \                 C
8514 C       o    k1             o                                                  C
8515 C         (I)          (II)                (III)          (IV)                 C
8516 C                                                                              C
8517 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8518 C                                                                              C
8519 C                            Antiparallel chains                               C
8520 C                                                                              C
8521 C          o             o                   o             o                   C
8522 C         /j\           / \             \   / \           / \   /              C
8523 C        /   \         /   \             \ /   \         /   \ /               C
8524 C      j1| o |l        | o |              o| o |         | o |o                C
8525 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8526 C      \i/   \         /   \ /             /   \         /   \                 C
8527 C       o     k1            o                                                  C
8528 C         (I)          (II)                (III)          (IV)                 C
8529 C                                                                              C
8530 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8531 C                                                                              C
8532 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8533 C                                                                              C
8534 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8535 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8536 cd        eello5=0.0d0
8537 cd        return
8538 cd      endif
8539 cd      write (iout,*)
8540 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8541 cd     &   ' and',k,l
8542       itk=itortyp(itype(k))
8543       itl=itortyp(itype(l))
8544       itj=itortyp(itype(j))
8545       eello5_1=0.0d0
8546       eello5_2=0.0d0
8547       eello5_3=0.0d0
8548       eello5_4=0.0d0
8549 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8550 cd     &   eel5_3_num,eel5_4_num)
8551       do iii=1,2
8552         do kkk=1,5
8553           do lll=1,3
8554             derx(lll,kkk,iii)=0.0d0
8555           enddo
8556         enddo
8557       enddo
8558 cd      eij=facont_hb(jj,i)
8559 cd      ekl=facont_hb(kk,k)
8560 cd      ekont=eij*ekl
8561 cd      write (iout,*)'Contacts have occurred for peptide groups',
8562 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8563 cd      goto 1111
8564 C Contribution from the graph I.
8565 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8566 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8567       call transpose2(EUg(1,1,k),auxmat(1,1))
8568       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8569       vv(1)=pizda(1,1)-pizda(2,2)
8570       vv(2)=pizda(1,2)+pizda(2,1)
8571       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8572      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8573 C Explicit gradient in virtual-dihedral angles.
8574       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8575      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8576      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8577       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8578       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8579       vv(1)=pizda(1,1)-pizda(2,2)
8580       vv(2)=pizda(1,2)+pizda(2,1)
8581       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8582      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8583      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8584       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8585       vv(1)=pizda(1,1)-pizda(2,2)
8586       vv(2)=pizda(1,2)+pizda(2,1)
8587       if (l.eq.j+1) then
8588         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8589      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8591       else
8592         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8593      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8595       endif
8596 C Cartesian gradient
8597       do iii=1,2
8598         do kkk=1,5
8599           do lll=1,3
8600             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8601      &        pizda(1,1))
8602             vv(1)=pizda(1,1)-pizda(2,2)
8603             vv(2)=pizda(1,2)+pizda(2,1)
8604             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8605      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8606      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8607           enddo
8608         enddo
8609       enddo
8610 c      goto 1112
8611 c1111  continue
8612 C Contribution from graph II
8613       call transpose2(EE(1,1,itk),auxmat(1,1))
8614       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8615       vv(1)=pizda(1,1)+pizda(2,2)
8616       vv(2)=pizda(2,1)-pizda(1,2)
8617       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8618      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8619 C Explicit gradient in virtual-dihedral angles.
8620       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8621      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8622       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8623       vv(1)=pizda(1,1)+pizda(2,2)
8624       vv(2)=pizda(2,1)-pizda(1,2)
8625       if (l.eq.j+1) then
8626         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8627      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8628      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8629       else
8630         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8631      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8632      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8633       endif
8634 C Cartesian gradient
8635       do iii=1,2
8636         do kkk=1,5
8637           do lll=1,3
8638             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8639      &        pizda(1,1))
8640             vv(1)=pizda(1,1)+pizda(2,2)
8641             vv(2)=pizda(2,1)-pizda(1,2)
8642             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8643      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8644      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8645           enddo
8646         enddo
8647       enddo
8648 cd      goto 1112
8649 cd1111  continue
8650       if (l.eq.j+1) then
8651 cd        goto 1110
8652 C Parallel orientation
8653 C Contribution from graph III
8654         call transpose2(EUg(1,1,l),auxmat(1,1))
8655         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8656         vv(1)=pizda(1,1)-pizda(2,2)
8657         vv(2)=pizda(1,2)+pizda(2,1)
8658         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8659      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8660 C Explicit gradient in virtual-dihedral angles.
8661         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8662      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8663      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8664         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8665         vv(1)=pizda(1,1)-pizda(2,2)
8666         vv(2)=pizda(1,2)+pizda(2,1)
8667         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8668      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8669      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8670         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8671         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8672         vv(1)=pizda(1,1)-pizda(2,2)
8673         vv(2)=pizda(1,2)+pizda(2,1)
8674         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8675      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8676      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8677 C Cartesian gradient
8678         do iii=1,2
8679           do kkk=1,5
8680             do lll=1,3
8681               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8682      &          pizda(1,1))
8683               vv(1)=pizda(1,1)-pizda(2,2)
8684               vv(2)=pizda(1,2)+pizda(2,1)
8685               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8686      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8687      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8688             enddo
8689           enddo
8690         enddo
8691 cd        goto 1112
8692 C Contribution from graph IV
8693 cd1110    continue
8694         call transpose2(EE(1,1,itl),auxmat(1,1))
8695         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8696         vv(1)=pizda(1,1)+pizda(2,2)
8697         vv(2)=pizda(2,1)-pizda(1,2)
8698         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8699      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8700 C Explicit gradient in virtual-dihedral angles.
8701         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8702      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8703         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8704         vv(1)=pizda(1,1)+pizda(2,2)
8705         vv(2)=pizda(2,1)-pizda(1,2)
8706         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8707      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8708      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8709 C Cartesian gradient
8710         do iii=1,2
8711           do kkk=1,5
8712             do lll=1,3
8713               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8714      &          pizda(1,1))
8715               vv(1)=pizda(1,1)+pizda(2,2)
8716               vv(2)=pizda(2,1)-pizda(1,2)
8717               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8718      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8719      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8720             enddo
8721           enddo
8722         enddo
8723       else
8724 C Antiparallel orientation
8725 C Contribution from graph III
8726 c        goto 1110
8727         call transpose2(EUg(1,1,j),auxmat(1,1))
8728         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8729         vv(1)=pizda(1,1)-pizda(2,2)
8730         vv(2)=pizda(1,2)+pizda(2,1)
8731         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8732      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8733 C Explicit gradient in virtual-dihedral angles.
8734         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8735      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8736      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8737         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8738         vv(1)=pizda(1,1)-pizda(2,2)
8739         vv(2)=pizda(1,2)+pizda(2,1)
8740         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8741      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8742      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8743         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8744         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8745         vv(1)=pizda(1,1)-pizda(2,2)
8746         vv(2)=pizda(1,2)+pizda(2,1)
8747         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8748      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8749      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8750 C Cartesian gradient
8751         do iii=1,2
8752           do kkk=1,5
8753             do lll=1,3
8754               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8755      &          pizda(1,1))
8756               vv(1)=pizda(1,1)-pizda(2,2)
8757               vv(2)=pizda(1,2)+pizda(2,1)
8758               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8759      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8760      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8761             enddo
8762           enddo
8763         enddo
8764 cd        goto 1112
8765 C Contribution from graph IV
8766 1110    continue
8767         call transpose2(EE(1,1,itj),auxmat(1,1))
8768         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8769         vv(1)=pizda(1,1)+pizda(2,2)
8770         vv(2)=pizda(2,1)-pizda(1,2)
8771         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8772      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8773 C Explicit gradient in virtual-dihedral angles.
8774         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8775      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8776         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8777         vv(1)=pizda(1,1)+pizda(2,2)
8778         vv(2)=pizda(2,1)-pizda(1,2)
8779         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8780      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8781      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8782 C Cartesian gradient
8783         do iii=1,2
8784           do kkk=1,5
8785             do lll=1,3
8786               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8787      &          pizda(1,1))
8788               vv(1)=pizda(1,1)+pizda(2,2)
8789               vv(2)=pizda(2,1)-pizda(1,2)
8790               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8791      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8792      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8793             enddo
8794           enddo
8795         enddo
8796       endif
8797 1112  continue
8798       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8799 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8800 cd        write (2,*) 'ijkl',i,j,k,l
8801 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8802 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8803 cd      endif
8804 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8805 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8806 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8807 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8808       if (j.lt.nres-1) then
8809         j1=j+1
8810         j2=j-1
8811       else
8812         j1=j-1
8813         j2=j-2
8814       endif
8815       if (l.lt.nres-1) then
8816         l1=l+1
8817         l2=l-1
8818       else
8819         l1=l-1
8820         l2=l-2
8821       endif
8822 cd      eij=1.0d0
8823 cd      ekl=1.0d0
8824 cd      ekont=1.0d0
8825 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8826 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8827 C        summed up outside the subrouine as for the other subroutines
8828 C        handling long-range interactions. The old code is commented out
8829 C        with "cgrad" to keep track of changes.
8830       do ll=1,3
8831 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8832 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8833         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8834         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8835 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8836 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8837 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8838 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8839 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8840 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8841 c     &   gradcorr5ij,
8842 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8843 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8844 cgrad        ghalf=0.5d0*ggg1(ll)
8845 cd        ghalf=0.0d0
8846         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8847         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8848         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8849         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8850         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8851         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8852 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8853 cgrad        ghalf=0.5d0*ggg2(ll)
8854 cd        ghalf=0.0d0
8855         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8856         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8857         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8858         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8859         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8860         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8861       enddo
8862 cd      goto 1112
8863 cgrad      do m=i+1,j-1
8864 cgrad        do ll=1,3
8865 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8866 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8867 cgrad        enddo
8868 cgrad      enddo
8869 cgrad      do m=k+1,l-1
8870 cgrad        do ll=1,3
8871 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8872 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8873 cgrad        enddo
8874 cgrad      enddo
8875 c1112  continue
8876 cgrad      do m=i+2,j2
8877 cgrad        do ll=1,3
8878 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8879 cgrad        enddo
8880 cgrad      enddo
8881 cgrad      do m=k+2,l2
8882 cgrad        do ll=1,3
8883 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8884 cgrad        enddo
8885 cgrad      enddo
8886 cd      do iii=1,nres-3
8887 cd        write (2,*) iii,g_corr5_loc(iii)
8888 cd      enddo
8889       eello5=ekont*eel5
8890 cd      write (2,*) 'ekont',ekont
8891 cd      write (iout,*) 'eello5',ekont*eel5
8892       return
8893       end
8894 c--------------------------------------------------------------------------
8895       double precision function eello6(i,j,k,l,jj,kk)
8896       implicit real*8 (a-h,o-z)
8897       include 'DIMENSIONS'
8898       include 'COMMON.IOUNITS'
8899       include 'COMMON.CHAIN'
8900       include 'COMMON.DERIV'
8901       include 'COMMON.INTERACT'
8902       include 'COMMON.CONTACTS'
8903       include 'COMMON.TORSION'
8904       include 'COMMON.VAR'
8905       include 'COMMON.GEO'
8906       include 'COMMON.FFIELD'
8907       double precision ggg1(3),ggg2(3)
8908 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8909 cd        eello6=0.0d0
8910 cd        return
8911 cd      endif
8912 cd      write (iout,*)
8913 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8914 cd     &   ' and',k,l
8915       eello6_1=0.0d0
8916       eello6_2=0.0d0
8917       eello6_3=0.0d0
8918       eello6_4=0.0d0
8919       eello6_5=0.0d0
8920       eello6_6=0.0d0
8921 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8922 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8923       do iii=1,2
8924         do kkk=1,5
8925           do lll=1,3
8926             derx(lll,kkk,iii)=0.0d0
8927           enddo
8928         enddo
8929       enddo
8930 cd      eij=facont_hb(jj,i)
8931 cd      ekl=facont_hb(kk,k)
8932 cd      ekont=eij*ekl
8933 cd      eij=1.0d0
8934 cd      ekl=1.0d0
8935 cd      ekont=1.0d0
8936       if (l.eq.j+1) then
8937         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8938         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8939         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8940         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8941         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8942         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8943       else
8944         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8945         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8946         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8947         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8948         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8949           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8950         else
8951           eello6_5=0.0d0
8952         endif
8953         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8954       endif
8955 C If turn contributions are considered, they will be handled separately.
8956       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8957 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8958 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8959 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8960 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8961 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8962 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8963 cd      goto 1112
8964       if (j.lt.nres-1) then
8965         j1=j+1
8966         j2=j-1
8967       else
8968         j1=j-1
8969         j2=j-2
8970       endif
8971       if (l.lt.nres-1) then
8972         l1=l+1
8973         l2=l-1
8974       else
8975         l1=l-1
8976         l2=l-2
8977       endif
8978       do ll=1,3
8979 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8980 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8981 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8982 cgrad        ghalf=0.5d0*ggg1(ll)
8983 cd        ghalf=0.0d0
8984         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8985         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8986         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8987         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8988         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8989         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8990         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8991         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8992 cgrad        ghalf=0.5d0*ggg2(ll)
8993 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8994 cd        ghalf=0.0d0
8995         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8996         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8997         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8998         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8999         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9000         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9001       enddo
9002 cd      goto 1112
9003 cgrad      do m=i+1,j-1
9004 cgrad        do ll=1,3
9005 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9006 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9007 cgrad        enddo
9008 cgrad      enddo
9009 cgrad      do m=k+1,l-1
9010 cgrad        do ll=1,3
9011 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9012 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9013 cgrad        enddo
9014 cgrad      enddo
9015 cgrad1112  continue
9016 cgrad      do m=i+2,j2
9017 cgrad        do ll=1,3
9018 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9019 cgrad        enddo
9020 cgrad      enddo
9021 cgrad      do m=k+2,l2
9022 cgrad        do ll=1,3
9023 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9024 cgrad        enddo
9025 cgrad      enddo
9026 cd      do iii=1,nres-3
9027 cd        write (2,*) iii,g_corr6_loc(iii)
9028 cd      enddo
9029       eello6=ekont*eel6
9030 cd      write (2,*) 'ekont',ekont
9031 cd      write (iout,*) 'eello6',ekont*eel6
9032       return
9033       end
9034 c--------------------------------------------------------------------------
9035       double precision function eello6_graph1(i,j,k,l,imat,swap)
9036       implicit real*8 (a-h,o-z)
9037       include 'DIMENSIONS'
9038       include 'COMMON.IOUNITS'
9039       include 'COMMON.CHAIN'
9040       include 'COMMON.DERIV'
9041       include 'COMMON.INTERACT'
9042       include 'COMMON.CONTACTS'
9043       include 'COMMON.TORSION'
9044       include 'COMMON.VAR'
9045       include 'COMMON.GEO'
9046       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9047       logical swap
9048       logical lprn
9049       common /kutas/ lprn
9050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9051 C                                                                              C
9052 C      Parallel       Antiparallel                                             C
9053 C                                                                              C
9054 C          o             o                                                     C
9055 C         /l\           /j\                                                    C
9056 C        /   \         /   \                                                   C
9057 C       /| o |         | o |\                                                  C
9058 C     \ j|/k\|  /   \  |/k\|l /                                                C
9059 C      \ /   \ /     \ /   \ /                                                 C
9060 C       o     o       o     o                                                  C
9061 C       i             i                                                        C
9062 C                                                                              C
9063 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9064       itk=itortyp(itype(k))
9065       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9066       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9067       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9068       call transpose2(EUgC(1,1,k),auxmat(1,1))
9069       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9070       vv1(1)=pizda1(1,1)-pizda1(2,2)
9071       vv1(2)=pizda1(1,2)+pizda1(2,1)
9072       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9073       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9074       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9075       s5=scalar2(vv(1),Dtobr2(1,i))
9076 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9077       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9078       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9079      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9080      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9081      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9082      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9083      & +scalar2(vv(1),Dtobr2der(1,i)))
9084       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9085       vv1(1)=pizda1(1,1)-pizda1(2,2)
9086       vv1(2)=pizda1(1,2)+pizda1(2,1)
9087       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9088       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9089       if (l.eq.j+1) then
9090         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9091      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9092      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9093      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9094      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9095       else
9096         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9097      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9098      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9099      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9100      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9101       endif
9102       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9103       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9104       vv1(1)=pizda1(1,1)-pizda1(2,2)
9105       vv1(2)=pizda1(1,2)+pizda1(2,1)
9106       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9107      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9108      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9109      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9110       do iii=1,2
9111         if (swap) then
9112           ind=3-iii
9113         else
9114           ind=iii
9115         endif
9116         do kkk=1,5
9117           do lll=1,3
9118             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9119             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9120             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9121             call transpose2(EUgC(1,1,k),auxmat(1,1))
9122             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9123      &        pizda1(1,1))
9124             vv1(1)=pizda1(1,1)-pizda1(2,2)
9125             vv1(2)=pizda1(1,2)+pizda1(2,1)
9126             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9127             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9128      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9129             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9130      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9131             s5=scalar2(vv(1),Dtobr2(1,i))
9132             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9133           enddo
9134         enddo
9135       enddo
9136       return
9137       end
9138 c----------------------------------------------------------------------------
9139       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9140       implicit real*8 (a-h,o-z)
9141       include 'DIMENSIONS'
9142       include 'COMMON.IOUNITS'
9143       include 'COMMON.CHAIN'
9144       include 'COMMON.DERIV'
9145       include 'COMMON.INTERACT'
9146       include 'COMMON.CONTACTS'
9147       include 'COMMON.TORSION'
9148       include 'COMMON.VAR'
9149       include 'COMMON.GEO'
9150       logical swap
9151       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9152      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9153       logical lprn
9154       common /kutas/ lprn
9155 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9156 C                                                                              C
9157 C      Parallel       Antiparallel                                             C
9158 C                                                                              C
9159 C          o             o                                                     C
9160 C     \   /l\           /j\   /                                                C
9161 C      \ /   \         /   \ /                                                 C
9162 C       o| o |         | o |o                                                  C
9163 C     \ j|/k\|      \  |/k\|l                                                  C
9164 C      \ /   \       \ /   \                                                   C
9165 C       o             o                                                        C
9166 C       i             i                                                        C
9167 C                                                                              C
9168 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9169 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9170 C AL 7/4/01 s1 would occur in the sixth-order moment,
9171 C           but not in a cluster cumulant
9172 #ifdef MOMENT
9173       s1=dip(1,jj,i)*dip(1,kk,k)
9174 #endif
9175       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9176       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9177       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9178       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9179       call transpose2(EUg(1,1,k),auxmat(1,1))
9180       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9181       vv(1)=pizda(1,1)-pizda(2,2)
9182       vv(2)=pizda(1,2)+pizda(2,1)
9183       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9184 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9185 #ifdef MOMENT
9186       eello6_graph2=-(s1+s2+s3+s4)
9187 #else
9188       eello6_graph2=-(s2+s3+s4)
9189 #endif
9190 c      eello6_graph2=-s3
9191 C Derivatives in gamma(i-1)
9192       if (i.gt.1) then
9193 #ifdef MOMENT
9194         s1=dipderg(1,jj,i)*dip(1,kk,k)
9195 #endif
9196         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9197         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9198         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9199         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9200 #ifdef MOMENT
9201         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9202 #else
9203         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9204 #endif
9205 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9206       endif
9207 C Derivatives in gamma(k-1)
9208 #ifdef MOMENT
9209       s1=dip(1,jj,i)*dipderg(1,kk,k)
9210 #endif
9211       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9212       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9213       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9214       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9215       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9216       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9217       vv(1)=pizda(1,1)-pizda(2,2)
9218       vv(2)=pizda(1,2)+pizda(2,1)
9219       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9220 #ifdef MOMENT
9221       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9222 #else
9223       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9224 #endif
9225 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9226 C Derivatives in gamma(j-1) or gamma(l-1)
9227       if (j.gt.1) then
9228 #ifdef MOMENT
9229         s1=dipderg(3,jj,i)*dip(1,kk,k)
9230 #endif
9231         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9232         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9233         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9234         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9235         vv(1)=pizda(1,1)-pizda(2,2)
9236         vv(2)=pizda(1,2)+pizda(2,1)
9237         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9238 #ifdef MOMENT
9239         if (swap) then
9240           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9241         else
9242           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9243         endif
9244 #endif
9245         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9246 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9247       endif
9248 C Derivatives in gamma(l-1) or gamma(j-1)
9249       if (l.gt.1) then
9250 #ifdef MOMENT
9251         s1=dip(1,jj,i)*dipderg(3,kk,k)
9252 #endif
9253         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9254         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9255         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9256         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9257         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9258         vv(1)=pizda(1,1)-pizda(2,2)
9259         vv(2)=pizda(1,2)+pizda(2,1)
9260         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9261 #ifdef MOMENT
9262         if (swap) then
9263           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9264         else
9265           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9266         endif
9267 #endif
9268         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9269 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9270       endif
9271 C Cartesian derivatives.
9272       if (lprn) then
9273         write (2,*) 'In eello6_graph2'
9274         do iii=1,2
9275           write (2,*) 'iii=',iii
9276           do kkk=1,5
9277             write (2,*) 'kkk=',kkk
9278             do jjj=1,2
9279               write (2,'(3(2f10.5),5x)')
9280      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9281             enddo
9282           enddo
9283         enddo
9284       endif
9285       do iii=1,2
9286         do kkk=1,5
9287           do lll=1,3
9288 #ifdef MOMENT
9289             if (iii.eq.1) then
9290               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9291             else
9292               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9293             endif
9294 #endif
9295             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9296      &        auxvec(1))
9297             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9298             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9299      &        auxvec(1))
9300             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9301             call transpose2(EUg(1,1,k),auxmat(1,1))
9302             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9303      &        pizda(1,1))
9304             vv(1)=pizda(1,1)-pizda(2,2)
9305             vv(2)=pizda(1,2)+pizda(2,1)
9306             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9307 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9308 #ifdef MOMENT
9309             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9310 #else
9311             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9312 #endif
9313             if (swap) then
9314               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9315             else
9316               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9317             endif
9318           enddo
9319         enddo
9320       enddo
9321       return
9322       end
9323 c----------------------------------------------------------------------------
9324       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9325       implicit real*8 (a-h,o-z)
9326       include 'DIMENSIONS'
9327       include 'COMMON.IOUNITS'
9328       include 'COMMON.CHAIN'
9329       include 'COMMON.DERIV'
9330       include 'COMMON.INTERACT'
9331       include 'COMMON.CONTACTS'
9332       include 'COMMON.TORSION'
9333       include 'COMMON.VAR'
9334       include 'COMMON.GEO'
9335       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9336       logical swap
9337 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9338 C                                                                              C
9339 C      Parallel       Antiparallel                                             C
9340 C                                                                              C
9341 C          o             o                                                     C
9342 C         /l\   /   \   /j\                                                    C
9343 C        /   \ /     \ /   \                                                   C
9344 C       /| o |o       o| o |\                                                  C
9345 C       j|/k\|  /      |/k\|l /                                                C
9346 C        /   \ /       /   \ /                                                 C
9347 C       /     o       /     o                                                  C
9348 C       i             i                                                        C
9349 C                                                                              C
9350 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9351 C
9352 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9353 C           energy moment and not to the cluster cumulant.
9354       iti=itortyp(itype(i))
9355       if (j.lt.nres-1) then
9356         itj1=itortyp(itype(j+1))
9357       else
9358         itj1=ntortyp
9359       endif
9360       itk=itortyp(itype(k))
9361       itk1=itortyp(itype(k+1))
9362       if (l.lt.nres-1) then
9363         itl1=itortyp(itype(l+1))
9364       else
9365         itl1=ntortyp
9366       endif
9367 #ifdef MOMENT
9368       s1=dip(4,jj,i)*dip(4,kk,k)
9369 #endif
9370       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9371       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9372       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9373       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9374       call transpose2(EE(1,1,itk),auxmat(1,1))
9375       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9376       vv(1)=pizda(1,1)+pizda(2,2)
9377       vv(2)=pizda(2,1)-pizda(1,2)
9378       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9379 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9380 cd     & "sum",-(s2+s3+s4)
9381 #ifdef MOMENT
9382       eello6_graph3=-(s1+s2+s3+s4)
9383 #else
9384       eello6_graph3=-(s2+s3+s4)
9385 #endif
9386 c      eello6_graph3=-s4
9387 C Derivatives in gamma(k-1)
9388       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9389       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9390       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9391       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9392 C Derivatives in gamma(l-1)
9393       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9394       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9395       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9396       vv(1)=pizda(1,1)+pizda(2,2)
9397       vv(2)=pizda(2,1)-pizda(1,2)
9398       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9399       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9400 C Cartesian derivatives.
9401       do iii=1,2
9402         do kkk=1,5
9403           do lll=1,3
9404 #ifdef MOMENT
9405             if (iii.eq.1) then
9406               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9407             else
9408               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9409             endif
9410 #endif
9411             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9412      &        auxvec(1))
9413             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9414             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9415      &        auxvec(1))
9416             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9417             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9418      &        pizda(1,1))
9419             vv(1)=pizda(1,1)+pizda(2,2)
9420             vv(2)=pizda(2,1)-pizda(1,2)
9421             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9422 #ifdef MOMENT
9423             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9424 #else
9425             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9426 #endif
9427             if (swap) then
9428               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9429             else
9430               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9431             endif
9432 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9433           enddo
9434         enddo
9435       enddo
9436       return
9437       end
9438 c----------------------------------------------------------------------------
9439       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9440       implicit real*8 (a-h,o-z)
9441       include 'DIMENSIONS'
9442       include 'COMMON.IOUNITS'
9443       include 'COMMON.CHAIN'
9444       include 'COMMON.DERIV'
9445       include 'COMMON.INTERACT'
9446       include 'COMMON.CONTACTS'
9447       include 'COMMON.TORSION'
9448       include 'COMMON.VAR'
9449       include 'COMMON.GEO'
9450       include 'COMMON.FFIELD'
9451       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9452      & auxvec1(2),auxmat1(2,2)
9453       logical swap
9454 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9455 C                                                                              C
9456 C      Parallel       Antiparallel                                             C
9457 C                                                                              C
9458 C          o             o                                                     C
9459 C         /l\   /   \   /j\                                                    C
9460 C        /   \ /     \ /   \                                                   C
9461 C       /| o |o       o| o |\                                                  C
9462 C     \ j|/k\|      \  |/k\|l                                                  C
9463 C      \ /   \       \ /   \                                                   C
9464 C       o     \       o     \                                                  C
9465 C       i             i                                                        C
9466 C                                                                              C
9467 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9468 C
9469 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9470 C           energy moment and not to the cluster cumulant.
9471 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9472       iti=itortyp(itype(i))
9473       itj=itortyp(itype(j))
9474       if (j.lt.nres-1) then
9475         itj1=itortyp(itype(j+1))
9476       else
9477         itj1=ntortyp
9478       endif
9479       itk=itortyp(itype(k))
9480       if (k.lt.nres-1) then
9481         itk1=itortyp(itype(k+1))
9482       else
9483         itk1=ntortyp
9484       endif
9485       itl=itortyp(itype(l))
9486       if (l.lt.nres-1) then
9487         itl1=itortyp(itype(l+1))
9488       else
9489         itl1=ntortyp
9490       endif
9491 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9492 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9493 cd     & ' itl',itl,' itl1',itl1
9494 #ifdef MOMENT
9495       if (imat.eq.1) then
9496         s1=dip(3,jj,i)*dip(3,kk,k)
9497       else
9498         s1=dip(2,jj,j)*dip(2,kk,l)
9499       endif
9500 #endif
9501       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9502       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9503       if (j.eq.l+1) then
9504         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9505         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9506       else
9507         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9508         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9509       endif
9510       call transpose2(EUg(1,1,k),auxmat(1,1))
9511       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9512       vv(1)=pizda(1,1)-pizda(2,2)
9513       vv(2)=pizda(2,1)+pizda(1,2)
9514       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9515 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9516 #ifdef MOMENT
9517       eello6_graph4=-(s1+s2+s3+s4)
9518 #else
9519       eello6_graph4=-(s2+s3+s4)
9520 #endif
9521 C Derivatives in gamma(i-1)
9522       if (i.gt.1) then
9523 #ifdef MOMENT
9524         if (imat.eq.1) then
9525           s1=dipderg(2,jj,i)*dip(3,kk,k)
9526         else
9527           s1=dipderg(4,jj,j)*dip(2,kk,l)
9528         endif
9529 #endif
9530         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9531         if (j.eq.l+1) then
9532           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9533           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9534         else
9535           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9536           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9537         endif
9538         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9539         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9540 cd          write (2,*) 'turn6 derivatives'
9541 #ifdef MOMENT
9542           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9543 #else
9544           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9545 #endif
9546         else
9547 #ifdef MOMENT
9548           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9549 #else
9550           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9551 #endif
9552         endif
9553       endif
9554 C Derivatives in gamma(k-1)
9555 #ifdef MOMENT
9556       if (imat.eq.1) then
9557         s1=dip(3,jj,i)*dipderg(2,kk,k)
9558       else
9559         s1=dip(2,jj,j)*dipderg(4,kk,l)
9560       endif
9561 #endif
9562       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9563       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9564       if (j.eq.l+1) then
9565         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9566         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9567       else
9568         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9569         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9570       endif
9571       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9572       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9573       vv(1)=pizda(1,1)-pizda(2,2)
9574       vv(2)=pizda(2,1)+pizda(1,2)
9575       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9576       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9577 #ifdef MOMENT
9578         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9579 #else
9580         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9581 #endif
9582       else
9583 #ifdef MOMENT
9584         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9585 #else
9586         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9587 #endif
9588       endif
9589 C Derivatives in gamma(j-1) or gamma(l-1)
9590       if (l.eq.j+1 .and. l.gt.1) then
9591         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9592         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9593         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9594         vv(1)=pizda(1,1)-pizda(2,2)
9595         vv(2)=pizda(2,1)+pizda(1,2)
9596         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9597         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9598       else if (j.gt.1) then
9599         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9600         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9601         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9602         vv(1)=pizda(1,1)-pizda(2,2)
9603         vv(2)=pizda(2,1)+pizda(1,2)
9604         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9605         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9606           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9607         else
9608           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9609         endif
9610       endif
9611 C Cartesian derivatives.
9612       do iii=1,2
9613         do kkk=1,5
9614           do lll=1,3
9615 #ifdef MOMENT
9616             if (iii.eq.1) then
9617               if (imat.eq.1) then
9618                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9619               else
9620                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9621               endif
9622             else
9623               if (imat.eq.1) then
9624                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9625               else
9626                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9627               endif
9628             endif
9629 #endif
9630             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9631      &        auxvec(1))
9632             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9633             if (j.eq.l+1) then
9634               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9635      &          b1(1,j+1),auxvec(1))
9636               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9637             else
9638               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9639      &          b1(1,l+1),auxvec(1))
9640               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9641             endif
9642             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9643      &        pizda(1,1))
9644             vv(1)=pizda(1,1)-pizda(2,2)
9645             vv(2)=pizda(2,1)+pizda(1,2)
9646             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9647             if (swap) then
9648               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9649 #ifdef MOMENT
9650                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9651      &             -(s1+s2+s4)
9652 #else
9653                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9654      &             -(s2+s4)
9655 #endif
9656                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9657               else
9658 #ifdef MOMENT
9659                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9660 #else
9661                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9662 #endif
9663                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9664               endif
9665             else
9666 #ifdef MOMENT
9667               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9668 #else
9669               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9670 #endif
9671               if (l.eq.j+1) then
9672                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9673               else
9674                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9675               endif
9676             endif
9677           enddo
9678         enddo
9679       enddo
9680       return
9681       end
9682 c----------------------------------------------------------------------------
9683       double precision function eello_turn6(i,jj,kk)
9684       implicit real*8 (a-h,o-z)
9685       include 'DIMENSIONS'
9686       include 'COMMON.IOUNITS'
9687       include 'COMMON.CHAIN'
9688       include 'COMMON.DERIV'
9689       include 'COMMON.INTERACT'
9690       include 'COMMON.CONTACTS'
9691       include 'COMMON.TORSION'
9692       include 'COMMON.VAR'
9693       include 'COMMON.GEO'
9694       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9695      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9696      &  ggg1(3),ggg2(3)
9697       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9698      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9699 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9700 C           the respective energy moment and not to the cluster cumulant.
9701       s1=0.0d0
9702       s8=0.0d0
9703       s13=0.0d0
9704 c
9705       eello_turn6=0.0d0
9706       j=i+4
9707       k=i+1
9708       l=i+3
9709       iti=itortyp(itype(i))
9710       itk=itortyp(itype(k))
9711       itk1=itortyp(itype(k+1))
9712       itl=itortyp(itype(l))
9713       itj=itortyp(itype(j))
9714 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9715 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9716 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9717 cd        eello6=0.0d0
9718 cd        return
9719 cd      endif
9720 cd      write (iout,*)
9721 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9722 cd     &   ' and',k,l
9723 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9724       do iii=1,2
9725         do kkk=1,5
9726           do lll=1,3
9727             derx_turn(lll,kkk,iii)=0.0d0
9728           enddo
9729         enddo
9730       enddo
9731 cd      eij=1.0d0
9732 cd      ekl=1.0d0
9733 cd      ekont=1.0d0
9734       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9735 cd      eello6_5=0.0d0
9736 cd      write (2,*) 'eello6_5',eello6_5
9737 #ifdef MOMENT
9738       call transpose2(AEA(1,1,1),auxmat(1,1))
9739       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9740       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9741       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9742 #endif
9743       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9744       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9745       s2 = scalar2(b1(1,k),vtemp1(1))
9746 #ifdef MOMENT
9747       call transpose2(AEA(1,1,2),atemp(1,1))
9748       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9749       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9750       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9751 #endif
9752       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9753       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9754       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9755 #ifdef MOMENT
9756       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9757       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9758       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9759       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9760       ss13 = scalar2(b1(1,k),vtemp4(1))
9761       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9762 #endif
9763 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9764 c      s1=0.0d0
9765 c      s2=0.0d0
9766 c      s8=0.0d0
9767 c      s12=0.0d0
9768 c      s13=0.0d0
9769       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9770 C Derivatives in gamma(i+2)
9771       s1d =0.0d0
9772       s8d =0.0d0
9773 #ifdef MOMENT
9774       call transpose2(AEA(1,1,1),auxmatd(1,1))
9775       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9776       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9777       call transpose2(AEAderg(1,1,2),atempd(1,1))
9778       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9779       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9780 #endif
9781       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9782       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9783       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9784 c      s1d=0.0d0
9785 c      s2d=0.0d0
9786 c      s8d=0.0d0
9787 c      s12d=0.0d0
9788 c      s13d=0.0d0
9789       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9790 C Derivatives in gamma(i+3)
9791 #ifdef MOMENT
9792       call transpose2(AEA(1,1,1),auxmatd(1,1))
9793       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9794       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9795       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9796 #endif
9797       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9798       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9799       s2d = scalar2(b1(1,k),vtemp1d(1))
9800 #ifdef MOMENT
9801       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9802       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9803 #endif
9804       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9805 #ifdef MOMENT
9806       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9807       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9808       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9809 #endif
9810 c      s1d=0.0d0
9811 c      s2d=0.0d0
9812 c      s8d=0.0d0
9813 c      s12d=0.0d0
9814 c      s13d=0.0d0
9815 #ifdef MOMENT
9816       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9817      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9818 #else
9819       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9820      &               -0.5d0*ekont*(s2d+s12d)
9821 #endif
9822 C Derivatives in gamma(i+4)
9823       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9824       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9825       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9826 #ifdef MOMENT
9827       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9828       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9829       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9830 #endif
9831 c      s1d=0.0d0
9832 c      s2d=0.0d0
9833 c      s8d=0.0d0
9834 C      s12d=0.0d0
9835 c      s13d=0.0d0
9836 #ifdef MOMENT
9837       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9838 #else
9839       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9840 #endif
9841 C Derivatives in gamma(i+5)
9842 #ifdef MOMENT
9843       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9844       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9845       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9846 #endif
9847       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9848       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9849       s2d = scalar2(b1(1,k),vtemp1d(1))
9850 #ifdef MOMENT
9851       call transpose2(AEA(1,1,2),atempd(1,1))
9852       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9853       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9854 #endif
9855       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9856       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9857 #ifdef MOMENT
9858       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9859       ss13d = scalar2(b1(1,k),vtemp4d(1))
9860       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9861 #endif
9862 c      s1d=0.0d0
9863 c      s2d=0.0d0
9864 c      s8d=0.0d0
9865 c      s12d=0.0d0
9866 c      s13d=0.0d0
9867 #ifdef MOMENT
9868       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9869      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9870 #else
9871       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9872      &               -0.5d0*ekont*(s2d+s12d)
9873 #endif
9874 C Cartesian derivatives
9875       do iii=1,2
9876         do kkk=1,5
9877           do lll=1,3
9878 #ifdef MOMENT
9879             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9880             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9881             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9882 #endif
9883             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9884             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9885      &          vtemp1d(1))
9886             s2d = scalar2(b1(1,k),vtemp1d(1))
9887 #ifdef MOMENT
9888             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9889             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9890             s8d = -(atempd(1,1)+atempd(2,2))*
9891      &           scalar2(cc(1,1,itl),vtemp2(1))
9892 #endif
9893             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9894      &           auxmatd(1,1))
9895             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9896             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9897 c      s1d=0.0d0
9898 c      s2d=0.0d0
9899 c      s8d=0.0d0
9900 c      s12d=0.0d0
9901 c      s13d=0.0d0
9902 #ifdef MOMENT
9903             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9904      &        - 0.5d0*(s1d+s2d)
9905 #else
9906             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9907      &        - 0.5d0*s2d
9908 #endif
9909 #ifdef MOMENT
9910             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9911      &        - 0.5d0*(s8d+s12d)
9912 #else
9913             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9914      &        - 0.5d0*s12d
9915 #endif
9916           enddo
9917         enddo
9918       enddo
9919 #ifdef MOMENT
9920       do kkk=1,5
9921         do lll=1,3
9922           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9923      &      achuj_tempd(1,1))
9924           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9925           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9926           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9927           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9928           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9929      &      vtemp4d(1))
9930           ss13d = scalar2(b1(1,k),vtemp4d(1))
9931           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9932           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9933         enddo
9934       enddo
9935 #endif
9936 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9937 cd     &  16*eel_turn6_num
9938 cd      goto 1112
9939       if (j.lt.nres-1) then
9940         j1=j+1
9941         j2=j-1
9942       else
9943         j1=j-1
9944         j2=j-2
9945       endif
9946       if (l.lt.nres-1) then
9947         l1=l+1
9948         l2=l-1
9949       else
9950         l1=l-1
9951         l2=l-2
9952       endif
9953       do ll=1,3
9954 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9955 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9956 cgrad        ghalf=0.5d0*ggg1(ll)
9957 cd        ghalf=0.0d0
9958         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9959         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9960         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9961      &    +ekont*derx_turn(ll,2,1)
9962         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9963         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9964      &    +ekont*derx_turn(ll,4,1)
9965         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9966         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9967         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9968 cgrad        ghalf=0.5d0*ggg2(ll)
9969 cd        ghalf=0.0d0
9970         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9971      &    +ekont*derx_turn(ll,2,2)
9972         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9973         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9974      &    +ekont*derx_turn(ll,4,2)
9975         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9976         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9977         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9978       enddo
9979 cd      goto 1112
9980 cgrad      do m=i+1,j-1
9981 cgrad        do ll=1,3
9982 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9983 cgrad        enddo
9984 cgrad      enddo
9985 cgrad      do m=k+1,l-1
9986 cgrad        do ll=1,3
9987 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9988 cgrad        enddo
9989 cgrad      enddo
9990 cgrad1112  continue
9991 cgrad      do m=i+2,j2
9992 cgrad        do ll=1,3
9993 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9994 cgrad        enddo
9995 cgrad      enddo
9996 cgrad      do m=k+2,l2
9997 cgrad        do ll=1,3
9998 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9999 cgrad        enddo
10000 cgrad      enddo
10001 cd      do iii=1,nres-3
10002 cd        write (2,*) iii,g_corr6_loc(iii)
10003 cd      enddo
10004       eello_turn6=ekont*eel_turn6
10005 cd      write (2,*) 'ekont',ekont
10006 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10007       return
10008       end
10009
10010 C-----------------------------------------------------------------------------
10011       double precision function scalar(u,v)
10012 !DIR$ INLINEALWAYS scalar
10013 #ifndef OSF
10014 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10015 #endif
10016       implicit none
10017       double precision u(3),v(3)
10018 cd      double precision sc
10019 cd      integer i
10020 cd      sc=0.0d0
10021 cd      do i=1,3
10022 cd        sc=sc+u(i)*v(i)
10023 cd      enddo
10024 cd      scalar=sc
10025
10026       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10027       return
10028       end
10029 crc-------------------------------------------------
10030       SUBROUTINE MATVEC2(A1,V1,V2)
10031 !DIR$ INLINEALWAYS MATVEC2
10032 #ifndef OSF
10033 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10034 #endif
10035       implicit real*8 (a-h,o-z)
10036       include 'DIMENSIONS'
10037       DIMENSION A1(2,2),V1(2),V2(2)
10038 c      DO 1 I=1,2
10039 c        VI=0.0
10040 c        DO 3 K=1,2
10041 c    3     VI=VI+A1(I,K)*V1(K)
10042 c        Vaux(I)=VI
10043 c    1 CONTINUE
10044
10045       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10046       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10047
10048       v2(1)=vaux1
10049       v2(2)=vaux2
10050       END
10051 C---------------------------------------
10052       SUBROUTINE MATMAT2(A1,A2,A3)
10053 #ifndef OSF
10054 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10055 #endif
10056       implicit real*8 (a-h,o-z)
10057       include 'DIMENSIONS'
10058       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10059 c      DIMENSION AI3(2,2)
10060 c        DO  J=1,2
10061 c          A3IJ=0.0
10062 c          DO K=1,2
10063 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10064 c          enddo
10065 c          A3(I,J)=A3IJ
10066 c       enddo
10067 c      enddo
10068
10069       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10070       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10071       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10072       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10073
10074       A3(1,1)=AI3_11
10075       A3(2,1)=AI3_21
10076       A3(1,2)=AI3_12
10077       A3(2,2)=AI3_22
10078       END
10079
10080 c-------------------------------------------------------------------------
10081       double precision function scalar2(u,v)
10082 !DIR$ INLINEALWAYS scalar2
10083       implicit none
10084       double precision u(2),v(2)
10085       double precision sc
10086       integer i
10087       scalar2=u(1)*v(1)+u(2)*v(2)
10088       return
10089       end
10090
10091 C-----------------------------------------------------------------------------
10092
10093       subroutine transpose2(a,at)
10094 !DIR$ INLINEALWAYS transpose2
10095 #ifndef OSF
10096 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10097 #endif
10098       implicit none
10099       double precision a(2,2),at(2,2)
10100       at(1,1)=a(1,1)
10101       at(1,2)=a(2,1)
10102       at(2,1)=a(1,2)
10103       at(2,2)=a(2,2)
10104       return
10105       end
10106 c--------------------------------------------------------------------------
10107       subroutine transpose(n,a,at)
10108       implicit none
10109       integer n,i,j
10110       double precision a(n,n),at(n,n)
10111       do i=1,n
10112         do j=1,n
10113           at(j,i)=a(i,j)
10114         enddo
10115       enddo
10116       return
10117       end
10118 C---------------------------------------------------------------------------
10119       subroutine prodmat3(a1,a2,kk,transp,prod)
10120 !DIR$ INLINEALWAYS prodmat3
10121 #ifndef OSF
10122 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10123 #endif
10124       implicit none
10125       integer i,j
10126       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10127       logical transp
10128 crc      double precision auxmat(2,2),prod_(2,2)
10129
10130       if (transp) then
10131 crc        call transpose2(kk(1,1),auxmat(1,1))
10132 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10133 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10134
10135            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10136      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10137            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10138      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10139            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10140      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10141            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10142      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10143
10144       else
10145 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10146 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10147
10148            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10149      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10150            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10151      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10152            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10153      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10154            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10155      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10156
10157       endif
10158 c      call transpose2(a2(1,1),a2t(1,1))
10159
10160 crc      print *,transp
10161 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10162 crc      print *,((prod(i,j),i=1,2),j=1,2)
10163
10164       return
10165       end
10166 CCC----------------------------------------------
10167       subroutine Eliptransfer(eliptran)
10168       implicit real*8 (a-h,o-z)
10169       include 'DIMENSIONS'
10170       include 'COMMON.GEO'
10171       include 'COMMON.VAR'
10172       include 'COMMON.LOCAL'
10173       include 'COMMON.CHAIN'
10174       include 'COMMON.DERIV'
10175       include 'COMMON.NAMES'
10176       include 'COMMON.INTERACT'
10177       include 'COMMON.IOUNITS'
10178       include 'COMMON.CALC'
10179       include 'COMMON.CONTROL'
10180       include 'COMMON.SPLITELE'
10181       include 'COMMON.SBRIDGE'
10182 C this is done by Adasko
10183 C      print *,"wchodze"
10184 C structure of box:
10185 C      water
10186 C--bordliptop-- buffore starts
10187 C--bufliptop--- here true lipid starts
10188 C      lipid
10189 C--buflipbot--- lipid ends buffore starts
10190 C--bordlipbot--buffore ends
10191       eliptran=0.0
10192       do i=ilip_start,ilip_end
10193 C       do i=1,1
10194         if (itype(i).eq.ntyp1) cycle
10195
10196         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10197         if (positi.le.0) positi=positi+boxzsize
10198 C        print *,i
10199 C first for peptide groups
10200 c for each residue check if it is in lipid or lipid water border area
10201        if ((positi.gt.bordlipbot)
10202      &.and.(positi.lt.bordliptop)) then
10203 C the energy transfer exist
10204         if (positi.lt.buflipbot) then
10205 C what fraction I am in
10206          fracinbuf=1.0d0-
10207      &        ((positi-bordlipbot)/lipbufthick)
10208 C lipbufthick is thickenes of lipid buffore
10209          sslip=sscalelip(fracinbuf)
10210          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10211          eliptran=eliptran+sslip*pepliptran
10212          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10213          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10214 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10215
10216 C        print *,"doing sccale for lower part"
10217 C         print *,i,sslip,fracinbuf,ssgradlip
10218         elseif (positi.gt.bufliptop) then
10219          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10220          sslip=sscalelip(fracinbuf)
10221          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10222          eliptran=eliptran+sslip*pepliptran
10223          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10224          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10225 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10226 C          print *, "doing sscalefor top part"
10227 C         print *,i,sslip,fracinbuf,ssgradlip
10228         else
10229          eliptran=eliptran+pepliptran
10230 C         print *,"I am in true lipid"
10231         endif
10232 C       else
10233 C       eliptran=elpitran+0.0 ! I am in water
10234        endif
10235        enddo
10236 C       print *, "nic nie bylo w lipidzie?"
10237 C now multiply all by the peptide group transfer factor
10238 C       eliptran=eliptran*pepliptran
10239 C now the same for side chains
10240 CV       do i=1,1
10241        do i=ilip_start,ilip_end
10242         if (itype(i).eq.ntyp1) cycle
10243         positi=(mod(c(3,i+nres),boxzsize))
10244         if (positi.le.0) positi=positi+boxzsize
10245 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10246 c for each residue check if it is in lipid or lipid water border area
10247 C       respos=mod(c(3,i+nres),boxzsize)
10248 C       print *,positi,bordlipbot,buflipbot
10249        if ((positi.gt.bordlipbot)
10250      & .and.(positi.lt.bordliptop)) then
10251 C the energy transfer exist
10252         if (positi.lt.buflipbot) then
10253          fracinbuf=1.0d0-
10254      &     ((positi-bordlipbot)/lipbufthick)
10255 C lipbufthick is thickenes of lipid buffore
10256          sslip=sscalelip(fracinbuf)
10257          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10258          eliptran=eliptran+sslip*liptranene(itype(i))
10259          gliptranx(3,i)=gliptranx(3,i)
10260      &+ssgradlip*liptranene(itype(i))
10261          gliptranc(3,i-1)= gliptranc(3,i-1)
10262      &+ssgradlip*liptranene(itype(i))
10263 C         print *,"doing sccale for lower part"
10264         elseif (positi.gt.bufliptop) then
10265          fracinbuf=1.0d0-
10266      &((bordliptop-positi)/lipbufthick)
10267          sslip=sscalelip(fracinbuf)
10268          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10269          eliptran=eliptran+sslip*liptranene(itype(i))
10270          gliptranx(3,i)=gliptranx(3,i)
10271      &+ssgradlip*liptranene(itype(i))
10272          gliptranc(3,i-1)= gliptranc(3,i-1)
10273      &+ssgradlip*liptranene(itype(i))
10274 C          print *, "doing sscalefor top part",sslip,fracinbuf
10275         else
10276          eliptran=eliptran+liptranene(itype(i))
10277 C         print *,"I am in true lipid"
10278         endif
10279         endif ! if in lipid or buffor
10280 C       else
10281 C       eliptran=elpitran+0.0 ! I am in water
10282        enddo
10283        return
10284        end
10285 C---------------------------------------------------------
10286 C AFM soubroutine for constant force
10287        subroutine AFMforce(Eafmforce)
10288        implicit real*8 (a-h,o-z)
10289       include 'DIMENSIONS'
10290       include 'COMMON.GEO'
10291       include 'COMMON.VAR'
10292       include 'COMMON.LOCAL'
10293       include 'COMMON.CHAIN'
10294       include 'COMMON.DERIV'
10295       include 'COMMON.NAMES'
10296       include 'COMMON.INTERACT'
10297       include 'COMMON.IOUNITS'
10298       include 'COMMON.CALC'
10299       include 'COMMON.CONTROL'
10300       include 'COMMON.SPLITELE'
10301       include 'COMMON.SBRIDGE'
10302       real*8 diffafm(3)
10303       dist=0.0d0
10304       Eafmforce=0.0d0
10305       do i=1,3
10306       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10307       dist=dist+diffafm(i)**2
10308       enddo
10309       dist=dsqrt(dist)
10310       Eafmforce=-forceAFMconst*(dist-distafminit)
10311       do i=1,3
10312       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10313       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10314       enddo
10315 C      print *,'AFM',Eafmforce
10316       return
10317       end
10318 C---------------------------------------------------------
10319 C AFM subroutine with pseudoconstant velocity
10320        subroutine AFMvel(Eafmforce)
10321        implicit real*8 (a-h,o-z)
10322       include 'DIMENSIONS'
10323       include 'COMMON.GEO'
10324       include 'COMMON.VAR'
10325       include 'COMMON.LOCAL'
10326       include 'COMMON.CHAIN'
10327       include 'COMMON.DERIV'
10328       include 'COMMON.NAMES'
10329       include 'COMMON.INTERACT'
10330       include 'COMMON.IOUNITS'
10331       include 'COMMON.CALC'
10332       include 'COMMON.CONTROL'
10333       include 'COMMON.SPLITELE'
10334       include 'COMMON.SBRIDGE'
10335       real*8 diffafm(3)
10336 C Only for check grad COMMENT if not used for checkgrad
10337 C      totT=3.0d0
10338 C--------------------------------------------------------
10339 C      print *,"wchodze"
10340       dist=0.0d0
10341       Eafmforce=0.0d0
10342       do i=1,3
10343       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10344       dist=dist+diffafm(i)**2
10345       enddo
10346       dist=dsqrt(dist)
10347       Eafmforce=0.5d0*forceAFMconst
10348      & *(distafminit+totTafm*velAFMconst-dist)**2
10349 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10350       do i=1,3
10351       gradafm(i,afmend-1)=-forceAFMconst*
10352      &(distafminit+totTafm*velAFMconst-dist)
10353      &*diffafm(i)/dist
10354       gradafm(i,afmbeg-1)=forceAFMconst*
10355      &(distafminit+totTafm*velAFMconst-dist)
10356      &*diffafm(i)/dist
10357       enddo
10358 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10359       return
10360       end
10361