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
 218       if (constr_homology.ge.1) then
 219         call e_modeller(ehomology_constr)
 220 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 221 c     &  'Processor',fg_rank,' CG group',kolor,
 222 c     &  ' absolute rank',MyRank
 223       else
 224         ehomology_constr=0.0d0
 225       endif
 226
 227
 228 c      write(iout,*) ehomology_constr
 229 c      print *,"Processor",myrank," computed Utor"
 230 C
 231 C 6/23/01 Calculate double-torsional energy
 232 C
 233       if (wtor_d.gt.0) then
 234        call etor_d(etors_d)
 235       else
 236        etors_d=0
 237       endif
 238 c      print *,"Processor",myrank," computed Utord"
 239 C
 240 C 21/5/07 Calculate local sicdechain correlation energy
 241 C
 242       if (wsccor.gt.0.0d0) then
 243         call eback_sc_corr(esccor)
 244       else
 245         esccor=0.0d0
 246       endif
 247 C      print *,"PRZED MULIt"
 248 c      print *,"Processor",myrank," computed Usccorr"
 249 C
 250 C 12/1/95 Multi-body terms
 251 C
 252       n_corr=0
 253       n_corr1=0
 254       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 255      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 256          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 257 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 258 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 259       else
 260          ecorr=0.0d0
 261          ecorr5=0.0d0
 262          ecorr6=0.0d0
 263          eturn6=0.0d0
 264       endif
 265       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 266          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 267 cd         write (iout,*) "multibody_hb ecorr",ecorr
 268       endif
 269 c      print *,"Processor",myrank," computed Ucorr"
 270 C
 271 C If performing constraint dynamics, call the constraint energy
 272 C  after the equilibration time
 273       if(usampl.and.totT.gt.eq_time) then
 274          call EconstrQ
 275          call Econstr_back
 276       else
 277          Uconst=0.0d0
 278          Uconst_back=0.0d0
 279       endif
 280 C 01/27/2015 added by adasko
 281 C the energy component below is energy transfer into lipid environment
 282 C based on partition function
 283 C      print *,"przed lipidami"
 284       if (wliptran.gt.0) then
 285         call Eliptransfer(eliptran)
 286       endif
 287 C      print *,"za lipidami"
 288       if (AFMlog.gt.0) then
 289         call AFMforce(Eafmforce)
 290       else if (selfguide.gt.0) then
 291         call AFMvel(Eafmforce)
 292       endif
 293 #ifdef TIMING
 294       time_enecalc=time_enecalc+MPI_Wtime()-time00
 295 #endif
 296 c      print *,"Processor",myrank," computed Uconstr"
 297 #ifdef TIMING
 298       time00=MPI_Wtime()
 299 #endif
 300 c
 301 C Sum the energies
 302 C
 303       energia(1)=evdw
 304 #ifdef SCP14
 305       energia(2)=evdw2-evdw2_14
 306       energia(18)=evdw2_14
 307 #else
 308       energia(2)=evdw2
 309       energia(18)=0.0d0
 310 #endif
 311 #ifdef SPLITELE
 312       energia(3)=ees
 313       energia(16)=evdw1
 314 #else
 315       energia(3)=ees+evdw1
 316       energia(16)=0.0d0
 317 #endif
 318       energia(4)=ecorr
 319       energia(5)=ecorr5
 320       energia(6)=ecorr6
 321       energia(7)=eel_loc
 322       energia(8)=eello_turn3
 323       energia(9)=eello_turn4
 324       energia(10)=eturn6
 325       energia(11)=ebe
 326       energia(12)=escloc
 327       energia(13)=etors
 328       energia(14)=etors_d
 329       energia(15)=ehpb
 330       energia(19)=edihcnstr
 331       energia(17)=estr
 332       energia(20)=Uconst+Uconst_back
 333       energia(21)=esccor
 334       energia(22)=eliptran
 335       energia(23)=Eafmforce
 336       energia(24)=ehomology_constr
 337 c    Here are the energies showed per procesor if the are more processors
 338 c    per molecule then we sum it up in sum_energy subroutine
 339 c      print *," Processor",myrank," calls SUM_ENERGY"
 340       call sum_energy(energia,.true.)
 341       if (dyn_ss) call dyn_set_nss
 342 c      print *," Processor",myrank," left SUM_ENERGY"
 343 #ifdef TIMING
 344       time_sumene=time_sumene+MPI_Wtime()-time00
 345 #endif
 346       return
 347       end
 348 c-------------------------------------------------------------------------------
 349       subroutine sum_energy(energia,reduce)
 350       implicit real*8 (a-h,o-z)
 351       include 'DIMENSIONS'
 352 #ifndef ISNAN
 353       external proc_proc
 354 #ifdef WINPGI
 355 cMS$ATTRIBUTES C ::  proc_proc
 356 #endif
 357 #endif
 358 #ifdef MPI
 359       include "mpif.h"
 360 #endif
 361       include 'COMMON.SETUP'
 362       include 'COMMON.IOUNITS'
 363       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 364       include 'COMMON.FFIELD'
 365       include 'COMMON.DERIV'
 366       include 'COMMON.INTERACT'
 367       include 'COMMON.SBRIDGE'
 368       include 'COMMON.CHAIN'
 369       include 'COMMON.VAR'
 370       include 'COMMON.CONTROL'
 371       include 'COMMON.TIME1'
 372       logical reduce
 373 #ifdef MPI
 374       if (nfgtasks.gt.1 .and. reduce) then
 375 #ifdef DEBUG
 376         write (iout,*) "energies before REDUCE"
 377         call enerprint(energia)
 378         call flush(iout)
 379 #endif
 380         do i=0,n_ene
 381           enebuff(i)=energia(i)
 382         enddo
 383         time00=MPI_Wtime()
 384         call MPI_Barrier(FG_COMM,IERR)
 385         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 386         time00=MPI_Wtime()
 387         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 388      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 389 #ifdef DEBUG
 390         write (iout,*) "energies after REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         time_Reduce=time_Reduce+MPI_Wtime()-time00
 395       endif
 396       if (fg_rank.eq.0) then
 397 #endif
 398       evdw=energia(1)
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428       eliptran=energia(22)
 429       Eafmforce=energia(23)
 430       ehomology_constr=energia(24)
 431 #ifdef SPLITELE
 432       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 433      & +wang*ebe+wtor*etors+wscloc*escloc
 434      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 435      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 436      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 437      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 438      & +wliptran*eliptran+Eafmforce
 439 #else
 440       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 441      & +wang*ebe+wtor*etors+wscloc*escloc
 442      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 443      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 444      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 445      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 446      & +wliptran*eliptran
 447      & +Eafmforce
 448 #endif
 449       energia(0)=etot
 450 c detecting NaNQ
 451 #ifdef ISNAN
 452 #ifdef AIX
 453       if (isnan(etot).ne.0) energia(0)=1.0d+99
 454 #else
 455       if (isnan(etot)) energia(0)=1.0d+99
 456 #endif
 457 #else
 458       i=0
 459 #ifdef WINPGI
 460       idumm=proc_proc(etot,i)
 461 #else
 462       call proc_proc(etot,i)
 463 #endif
 464       if(i.eq.1)energia(0)=1.0d+99
 465 #endif
 466 #ifdef MPI
 467       endif
 468 #endif
 469       return
 470       end
 471 c-------------------------------------------------------------------------------
 472       subroutine sum_gradient
 473       implicit real*8 (a-h,o-z)
 474       include 'DIMENSIONS'
 475 #ifndef ISNAN
 476       external proc_proc
 477 #ifdef WINPGI
 478 cMS$ATTRIBUTES C ::  proc_proc
 479 #endif
 480 #endif
 481 #ifdef MPI
 482       include 'mpif.h'
 483 #endif
 484       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 485      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 486      & ,gloc_scbuf(3,-1:maxres)
 487       include 'COMMON.SETUP'
 488       include 'COMMON.IOUNITS'
 489       include 'COMMON.FFIELD'
 490       include 'COMMON.DERIV'
 491       include 'COMMON.INTERACT'
 492       include 'COMMON.SBRIDGE'
 493       include 'COMMON.CHAIN'
 494       include 'COMMON.VAR'
 495       include 'COMMON.CONTROL'
 496       include 'COMMON.TIME1'
 497       include 'COMMON.MAXGRAD'
 498       include 'COMMON.SCCOR'
 499       include 'COMMON.MD'
 500 #ifdef TIMING
 501       time01=MPI_Wtime()
 502 #endif
 503 #ifdef DEBUG
 504       write (iout,*) "sum_gradient gvdwc, gvdwx"
 505       do i=1,nres
 506         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 507      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 508       enddo
 509       call flush(iout)
 510 #endif
 511 #ifdef MPI
 512 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 513         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 514      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 515 #endif
 516 C
 517 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 518 C            in virtual-bond-vector coordinates
 519 C
 520 #ifdef DEBUG
 521 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 522 c      do i=1,nres-1
 523 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 524 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 525 c      enddo
 526 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 527 c      do i=1,nres-1
 528 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 529 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 530 c      enddo
 531       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 534      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 535      &   g_corr5_loc(i)
 536       enddo
 537       call flush(iout)
 538 #endif
 539 #ifdef SPLITELE
 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)+wvdwpp*gvdwpp(j,i)+
 545      &                wel_loc*gel_loc_long(j,i)+
 546      &                wcorr*gradcorr_long(j,i)+
 547      &                wcorr5*gradcorr5_long(j,i)+
 548      &                wcorr6*gradcorr6_long(j,i)+
 549      &                wturn6*gcorr6_turn_long(j,i)+
 550      &                wstrain*ghpbc(j,i)
 551      &                +wliptran*gliptranc(j,i)
 552      &                +gradafm(j,i)
 553
 554         enddo
 555       enddo
 556 #else
 557       do i=0,nct
 558         do j=1,3
 559           gradbufc(j,i)=wsc*gvdwc(j,i)+
 560      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 561      &                welec*gelc_long(j,i)+
 562      &                wbond*gradb(j,i)+
 563      &                wel_loc*gel_loc_long(j,i)+
 564      &                wcorr*gradcorr_long(j,i)+
 565      &                wcorr5*gradcorr5_long(j,i)+
 566      &                wcorr6*gradcorr6_long(j,i)+
 567      &                wturn6*gcorr6_turn_long(j,i)+
 568      &                wstrain*ghpbc(j,i)
 569      &                +wliptran*gliptranc(j,i)
 570      &                +gradafm(j,i)
 571
 572         enddo
 573       enddo
 574 #endif
 575 #ifdef MPI
 576       if (nfgtasks.gt.1) then
 577       time00=MPI_Wtime()
 578 #ifdef DEBUG
 579       write (iout,*) "gradbufc before allreduce"
 580       do i=1,nres
 581         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 582       enddo
 583       call flush(iout)
 584 #endif
 585       do i=0,nres
 586         do j=1,3
 587           gradbufc_sum(j,i)=gradbufc(j,i)
 588         enddo
 589       enddo
 590 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 591 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 592 c      time_reduce=time_reduce+MPI_Wtime()-time00
 593 #ifdef DEBUG
 594 c      write (iout,*) "gradbufc_sum after allreduce"
 595 c      do i=1,nres
 596 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 597 c      enddo
 598 c      call flush(iout)
 599 #endif
 600 #ifdef TIMING
 601 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 602 #endif
 603       do i=nnt,nres
 604         do k=1,3
 605           gradbufc(k,i)=0.0d0
 606         enddo
 607       enddo
 608 #ifdef DEBUG
 609       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 610       write (iout,*) (i," jgrad_start",jgrad_start(i),
 611      &                  " jgrad_end  ",jgrad_end(i),
 612      &                  i=igrad_start,igrad_end)
 613 #endif
 614 c
 615 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 616 c do not parallelize this part.
 617 c
 618 c      do i=igrad_start,igrad_end
 619 c        do j=jgrad_start(i),jgrad_end(i)
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625       do j=1,3
 626         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 627       enddo
 628       do i=nres-2,-1,-1
 629         do j=1,3
 630           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 631         enddo
 632       enddo
 633 #ifdef DEBUG
 634       write (iout,*) "gradbufc after summing"
 635       do i=1,nres
 636         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 637       enddo
 638       call flush(iout)
 639 #endif
 640       else
 641 #endif
 642 #ifdef DEBUG
 643       write (iout,*) "gradbufc"
 644       do i=1,nres
 645         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 646       enddo
 647       call flush(iout)
 648 #endif
 649       do i=-1,nres
 650         do j=1,3
 651           gradbufc_sum(j,i)=gradbufc(j,i)
 652           gradbufc(j,i)=0.0d0
 653         enddo
 654       enddo
 655       do j=1,3
 656         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 657       enddo
 658       do i=nres-2,-1,-1
 659         do j=1,3
 660           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 661         enddo
 662       enddo
 663 c      do i=nnt,nres-1
 664 c        do k=1,3
 665 c          gradbufc(k,i)=0.0d0
 666 c        enddo
 667 c        do j=i+1,nres
 668 c          do k=1,3
 669 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 670 c          enddo
 671 c        enddo
 672 c      enddo
 673 #ifdef DEBUG
 674       write (iout,*) "gradbufc after summing"
 675       do i=1,nres
 676         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 677       enddo
 678       call flush(iout)
 679 #endif
 680 #ifdef MPI
 681       endif
 682 #endif
 683       do k=1,3
 684         gradbufc(k,nres)=0.0d0
 685       enddo
 686       do i=-1,nct
 687         do j=1,3
 688 #ifdef SPLITELE
 689           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 690      &                wel_loc*gel_loc(j,i)+
 691      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 692      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 693      &                wel_loc*gel_loc_long(j,i)+
 694      &                wcorr*gradcorr_long(j,i)+
 695      &                wcorr5*gradcorr5_long(j,i)+
 696      &                wcorr6*gradcorr6_long(j,i)+
 697      &                wturn6*gcorr6_turn_long(j,i))+
 698      &                wbond*gradb(j,i)+
 699      &                wcorr*gradcorr(j,i)+
 700      &                wturn3*gcorr3_turn(j,i)+
 701      &                wturn4*gcorr4_turn(j,i)+
 702      &                wcorr5*gradcorr5(j,i)+
 703      &                wcorr6*gradcorr6(j,i)+
 704      &                wturn6*gcorr6_turn(j,i)+
 705      &                wsccor*gsccorc(j,i)
 706      &               +wscloc*gscloc(j,i)
 707      &               +wliptran*gliptranc(j,i)
 708      &                +gradafm(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i) +
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728      &               +wliptran*gliptranc(j,i)
 729      &                +gradafm(j,i)
 730
 731 #endif
 732           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 733      &                  wbond*gradbx(j,i)+
 734      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 735      &                  wsccor*gsccorx(j,i)
 736      &                 +wscloc*gsclocx(j,i)
 737      &                 +wliptran*gliptranx(j,i)
 738         enddo
 739       enddo
 740       if (constr_homology.gt.0) then
 741         do i=1,nct
 742           do j=1,3
 743             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 744             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 745           enddo
 746         enddo
 747       endif
 748 #ifdef DEBUG
 749       write (iout,*) "gloc before adding corr"
 750       do i=1,4*nres
 751         write (iout,*) i,gloc(i,icg)
 752       enddo
 753 #endif
 754       do i=1,nres-3
 755         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 756      &   +wcorr5*g_corr5_loc(i)
 757      &   +wcorr6*g_corr6_loc(i)
 758      &   +wturn4*gel_loc_turn4(i)
 759      &   +wturn3*gel_loc_turn3(i)
 760      &   +wturn6*gel_loc_turn6(i)
 761      &   +wel_loc*gel_loc_loc(i)
 762       enddo
 763 #ifdef DEBUG
 764       write (iout,*) "gloc after adding corr"
 765       do i=1,4*nres
 766         write (iout,*) i,gloc(i,icg)
 767       enddo
 768 #endif
 769 #ifdef MPI
 770       if (nfgtasks.gt.1) then
 771         do j=1,3
 772           do i=1,nres
 773             gradbufc(j,i)=gradc(j,i,icg)
 774             gradbufx(j,i)=gradx(j,i,icg)
 775           enddo
 776         enddo
 777         do i=1,4*nres
 778           glocbuf(i)=gloc(i,icg)
 779         enddo
 780 c#define DEBUG
 781 #ifdef DEBUG
 782       write (iout,*) "gloc_sc before reduce"
 783       do i=1,nres
 784        do j=1,1
 785         write (iout,*) i,j,gloc_sc(j,i,icg)
 786        enddo
 787       enddo
 788 #endif
 789 c#undef DEBUG
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         time_reduce=time_reduce+MPI_Wtime()-time00
 806         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         time_reduce=time_reduce+MPI_Wtime()-time00
 809 c#define DEBUG
 810 #ifdef DEBUG
 811       write (iout,*) "gloc_sc after reduce"
 812       do i=1,nres
 813        do j=1,1
 814         write (iout,*) i,j,gloc_sc(j,i,icg)
 815        enddo
 816       enddo
 817 #endif
 818 c#undef DEBUG
 819 #ifdef DEBUG
 820       write (iout,*) "gloc after reduce"
 821       do i=1,4*nres
 822         write (iout,*) i,gloc(i,icg)
 823       enddo
 824 #endif
 825       endif
 826 #endif
 827       if (gnorm_check) then
 828 c
 829 c Compute the maximum elements of the gradient
 830 c
 831       gvdwc_max=0.0d0
 832       gvdwc_scp_max=0.0d0
 833       gelc_max=0.0d0
 834       gvdwpp_max=0.0d0
 835       gradb_max=0.0d0
 836       ghpbc_max=0.0d0
 837       gradcorr_max=0.0d0
 838       gel_loc_max=0.0d0
 839       gcorr3_turn_max=0.0d0
 840       gcorr4_turn_max=0.0d0
 841       gradcorr5_max=0.0d0
 842       gradcorr6_max=0.0d0
 843       gcorr6_turn_max=0.0d0
 844       gsccorc_max=0.0d0
 845       gscloc_max=0.0d0
 846       gvdwx_max=0.0d0
 847       gradx_scp_max=0.0d0
 848       ghpbx_max=0.0d0
 849       gradxorr_max=0.0d0
 850       gsccorx_max=0.0d0
 851       gsclocx_max=0.0d0
 852       do i=1,nct
 853         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 894         if (gradx_scp_norm.gt.gradx_scp_max)
 895      &    gradx_scp_max=gradx_scp_norm
 896         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 897         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 898         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 899         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 900         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 901         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 902         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 903         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 904       enddo
 905       if (gradout) then
 906 #ifdef AIX
 907         open(istat,file=statname,position="append")
 908 #else
 909         open(istat,file=statname,access="append")
 910 #endif
 911         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 912      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 913      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 914      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 915      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 916      &     gsccorx_max,gsclocx_max
 917         close(istat)
 918         if (gvdwc_max.gt.1.0d4) then
 919           write (iout,*) "gvdwc gvdwx gradb gradbx"
 920           do i=nnt,nct
 921             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 922      &        gradb(j,i),gradbx(j,i),j=1,3)
 923           enddo
 924           call pdbout(0.0d0,'cipiszcze',iout)
 925           call flush(iout)
 926         endif
 927       endif
 928       endif
 929 #ifdef DEBUG
 930       write (iout,*) "gradc gradx gloc"
 931       do i=1,nres
 932         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 933      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 934       enddo
 935 #endif
 936 #ifdef TIMING
 937       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 938 #endif
 939       return
 940       end
 941 c-------------------------------------------------------------------------------
 942       subroutine rescale_weights(t_bath)
 943       implicit real*8 (a-h,o-z)
 944       include 'DIMENSIONS'
 945       include 'COMMON.IOUNITS'
 946       include 'COMMON.FFIELD'
 947       include 'COMMON.SBRIDGE'
 948       double precision kfac /2.4d0/
 949       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 950 c      facT=temp0/t_bath
 951 c      facT=2*temp0/(t_bath+temp0)
 952       if (rescale_mode.eq.0) then
 953         facT=1.0d0
 954         facT2=1.0d0
 955         facT3=1.0d0
 956         facT4=1.0d0
 957         facT5=1.0d0
 958       else if (rescale_mode.eq.1) then
 959         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 960         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 961         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 962         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 963         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 964       else if (rescale_mode.eq.2) then
 965         x=t_bath/temp0
 966         x2=x*x
 967         x3=x2*x
 968         x4=x3*x
 969         x5=x4*x
 970         facT=licznik/dlog(dexp(x)+dexp(-x))
 971         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 972         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 973         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 974         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 975       else
 976         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 977         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 978 #ifdef MPI
 979        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 980 #endif
 981        stop 555
 982       endif
 983       welec=weights(3)*fact
 984       wcorr=weights(4)*fact3
 985       wcorr5=weights(5)*fact4
 986       wcorr6=weights(6)*fact5
 987       wel_loc=weights(7)*fact2
 988       wturn3=weights(8)*fact2
 989       wturn4=weights(9)*fact3
 990       wturn6=weights(10)*fact5
 991       wtor=weights(13)*fact
 992       wtor_d=weights(14)*fact2
 993       wsccor=weights(21)*fact
 994
 995       return
 996       end
 997 C------------------------------------------------------------------------
 998       subroutine enerprint(energia)
 999       implicit real*8 (a-h,o-z)
1000       include 'DIMENSIONS'
1001       include 'COMMON.IOUNITS'
1002       include 'COMMON.FFIELD'
1003       include 'COMMON.SBRIDGE'
1004       include 'COMMON.MD'
1005       double precision energia(0:n_ene)
1006       etot=energia(0)
1007       evdw=energia(1)
1008       evdw2=energia(2)
1009 #ifdef SCP14
1010       evdw2=energia(2)+energia(18)
1011 #else
1012       evdw2=energia(2)
1013 #endif
1014       ees=energia(3)
1015 #ifdef SPLITELE
1016       evdw1=energia(16)
1017 #endif
1018       ecorr=energia(4)
1019       ecorr5=energia(5)
1020       ecorr6=energia(6)
1021       eel_loc=energia(7)
1022       eello_turn3=energia(8)
1023       eello_turn4=energia(9)
1024       eello_turn6=energia(10)
1025       ebe=energia(11)
1026       escloc=energia(12)
1027       etors=energia(13)
1028       etors_d=energia(14)
1029       ehpb=energia(15)
1030       edihcnstr=energia(19)
1031       estr=energia(17)
1032       Uconst=energia(20)
1033       esccor=energia(21)
1034       ehomology_constr=energia(24)
1035       eliptran=energia(22)
1036       Eafmforce=energia(23)
1037 #ifdef SPLITELE
1038       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1039      &  estr,wbond,ebe,wang,
1040      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1041      &  ecorr,wcorr,
1042      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1043      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1044      &  edihcnstr,ehomology_constr, ebr*nss,
1045      &  Uconst,eliptran,wliptran,Eafmforce,etot
1046    10 format (/'Virtual-chain energies:'//
1047      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1048      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1049      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1050      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1051      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1052      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1053      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1054      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1055      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1056      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1057      & ' (SS bridges & dist. cnstr.)'/
1058      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1059      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1060      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1061      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1062      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1063      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1064      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1065      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1066      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1067      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1068      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1069      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1070      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1071      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1072      & 'ETOT=  ',1pE16.6,' (total)')
1073
1074 #else
1075       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1076      &  estr,wbond,ebe,wang,
1077      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1078      &  ecorr,wcorr,
1079      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1080      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1081      &  ehomology_constr,ebr*nss,Uconst,
1082      &  eliptran,wliptran,Eafmforc,
1083      &  etot
1084    10 format (/'Virtual-chain energies:'//
1085      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1086      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1087      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1088      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1089      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1090      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1091      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1092      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1093      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1094      & ' (SS bridges & dist. cnstr.)'/
1095      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1096      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1097      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1098      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1099      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1100      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1101      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1102      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1103      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1104      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1105      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1106      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1107      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1108      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1109      & 'ETOT=  ',1pE16.6,' (total)')
1110 #endif
1111       return
1112       end
1113 C-----------------------------------------------------------------------
1114       subroutine elj(evdw)
1115 C
1116 C This subroutine calculates the interaction energy of nonbonded side chains
1117 C assuming the LJ potential of interaction.
1118 C
1119       implicit real*8 (a-h,o-z)
1120       include 'DIMENSIONS'
1121       parameter (accur=1.0d-10)
1122       include 'COMMON.GEO'
1123       include 'COMMON.VAR'
1124       include 'COMMON.LOCAL'
1125       include 'COMMON.CHAIN'
1126       include 'COMMON.DERIV'
1127       include 'COMMON.INTERACT'
1128       include 'COMMON.TORSION'
1129       include 'COMMON.SBRIDGE'
1130       include 'COMMON.NAMES'
1131       include 'COMMON.IOUNITS'
1132       include 'COMMON.CONTACTS'
1133       dimension gg(3)
1134 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1135       evdw=0.0D0
1136       do i=iatsc_s,iatsc_e
1137         itypi=iabs(itype(i))
1138         if (itypi.eq.ntyp1) cycle
1139         itypi1=iabs(itype(i+1))
1140         xi=c(1,nres+i)
1141         yi=c(2,nres+i)
1142         zi=c(3,nres+i)
1143 C Change 12/1/95
1144         num_conti=0
1145 C
1146 C Calculate SC interaction energy.
1147 C
1148         do iint=1,nint_gr(i)
1149 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1150 cd   &                  'iend=',iend(i,iint)
1151           do j=istart(i,iint),iend(i,iint)
1152             itypj=iabs(itype(j))
1153             if (itypj.eq.ntyp1) cycle
1154             xj=c(1,nres+j)-xi
1155             yj=c(2,nres+j)-yi
1156             zj=c(3,nres+j)-zi
1157 C Change 12/1/95 to calculate four-body interactions
1158             rij=xj*xj+yj*yj+zj*zj
1159             rrij=1.0D0/rij
1160 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1161             eps0ij=eps(itypi,itypj)
1162             fac=rrij**expon2
1163 C have you changed here?
1164             e1=fac*fac*aa
1165             e2=fac*bb
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173             evdw=evdw+evdwij
1174 C
1175 C Calculate the components of the gradient in DC and X
1176 C
1177             fac=-rrij*(e1+evdwij)
1178             gg(1)=xj*fac
1179             gg(2)=yj*fac
1180             gg(3)=zj*fac
1181             do k=1,3
1182               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1183               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1184               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1185               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1186             enddo
1187 cgrad            do k=i,j-1
1188 cgrad              do l=1,3
1189 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1190 cgrad              enddo
1191 cgrad            enddo
1192 C
1193 C 12/1/95, revised on 5/20/97
1194 C
1195 C Calculate the contact function. The ith column of the array JCONT will
1196 C contain the numbers of atoms that make contacts with the atom I (of numbers
1197 C greater than I). The arrays FACONT and GACONT will contain the values of
1198 C the contact function and its derivative.
1199 C
1200 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1201 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1202 C Uncomment next line, if the correlation interactions are contact function only
1203             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1204               rij=dsqrt(rij)
1205               sigij=sigma(itypi,itypj)
1206               r0ij=rs0(itypi,itypj)
1207 C
1208 C Check whether the SC's are not too far to make a contact.
1209 C
1210               rcut=1.5d0*r0ij
1211               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1212 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1213 C
1214               if (fcont.gt.0.0D0) then
1215 C If the SC-SC distance if close to sigma, apply spline.
1216 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1217 cAdam &             fcont1,fprimcont1)
1218 cAdam           fcont1=1.0d0-fcont1
1219 cAdam           if (fcont1.gt.0.0d0) then
1220 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1221 cAdam             fcont=fcont*fcont1
1222 cAdam           endif
1223 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1224 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1225 cga             do k=1,3
1226 cga               gg(k)=gg(k)*eps0ij
1227 cga             enddo
1228 cga             eps0ij=-evdwij*eps0ij
1229 C Uncomment for AL's type of SC correlation interactions.
1230 cadam           eps0ij=-evdwij
1231                 num_conti=num_conti+1
1232                 jcont(num_conti,i)=j
1233                 facont(num_conti,i)=fcont*eps0ij
1234                 fprimcont=eps0ij*fprimcont/rij
1235                 fcont=expon*fcont
1236 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1237 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1238 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1239 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1240                 gacont(1,num_conti,i)=-fprimcont*xj
1241                 gacont(2,num_conti,i)=-fprimcont*yj
1242                 gacont(3,num_conti,i)=-fprimcont*zj
1243 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1244 cd              write (iout,'(2i3,3f10.5)')
1245 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1246               endif
1247             endif
1248           enddo      ! j
1249         enddo        ! iint
1250 C Change 12/1/95
1251         num_cont(i)=num_conti
1252       enddo          ! i
1253       do i=1,nct
1254         do j=1,3
1255           gvdwc(j,i)=expon*gvdwc(j,i)
1256           gvdwx(j,i)=expon*gvdwx(j,i)
1257         enddo
1258       enddo
1259 C******************************************************************************
1260 C
1261 C                              N O T E !!!
1262 C
1263 C To save time, the factor of EXPON has been extracted from ALL components
1264 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1265 C use!
1266 C
1267 C******************************************************************************
1268       return
1269       end
1270 C-----------------------------------------------------------------------------
1271       subroutine eljk(evdw)
1272 C
1273 C This subroutine calculates the interaction energy of nonbonded side chains
1274 C assuming the LJK potential of interaction.
1275 C
1276       implicit real*8 (a-h,o-z)
1277       include 'DIMENSIONS'
1278       include 'COMMON.GEO'
1279       include 'COMMON.VAR'
1280       include 'COMMON.LOCAL'
1281       include 'COMMON.CHAIN'
1282       include 'COMMON.DERIV'
1283       include 'COMMON.INTERACT'
1284       include 'COMMON.IOUNITS'
1285       include 'COMMON.NAMES'
1286       dimension gg(3)
1287       logical scheck
1288 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1289       evdw=0.0D0
1290       do i=iatsc_s,iatsc_e
1291         itypi=iabs(itype(i))
1292         if (itypi.eq.ntyp1) cycle
1293         itypi1=iabs(itype(i+1))
1294         xi=c(1,nres+i)
1295         yi=c(2,nres+i)
1296         zi=c(3,nres+i)
1297 C
1298 C Calculate SC interaction energy.
1299 C
1300         do iint=1,nint_gr(i)
1301           do j=istart(i,iint),iend(i,iint)
1302             itypj=iabs(itype(j))
1303             if (itypj.eq.ntyp1) cycle
1304             xj=c(1,nres+j)-xi
1305             yj=c(2,nres+j)-yi
1306             zj=c(3,nres+j)-zi
1307             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1308             fac_augm=rrij**expon
1309             e_augm=augm(itypi,itypj)*fac_augm
1310             r_inv_ij=dsqrt(rrij)
1311             rij=1.0D0/r_inv_ij
1312             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1313             fac=r_shift_inv**expon
1314 C have you changed here?
1315             e1=fac*fac*aa
1316             e2=fac*bb
1317             evdwij=e_augm+e1+e2
1318 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1319 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1320 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1321 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1322 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1323 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1324 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1325             evdw=evdw+evdwij
1326 C
1327 C Calculate the components of the gradient in DC and X
1328 C
1329             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1330             gg(1)=xj*fac
1331             gg(2)=yj*fac
1332             gg(3)=zj*fac
1333             do k=1,3
1334               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1335               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1336               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1337               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1338             enddo
1339 cgrad            do k=i,j-1
1340 cgrad              do l=1,3
1341 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1342 cgrad              enddo
1343 cgrad            enddo
1344           enddo      ! j
1345         enddo        ! iint
1346       enddo          ! i
1347       do i=1,nct
1348         do j=1,3
1349           gvdwc(j,i)=expon*gvdwc(j,i)
1350           gvdwx(j,i)=expon*gvdwx(j,i)
1351         enddo
1352       enddo
1353       return
1354       end
1355 C-----------------------------------------------------------------------------
1356       subroutine ebp(evdw)
1357 C
1358 C This subroutine calculates the interaction energy of nonbonded side chains
1359 C assuming the Berne-Pechukas potential of interaction.
1360 C
1361       implicit real*8 (a-h,o-z)
1362       include 'DIMENSIONS'
1363       include 'COMMON.GEO'
1364       include 'COMMON.VAR'
1365       include 'COMMON.LOCAL'
1366       include 'COMMON.CHAIN'
1367       include 'COMMON.DERIV'
1368       include 'COMMON.NAMES'
1369       include 'COMMON.INTERACT'
1370       include 'COMMON.IOUNITS'
1371       include 'COMMON.CALC'
1372       common /srutu/ icall
1373 c     double precision rrsave(maxdim)
1374       logical lprn
1375       evdw=0.0D0
1376 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1377       evdw=0.0D0
1378 c     if (icall.eq.0) then
1379 c       lprn=.true.
1380 c     else
1381         lprn=.false.
1382 c     endif
1383       ind=0
1384       do i=iatsc_s,iatsc_e
1385         itypi=iabs(itype(i))
1386         if (itypi.eq.ntyp1) cycle
1387         itypi1=iabs(itype(i+1))
1388         xi=c(1,nres+i)
1389         yi=c(2,nres+i)
1390         zi=c(3,nres+i)
1391         dxi=dc_norm(1,nres+i)
1392         dyi=dc_norm(2,nres+i)
1393         dzi=dc_norm(3,nres+i)
1394 c        dsci_inv=dsc_inv(itypi)
1395         dsci_inv=vbld_inv(i+nres)
1396 C
1397 C Calculate SC interaction energy.
1398 C
1399         do iint=1,nint_gr(i)
1400           do j=istart(i,iint),iend(i,iint)
1401             ind=ind+1
1402             itypj=iabs(itype(j))
1403             if (itypj.eq.ntyp1) cycle
1404 c            dscj_inv=dsc_inv(itypj)
1405             dscj_inv=vbld_inv(j+nres)
1406             chi1=chi(itypi,itypj)
1407             chi2=chi(itypj,itypi)
1408             chi12=chi1*chi2
1409             chip1=chip(itypi)
1410             chip2=chip(itypj)
1411             chip12=chip1*chip2
1412             alf1=alp(itypi)
1413             alf2=alp(itypj)
1414             alf12=0.5D0*(alf1+alf2)
1415 C For diagnostics only!!!
1416 c           chi1=0.0D0
1417 c           chi2=0.0D0
1418 c           chi12=0.0D0
1419 c           chip1=0.0D0
1420 c           chip2=0.0D0
1421 c           chip12=0.0D0
1422 c           alf1=0.0D0
1423 c           alf2=0.0D0
1424 c           alf12=0.0D0
1425             xj=c(1,nres+j)-xi
1426             yj=c(2,nres+j)-yi
1427             zj=c(3,nres+j)-zi
1428             dxj=dc_norm(1,nres+j)
1429             dyj=dc_norm(2,nres+j)
1430             dzj=dc_norm(3,nres+j)
1431             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1432 cd          if (icall.eq.0) then
1433 cd            rrsave(ind)=rrij
1434 cd          else
1435 cd            rrij=rrsave(ind)
1436 cd          endif
1437             rij=dsqrt(rrij)
1438 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1439             call sc_angular
1440 C Calculate whole angle-dependent part of epsilon and contributions
1441 C to its derivatives
1442 C have you changed here?
1443             fac=(rrij*sigsq)**expon2
1444             e1=fac*fac*aa
1445             e2=fac*bb
1446             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1447             eps2der=evdwij*eps3rt
1448             eps3der=evdwij*eps2rt
1449             evdwij=evdwij*eps2rt*eps3rt
1450             evdw=evdw+evdwij
1451             if (lprn) then
1452             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1453             epsi=bb**2/aa
1454 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1455 cd     &        restyp(itypi),i,restyp(itypj),j,
1456 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1457 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1458 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1459 cd     &        evdwij
1460             endif
1461 C Calculate gradient components.
1462             e1=e1*eps1*eps2rt**2*eps3rt**2
1463             fac=-expon*(e1+evdwij)
1464             sigder=fac/sigsq
1465             fac=rrij*fac
1466 C Calculate radial part of the gradient
1467             gg(1)=xj*fac
1468             gg(2)=yj*fac
1469             gg(3)=zj*fac
1470 C Calculate the angular part of the gradient and sum add the contributions
1471 C to the appropriate components of the Cartesian gradient.
1472             call sc_grad
1473           enddo      ! j
1474         enddo        ! iint
1475       enddo          ! i
1476 c     stop
1477       return
1478       end
1479 C-----------------------------------------------------------------------------
1480       subroutine egb(evdw)
1481 C
1482 C This subroutine calculates the interaction energy of nonbonded side chains
1483 C assuming the Gay-Berne potential of interaction.
1484 C
1485       implicit real*8 (a-h,o-z)
1486       include 'DIMENSIONS'
1487       include 'COMMON.GEO'
1488       include 'COMMON.VAR'
1489       include 'COMMON.LOCAL'
1490       include 'COMMON.CHAIN'
1491       include 'COMMON.DERIV'
1492       include 'COMMON.NAMES'
1493       include 'COMMON.INTERACT'
1494       include 'COMMON.IOUNITS'
1495       include 'COMMON.CALC'
1496       include 'COMMON.CONTROL'
1497       include 'COMMON.SPLITELE'
1498       include 'COMMON.SBRIDGE'
1499       logical lprn
1500       integer xshift,yshift,zshift
1501       evdw=0.0D0
1502 ccccc      energy_dec=.false.
1503 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1504       evdw=0.0D0
1505       lprn=.false.
1506 c     if (icall.eq.0) lprn=.false.
1507       ind=0
1508 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1509 C we have the original box)
1510 C      do xshift=-1,1
1511 C      do yshift=-1,1
1512 C      do zshift=-1,1
1513       do i=iatsc_s,iatsc_e
1514         itypi=iabs(itype(i))
1515         if (itypi.eq.ntyp1) cycle
1516         itypi1=iabs(itype(i+1))
1517         xi=c(1,nres+i)
1518         yi=c(2,nres+i)
1519         zi=c(3,nres+i)
1520 C Return atom into box, boxxsize is size of box in x dimension
1521 c  134   continue
1522 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1523 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1524 C Condition for being inside the proper box
1525 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1526 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1527 c        go to 134
1528 c        endif
1529 c  135   continue
1530 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1531 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1532 C Condition for being inside the proper box
1533 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1534 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1535 c        go to 135
1536 c        endif
1537 c  136   continue
1538 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1539 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1540 C Condition for being inside the proper box
1541 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1542 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1543 c        go to 136
1544 c        endif
1545           xi=mod(xi,boxxsize)
1546           if (xi.lt.0) xi=xi+boxxsize
1547           yi=mod(yi,boxysize)
1548           if (yi.lt.0) yi=yi+boxysize
1549           zi=mod(zi,boxzsize)
1550           if (zi.lt.0) zi=zi+boxzsize
1551 C define scaling factor for lipids
1552
1553 C        if (positi.le.0) positi=positi+boxzsize
1554 C        print *,i
1555 C first for peptide groups
1556 c for each residue check if it is in lipid or lipid water border area
1557        if ((zi.gt.bordlipbot)
1558      &.and.(zi.lt.bordliptop)) then
1559 C the energy transfer exist
1560         if (zi.lt.buflipbot) then
1561 C what fraction I am in
1562          fracinbuf=1.0d0-
1563      &        ((zi-bordlipbot)/lipbufthick)
1564 C lipbufthick is thickenes of lipid buffore
1565          sslipi=sscalelip(fracinbuf)
1566          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1567         elseif (zi.gt.bufliptop) then
1568          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1569          sslipi=sscalelip(fracinbuf)
1570          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1571         else
1572          sslipi=1.0d0
1573          ssgradlipi=0.0
1574         endif
1575        else
1576          sslipi=0.0d0
1577          ssgradlipi=0.0
1578        endif
1579
1580 C          xi=xi+xshift*boxxsize
1581 C          yi=yi+yshift*boxysize
1582 C          zi=zi+zshift*boxzsize
1583
1584         dxi=dc_norm(1,nres+i)
1585         dyi=dc_norm(2,nres+i)
1586         dzi=dc_norm(3,nres+i)
1587 c        dsci_inv=dsc_inv(itypi)
1588         dsci_inv=vbld_inv(i+nres)
1589 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1590 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1591 C
1592 C Calculate SC interaction energy.
1593 C
1594         do iint=1,nint_gr(i)
1595           do j=istart(i,iint),iend(i,iint)
1596             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1597               call dyn_ssbond_ene(i,j,evdwij)
1598               evdw=evdw+evdwij
1599               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1600      &                        'evdw',i,j,evdwij,' ss'
1601             ELSE
1602             ind=ind+1
1603             itypj=iabs(itype(j))
1604             if (itypj.eq.ntyp1) cycle
1605 c            dscj_inv=dsc_inv(itypj)
1606             dscj_inv=vbld_inv(j+nres)
1607 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1608 c     &       1.0d0/vbld(j+nres)
1609 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1610             sig0ij=sigma(itypi,itypj)
1611             chi1=chi(itypi,itypj)
1612             chi2=chi(itypj,itypi)
1613             chi12=chi1*chi2
1614             chip1=chip(itypi)
1615             chip2=chip(itypj)
1616             chip12=chip1*chip2
1617             alf1=alp(itypi)
1618             alf2=alp(itypj)
1619             alf12=0.5D0*(alf1+alf2)
1620 C For diagnostics only!!!
1621 c           chi1=0.0D0
1622 c           chi2=0.0D0
1623 c           chi12=0.0D0
1624 c           chip1=0.0D0
1625 c           chip2=0.0D0
1626 c           chip12=0.0D0
1627 c           alf1=0.0D0
1628 c           alf2=0.0D0
1629 c           alf12=0.0D0
1630             xj=c(1,nres+j)
1631             yj=c(2,nres+j)
1632             zj=c(3,nres+j)
1633 C Return atom J into box the original box
1634 c  137   continue
1635 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1636 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1637 C Condition for being inside the proper box
1638 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1639 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1640 c        go to 137
1641 c        endif
1642 c  138   continue
1643 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1644 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1645 C Condition for being inside the proper box
1646 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1647 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1648 c        go to 138
1649 c        endif
1650 c  139   continue
1651 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1652 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1653 C Condition for being inside the proper box
1654 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1655 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1656 c        go to 139
1657 c        endif
1658           xj=mod(xj,boxxsize)
1659           if (xj.lt.0) xj=xj+boxxsize
1660           yj=mod(yj,boxysize)
1661           if (yj.lt.0) yj=yj+boxysize
1662           zj=mod(zj,boxzsize)
1663           if (zj.lt.0) zj=zj+boxzsize
1664        if ((zj.gt.bordlipbot)
1665      &.and.(zj.lt.bordliptop)) then
1666 C the energy transfer exist
1667         if (zj.lt.buflipbot) then
1668 C what fraction I am in
1669          fracinbuf=1.0d0-
1670      &        ((zj-bordlipbot)/lipbufthick)
1671 C lipbufthick is thickenes of lipid buffore
1672          sslipj=sscalelip(fracinbuf)
1673          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1674         elseif (zj.gt.bufliptop) then
1675          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1676          sslipj=sscalelip(fracinbuf)
1677          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1678         else
1679          sslipj=1.0d0
1680          ssgradlipj=0.0
1681         endif
1682        else
1683          sslipj=0.0d0
1684          ssgradlipj=0.0
1685        endif
1686       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1687      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1688       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1689      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1690 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1691 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1692 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1693 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1694       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1695       xj_safe=xj
1696       yj_safe=yj
1697       zj_safe=zj
1698       subchap=0
1699       do xshift=-1,1
1700       do yshift=-1,1
1701       do zshift=-1,1
1702           xj=xj_safe+xshift*boxxsize
1703           yj=yj_safe+yshift*boxysize
1704           zj=zj_safe+zshift*boxzsize
1705           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1706           if(dist_temp.lt.dist_init) then
1707             dist_init=dist_temp
1708             xj_temp=xj
1709             yj_temp=yj
1710             zj_temp=zj
1711             subchap=1
1712           endif
1713        enddo
1714        enddo
1715        enddo
1716        if (subchap.eq.1) then
1717           xj=xj_temp-xi
1718           yj=yj_temp-yi
1719           zj=zj_temp-zi
1720        else
1721           xj=xj_safe-xi
1722           yj=yj_safe-yi
1723           zj=zj_safe-zi
1724        endif
1725             dxj=dc_norm(1,nres+j)
1726             dyj=dc_norm(2,nres+j)
1727             dzj=dc_norm(3,nres+j)
1728 C            xj=xj-xi
1729 C            yj=yj-yi
1730 C            zj=zj-zi
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1737             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1738
1739 c            write (iout,'(a7,4f8.3)')
1740 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1741             if (sss.gt.0.0d0) then
1742 C Calculate angle-dependent terms of energy and contributions to their
1743 C derivatives.
1744             call sc_angular
1745             sigsq=1.0D0/sigsq
1746             sig=sig0ij*dsqrt(sigsq)
1747             rij_shift=1.0D0/rij-sig+sig0ij
1748 c for diagnostics; uncomment
1749 c            rij_shift=1.2*sig0ij
1750 C I hate to put IF's in the loops, but here don't have another choice!!!!
1751             if (rij_shift.le.0.0D0) then
1752               evdw=1.0D20
1753 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1754 cd     &        restyp(itypi),i,restyp(itypj),j,
1755 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1756               return
1757             endif
1758             sigder=-sig*sigsq
1759 c---------------------------------------------------------------
1760             rij_shift=1.0D0/rij_shift
1761             fac=rij_shift**expon
1762 C here to start with
1763 C            if (c(i,3).gt.
1764             faclip=fac
1765             e1=fac*fac*aa
1766             e2=fac*bb
1767             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1768             eps2der=evdwij*eps3rt
1769             eps3der=evdwij*eps2rt
1770 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1771 C     &((sslipi+sslipj)/2.0d0+
1772 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1773 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1774 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1775             evdwij=evdwij*eps2rt*eps3rt
1776             evdw=evdw+evdwij*sss
1777             if (lprn) then
1778             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1779             epsi=bb**2/aa
1780             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1781      &        restyp(itypi),i,restyp(itypj),j,
1782      &        epsi,sigm,chi1,chi2,chip1,chip2,
1783      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1784      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1785      &        evdwij
1786             endif
1787
1788             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1789      &                        'evdw',i,j,evdwij
1790
1791 C Calculate gradient components.
1792             e1=e1*eps1*eps2rt**2*eps3rt**2
1793             fac=-expon*(e1+evdwij)*rij_shift
1794             sigder=fac*sigder
1795             fac=rij*fac
1796 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1797 c     &      evdwij,fac,sigma(itypi,itypj),expon
1798             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1799 c            fac=0.0d0
1800 C Calculate the radial part of the gradient
1801             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1802      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1803      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1804      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1805             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1806             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1807 C            gg_lipi(3)=0.0d0
1808 C            gg_lipj(3)=0.0d0
1809             gg(1)=xj*fac
1810             gg(2)=yj*fac
1811             gg(3)=zj*fac
1812 C Calculate angular part of the gradient.
1813             call sc_grad
1814             endif
1815             ENDIF    ! dyn_ss
1816           enddo      ! j
1817         enddo        ! iint
1818       enddo          ! i
1819 C      enddo          ! zshift
1820 C      enddo          ! yshift
1821 C      enddo          ! xshift
1822 c      write (iout,*) "Number of loop steps in EGB:",ind
1823 cccc      energy_dec=.false.
1824       return
1825       end
1826 C-----------------------------------------------------------------------------
1827       subroutine egbv(evdw)
1828 C
1829 C This subroutine calculates the interaction energy of nonbonded side chains
1830 C assuming the Gay-Berne-Vorobjev potential of interaction.
1831 C
1832       implicit real*8 (a-h,o-z)
1833       include 'DIMENSIONS'
1834       include 'COMMON.GEO'
1835       include 'COMMON.VAR'
1836       include 'COMMON.LOCAL'
1837       include 'COMMON.CHAIN'
1838       include 'COMMON.DERIV'
1839       include 'COMMON.NAMES'
1840       include 'COMMON.INTERACT'
1841       include 'COMMON.IOUNITS'
1842       include 'COMMON.CALC'
1843       common /srutu/ icall
1844       logical lprn
1845       evdw=0.0D0
1846 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1847       evdw=0.0D0
1848       lprn=.false.
1849 c     if (icall.eq.0) lprn=.true.
1850       ind=0
1851       do i=iatsc_s,iatsc_e
1852         itypi=iabs(itype(i))
1853         if (itypi.eq.ntyp1) cycle
1854         itypi1=iabs(itype(i+1))
1855         xi=c(1,nres+i)
1856         yi=c(2,nres+i)
1857         zi=c(3,nres+i)
1858           xi=mod(xi,boxxsize)
1859           if (xi.lt.0) xi=xi+boxxsize
1860           yi=mod(yi,boxysize)
1861           if (yi.lt.0) yi=yi+boxysize
1862           zi=mod(zi,boxzsize)
1863           if (zi.lt.0) zi=zi+boxzsize
1864 C define scaling factor for lipids
1865
1866 C        if (positi.le.0) positi=positi+boxzsize
1867 C        print *,i
1868 C first for peptide groups
1869 c for each residue check if it is in lipid or lipid water border area
1870        if ((zi.gt.bordlipbot)
1871      &.and.(zi.lt.bordliptop)) then
1872 C the energy transfer exist
1873         if (zi.lt.buflipbot) then
1874 C what fraction I am in
1875          fracinbuf=1.0d0-
1876      &        ((zi-bordlipbot)/lipbufthick)
1877 C lipbufthick is thickenes of lipid buffore
1878          sslipi=sscalelip(fracinbuf)
1879          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1880         elseif (zi.gt.bufliptop) then
1881          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1882          sslipi=sscalelip(fracinbuf)
1883          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1884         else
1885          sslipi=1.0d0
1886          ssgradlipi=0.0
1887         endif
1888        else
1889          sslipi=0.0d0
1890          ssgradlipi=0.0
1891        endif
1892
1893         dxi=dc_norm(1,nres+i)
1894         dyi=dc_norm(2,nres+i)
1895         dzi=dc_norm(3,nres+i)
1896 c        dsci_inv=dsc_inv(itypi)
1897         dsci_inv=vbld_inv(i+nres)
1898 C
1899 C Calculate SC interaction energy.
1900 C
1901         do iint=1,nint_gr(i)
1902           do j=istart(i,iint),iend(i,iint)
1903             ind=ind+1
1904             itypj=iabs(itype(j))
1905             if (itypj.eq.ntyp1) cycle
1906 c            dscj_inv=dsc_inv(itypj)
1907             dscj_inv=vbld_inv(j+nres)
1908             sig0ij=sigma(itypi,itypj)
1909             r0ij=r0(itypi,itypj)
1910             chi1=chi(itypi,itypj)
1911             chi2=chi(itypj,itypi)
1912             chi12=chi1*chi2
1913             chip1=chip(itypi)
1914             chip2=chip(itypj)
1915             chip12=chip1*chip2
1916             alf1=alp(itypi)
1917             alf2=alp(itypj)
1918             alf12=0.5D0*(alf1+alf2)
1919 C For diagnostics only!!!
1920 c           chi1=0.0D0
1921 c           chi2=0.0D0
1922 c           chi12=0.0D0
1923 c           chip1=0.0D0
1924 c           chip2=0.0D0
1925 c           chip12=0.0D0
1926 c           alf1=0.0D0
1927 c           alf2=0.0D0
1928 c           alf12=0.0D0
1929 C            xj=c(1,nres+j)-xi
1930 C            yj=c(2,nres+j)-yi
1931 C            zj=c(3,nres+j)-zi
1932           xj=mod(xj,boxxsize)
1933           if (xj.lt.0) xj=xj+boxxsize
1934           yj=mod(yj,boxysize)
1935           if (yj.lt.0) yj=yj+boxysize
1936           zj=mod(zj,boxzsize)
1937           if (zj.lt.0) zj=zj+boxzsize
1938        if ((zj.gt.bordlipbot)
1939      &.and.(zj.lt.bordliptop)) then
1940 C the energy transfer exist
1941         if (zj.lt.buflipbot) then
1942 C what fraction I am in
1943          fracinbuf=1.0d0-
1944      &        ((zj-bordlipbot)/lipbufthick)
1945 C lipbufthick is thickenes of lipid buffore
1946          sslipj=sscalelip(fracinbuf)
1947          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1948         elseif (zj.gt.bufliptop) then
1949          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1950          sslipj=sscalelip(fracinbuf)
1951          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1952         else
1953          sslipj=1.0d0
1954          ssgradlipj=0.0
1955         endif
1956        else
1957          sslipj=0.0d0
1958          ssgradlipj=0.0
1959        endif
1960       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1961      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1962       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1963      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1964 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1965 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1966       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1967       xj_safe=xj
1968       yj_safe=yj
1969       zj_safe=zj
1970       subchap=0
1971       do xshift=-1,1
1972       do yshift=-1,1
1973       do zshift=-1,1
1974           xj=xj_safe+xshift*boxxsize
1975           yj=yj_safe+yshift*boxysize
1976           zj=zj_safe+zshift*boxzsize
1977           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1978           if(dist_temp.lt.dist_init) then
1979             dist_init=dist_temp
1980             xj_temp=xj
1981             yj_temp=yj
1982             zj_temp=zj
1983             subchap=1
1984           endif
1985        enddo
1986        enddo
1987        enddo
1988        if (subchap.eq.1) then
1989           xj=xj_temp-xi
1990           yj=yj_temp-yi
1991           zj=zj_temp-zi
1992        else
1993           xj=xj_safe-xi
1994           yj=yj_safe-yi
1995           zj=zj_safe-zi
1996        endif
1997             dxj=dc_norm(1,nres+j)
1998             dyj=dc_norm(2,nres+j)
1999             dzj=dc_norm(3,nres+j)
2000             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2001             rij=dsqrt(rrij)
2002 C Calculate angle-dependent terms of energy and contributions to their
2003 C derivatives.
2004             call sc_angular
2005             sigsq=1.0D0/sigsq
2006             sig=sig0ij*dsqrt(sigsq)
2007             rij_shift=1.0D0/rij-sig+r0ij
2008 C I hate to put IF's in the loops, but here don't have another choice!!!!
2009             if (rij_shift.le.0.0D0) then
2010               evdw=1.0D20
2011               return
2012             endif
2013             sigder=-sig*sigsq
2014 c---------------------------------------------------------------
2015             rij_shift=1.0D0/rij_shift
2016             fac=rij_shift**expon
2017             e1=fac*fac*aa
2018             e2=fac*bb
2019             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020             eps2der=evdwij*eps3rt
2021             eps3der=evdwij*eps2rt
2022             fac_augm=rrij**expon
2023             e_augm=augm(itypi,itypj)*fac_augm
2024             evdwij=evdwij*eps2rt*eps3rt
2025             evdw=evdw+evdwij+e_augm
2026             if (lprn) then
2027             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2028             epsi=bb**2/aa
2029             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2030      &        restyp(itypi),i,restyp(itypj),j,
2031      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2032      &        chi1,chi2,chip1,chip2,
2033      &        eps1,eps2rt**2,eps3rt**2,
2034      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2035      &        evdwij+e_augm
2036             endif
2037 C Calculate gradient components.
2038             e1=e1*eps1*eps2rt**2*eps3rt**2
2039             fac=-expon*(e1+evdwij)*rij_shift
2040             sigder=fac*sigder
2041             fac=rij*fac-2*expon*rrij*e_augm
2042             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2043 C Calculate the radial part of the gradient
2044             gg(1)=xj*fac
2045             gg(2)=yj*fac
2046             gg(3)=zj*fac
2047 C Calculate angular part of the gradient.
2048             call sc_grad
2049           enddo      ! j
2050         enddo        ! iint
2051       enddo          ! i
2052       end
2053 C-----------------------------------------------------------------------------
2054       subroutine sc_angular
2055 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2056 C om12. Called by ebp, egb, and egbv.
2057       implicit none
2058       include 'COMMON.CALC'
2059       include 'COMMON.IOUNITS'
2060       erij(1)=xj*rij
2061       erij(2)=yj*rij
2062       erij(3)=zj*rij
2063       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2064       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2065       om12=dxi*dxj+dyi*dyj+dzi*dzj
2066       chiom12=chi12*om12
2067 C Calculate eps1(om12) and its derivative in om12
2068       faceps1=1.0D0-om12*chiom12
2069       faceps1_inv=1.0D0/faceps1
2070       eps1=dsqrt(faceps1_inv)
2071 C Following variable is eps1*deps1/dom12
2072       eps1_om12=faceps1_inv*chiom12
2073 c diagnostics only
2074 c      faceps1_inv=om12
2075 c      eps1=om12
2076 c      eps1_om12=1.0d0
2077 c      write (iout,*) "om12",om12," eps1",eps1
2078 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2079 C and om12.
2080       om1om2=om1*om2
2081       chiom1=chi1*om1
2082       chiom2=chi2*om2
2083       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2084       sigsq=1.0D0-facsig*faceps1_inv
2085       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2086       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2087       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2088 c diagnostics only
2089 c      sigsq=1.0d0
2090 c      sigsq_om1=0.0d0
2091 c      sigsq_om2=0.0d0
2092 c      sigsq_om12=0.0d0
2093 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2094 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2095 c     &    " eps1",eps1
2096 C Calculate eps2 and its derivatives in om1, om2, and om12.
2097       chipom1=chip1*om1
2098       chipom2=chip2*om2
2099       chipom12=chip12*om12
2100       facp=1.0D0-om12*chipom12
2101       facp_inv=1.0D0/facp
2102       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2103 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2104 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2105 C Following variable is the square root of eps2
2106       eps2rt=1.0D0-facp1*facp_inv
2107 C Following three variables are the derivatives of the square root of eps
2108 C in om1, om2, and om12.
2109       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2110       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2111       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2112 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2113       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2114 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2115 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2116 c     &  " eps2rt_om12",eps2rt_om12
2117 C Calculate whole angle-dependent part of epsilon and contributions
2118 C to its derivatives
2119       return
2120       end
2121 C----------------------------------------------------------------------------
2122       subroutine sc_grad
2123       implicit real*8 (a-h,o-z)
2124       include 'DIMENSIONS'
2125       include 'COMMON.CHAIN'
2126       include 'COMMON.DERIV'
2127       include 'COMMON.CALC'
2128       include 'COMMON.IOUNITS'
2129       double precision dcosom1(3),dcosom2(3)
2130 cc      print *,'sss=',sss
2131       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2132       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2133       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2134      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2135 c diagnostics only
2136 c      eom1=0.0d0
2137 c      eom2=0.0d0
2138 c      eom12=evdwij*eps1_om12
2139 c end diagnostics
2140 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2141 c     &  " sigder",sigder
2142 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2143 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2144       do k=1,3
2145         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2146         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2147       enddo
2148       do k=1,3
2149         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2150       enddo
2151 c      write (iout,*) "gg",(gg(k),k=1,3)
2152       do k=1,3
2153         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2154      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2155      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2156         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2157      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2158      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2159 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2160 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2161 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2162 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2163       enddo
2164 C
2165 C Calculate the components of the gradient in DC and X
2166 C
2167 cgrad      do k=i,j-1
2168 cgrad        do l=1,3
2169 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2170 cgrad        enddo
2171 cgrad      enddo
2172       do l=1,3
2173         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2174         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2175       enddo
2176       return
2177       end
2178 C-----------------------------------------------------------------------
2179       subroutine e_softsphere(evdw)
2180 C
2181 C This subroutine calculates the interaction energy of nonbonded side chains
2182 C assuming the LJ potential of interaction.
2183 C
2184       implicit real*8 (a-h,o-z)
2185       include 'DIMENSIONS'
2186       parameter (accur=1.0d-10)
2187       include 'COMMON.GEO'
2188       include 'COMMON.VAR'
2189       include 'COMMON.LOCAL'
2190       include 'COMMON.CHAIN'
2191       include 'COMMON.DERIV'
2192       include 'COMMON.INTERACT'
2193       include 'COMMON.TORSION'
2194       include 'COMMON.SBRIDGE'
2195       include 'COMMON.NAMES'
2196       include 'COMMON.IOUNITS'
2197       include 'COMMON.CONTACTS'
2198       dimension gg(3)
2199 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2200       evdw=0.0D0
2201       do i=iatsc_s,iatsc_e
2202         itypi=iabs(itype(i))
2203         if (itypi.eq.ntyp1) cycle
2204         itypi1=iabs(itype(i+1))
2205         xi=c(1,nres+i)
2206         yi=c(2,nres+i)
2207         zi=c(3,nres+i)
2208 C
2209 C Calculate SC interaction energy.
2210 C
2211         do iint=1,nint_gr(i)
2212 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2213 cd   &                  'iend=',iend(i,iint)
2214           do j=istart(i,iint),iend(i,iint)
2215             itypj=iabs(itype(j))
2216             if (itypj.eq.ntyp1) cycle
2217             xj=c(1,nres+j)-xi
2218             yj=c(2,nres+j)-yi
2219             zj=c(3,nres+j)-zi
2220             rij=xj*xj+yj*yj+zj*zj
2221 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2222             r0ij=r0(itypi,itypj)
2223             r0ijsq=r0ij*r0ij
2224 c            print *,i,j,r0ij,dsqrt(rij)
2225             if (rij.lt.r0ijsq) then
2226               evdwij=0.25d0*(rij-r0ijsq)**2
2227               fac=rij-r0ijsq
2228             else
2229               evdwij=0.0d0
2230               fac=0.0d0
2231             endif
2232             evdw=evdw+evdwij
2233 C
2234 C Calculate the components of the gradient in DC and X
2235 C
2236             gg(1)=xj*fac
2237             gg(2)=yj*fac
2238             gg(3)=zj*fac
2239             do k=1,3
2240               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2241               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2242               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2243               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2244             enddo
2245 cgrad            do k=i,j-1
2246 cgrad              do l=1,3
2247 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2248 cgrad              enddo
2249 cgrad            enddo
2250           enddo ! j
2251         enddo ! iint
2252       enddo ! i
2253       return
2254       end
2255 C--------------------------------------------------------------------------
2256       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2257      &              eello_turn4)
2258 C
2259 C Soft-sphere potential of p-p interaction
2260 C
2261       implicit real*8 (a-h,o-z)
2262       include 'DIMENSIONS'
2263       include 'COMMON.CONTROL'
2264       include 'COMMON.IOUNITS'
2265       include 'COMMON.GEO'
2266       include 'COMMON.VAR'
2267       include 'COMMON.LOCAL'
2268       include 'COMMON.CHAIN'
2269       include 'COMMON.DERIV'
2270       include 'COMMON.INTERACT'
2271       include 'COMMON.CONTACTS'
2272       include 'COMMON.TORSION'
2273       include 'COMMON.VECTORS'
2274       include 'COMMON.FFIELD'
2275       dimension ggg(3)
2276 C      write(iout,*) 'In EELEC_soft_sphere'
2277       ees=0.0D0
2278       evdw1=0.0D0
2279       eel_loc=0.0d0
2280       eello_turn3=0.0d0
2281       eello_turn4=0.0d0
2282       ind=0
2283       do i=iatel_s,iatel_e
2284         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2285         dxi=dc(1,i)
2286         dyi=dc(2,i)
2287         dzi=dc(3,i)
2288         xmedi=c(1,i)+0.5d0*dxi
2289         ymedi=c(2,i)+0.5d0*dyi
2290         zmedi=c(3,i)+0.5d0*dzi
2291           xmedi=mod(xmedi,boxxsize)
2292           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2293           ymedi=mod(ymedi,boxysize)
2294           if (ymedi.lt.0) ymedi=ymedi+boxysize
2295           zmedi=mod(zmedi,boxzsize)
2296           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2297         num_conti=0
2298 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2299         do j=ielstart(i),ielend(i)
2300           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2301           ind=ind+1
2302           iteli=itel(i)
2303           itelj=itel(j)
2304           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2305           r0ij=rpp(iteli,itelj)
2306           r0ijsq=r0ij*r0ij
2307           dxj=dc(1,j)
2308           dyj=dc(2,j)
2309           dzj=dc(3,j)
2310           xj=c(1,j)+0.5D0*dxj
2311           yj=c(2,j)+0.5D0*dyj
2312           zj=c(3,j)+0.5D0*dzj
2313           xj=mod(xj,boxxsize)
2314           if (xj.lt.0) xj=xj+boxxsize
2315           yj=mod(yj,boxysize)
2316           if (yj.lt.0) yj=yj+boxysize
2317           zj=mod(zj,boxzsize)
2318           if (zj.lt.0) zj=zj+boxzsize
2319       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2320       xj_safe=xj
2321       yj_safe=yj
2322       zj_safe=zj
2323       isubchap=0
2324       do xshift=-1,1
2325       do yshift=-1,1
2326       do zshift=-1,1
2327           xj=xj_safe+xshift*boxxsize
2328           yj=yj_safe+yshift*boxysize
2329           zj=zj_safe+zshift*boxzsize
2330           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2331           if(dist_temp.lt.dist_init) then
2332             dist_init=dist_temp
2333             xj_temp=xj
2334             yj_temp=yj
2335             zj_temp=zj
2336             isubchap=1
2337           endif
2338        enddo
2339        enddo
2340        enddo
2341        if (isubchap.eq.1) then
2342           xj=xj_temp-xmedi
2343           yj=yj_temp-ymedi
2344           zj=zj_temp-zmedi
2345        else
2346           xj=xj_safe-xmedi
2347           yj=yj_safe-ymedi
2348           zj=zj_safe-zmedi
2349        endif
2350           rij=xj*xj+yj*yj+zj*zj
2351             sss=sscale(sqrt(rij))
2352             sssgrad=sscagrad(sqrt(rij))
2353           if (rij.lt.r0ijsq) then
2354             evdw1ij=0.25d0*(rij-r0ijsq)**2
2355             fac=rij-r0ijsq
2356           else
2357             evdw1ij=0.0d0
2358             fac=0.0d0
2359           endif
2360           evdw1=evdw1+evdw1ij*sss
2361 C
2362 C Calculate contributions to the Cartesian gradient.
2363 C
2364           ggg(1)=fac*xj*sssgrad
2365           ggg(2)=fac*yj*sssgrad
2366           ggg(3)=fac*zj*sssgrad
2367           do k=1,3
2368             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2369             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2370           enddo
2371 *
2372 * Loop over residues i+1 thru j-1.
2373 *
2374 cgrad          do k=i+1,j-1
2375 cgrad            do l=1,3
2376 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2377 cgrad            enddo
2378 cgrad          enddo
2379         enddo ! j
2380       enddo   ! i
2381 cgrad      do i=nnt,nct-1
2382 cgrad        do k=1,3
2383 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2384 cgrad        enddo
2385 cgrad        do j=i+1,nct-1
2386 cgrad          do k=1,3
2387 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2388 cgrad          enddo
2389 cgrad        enddo
2390 cgrad      enddo
2391       return
2392       end
2393 c------------------------------------------------------------------------------
2394       subroutine vec_and_deriv
2395       implicit real*8 (a-h,o-z)
2396       include 'DIMENSIONS'
2397 #ifdef MPI
2398       include 'mpif.h'
2399 #endif
2400       include 'COMMON.IOUNITS'
2401       include 'COMMON.GEO'
2402       include 'COMMON.VAR'
2403       include 'COMMON.LOCAL'
2404       include 'COMMON.CHAIN'
2405       include 'COMMON.VECTORS'
2406       include 'COMMON.SETUP'
2407       include 'COMMON.TIME1'
2408       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2409 C Compute the local reference systems. For reference system (i), the
2410 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2411 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2412 #ifdef PARVEC
2413       do i=ivec_start,ivec_end
2414 #else
2415       do i=1,nres-1
2416 #endif
2417           if (i.eq.nres-1) then
2418 C Case of the last full residue
2419 C Compute the Z-axis
2420             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2421             costh=dcos(pi-theta(nres))
2422             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2423             do k=1,3
2424               uz(k,i)=fac*uz(k,i)
2425             enddo
2426 C Compute the derivatives of uz
2427             uzder(1,1,1)= 0.0d0
2428             uzder(2,1,1)=-dc_norm(3,i-1)
2429             uzder(3,1,1)= dc_norm(2,i-1)
2430             uzder(1,2,1)= dc_norm(3,i-1)
2431             uzder(2,2,1)= 0.0d0
2432             uzder(3,2,1)=-dc_norm(1,i-1)
2433             uzder(1,3,1)=-dc_norm(2,i-1)
2434             uzder(2,3,1)= dc_norm(1,i-1)
2435             uzder(3,3,1)= 0.0d0
2436             uzder(1,1,2)= 0.0d0
2437             uzder(2,1,2)= dc_norm(3,i)
2438             uzder(3,1,2)=-dc_norm(2,i)
2439             uzder(1,2,2)=-dc_norm(3,i)
2440             uzder(2,2,2)= 0.0d0
2441             uzder(3,2,2)= dc_norm(1,i)
2442             uzder(1,3,2)= dc_norm(2,i)
2443             uzder(2,3,2)=-dc_norm(1,i)
2444             uzder(3,3,2)= 0.0d0
2445 C Compute the Y-axis
2446             facy=fac
2447             do k=1,3
2448               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2449             enddo
2450 C Compute the derivatives of uy
2451             do j=1,3
2452               do k=1,3
2453                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2454      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2455                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2456               enddo
2457               uyder(j,j,1)=uyder(j,j,1)-costh
2458               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2459             enddo
2460             do j=1,2
2461               do k=1,3
2462                 do l=1,3
2463                   uygrad(l,k,j,i)=uyder(l,k,j)
2464                   uzgrad(l,k,j,i)=uzder(l,k,j)
2465                 enddo
2466               enddo
2467             enddo
2468             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2469             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2470             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2471             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2472           else
2473 C Other residues
2474 C Compute the Z-axis
2475             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2476             costh=dcos(pi-theta(i+2))
2477             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2478             do k=1,3
2479               uz(k,i)=fac*uz(k,i)
2480             enddo
2481 C Compute the derivatives of uz
2482             uzder(1,1,1)= 0.0d0
2483             uzder(2,1,1)=-dc_norm(3,i+1)
2484             uzder(3,1,1)= dc_norm(2,i+1)
2485             uzder(1,2,1)= dc_norm(3,i+1)
2486             uzder(2,2,1)= 0.0d0
2487             uzder(3,2,1)=-dc_norm(1,i+1)
2488             uzder(1,3,1)=-dc_norm(2,i+1)
2489             uzder(2,3,1)= dc_norm(1,i+1)
2490             uzder(3,3,1)= 0.0d0
2491             uzder(1,1,2)= 0.0d0
2492             uzder(2,1,2)= dc_norm(3,i)
2493             uzder(3,1,2)=-dc_norm(2,i)
2494             uzder(1,2,2)=-dc_norm(3,i)
2495             uzder(2,2,2)= 0.0d0
2496             uzder(3,2,2)= dc_norm(1,i)
2497             uzder(1,3,2)= dc_norm(2,i)
2498             uzder(2,3,2)=-dc_norm(1,i)
2499             uzder(3,3,2)= 0.0d0
2500 C Compute the Y-axis
2501             facy=fac
2502             do k=1,3
2503               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2504             enddo
2505 C Compute the derivatives of uy
2506             do j=1,3
2507               do k=1,3
2508                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2509      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2510                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2511               enddo
2512               uyder(j,j,1)=uyder(j,j,1)-costh
2513               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2514             enddo
2515             do j=1,2
2516               do k=1,3
2517                 do l=1,3
2518                   uygrad(l,k,j,i)=uyder(l,k,j)
2519                   uzgrad(l,k,j,i)=uzder(l,k,j)
2520                 enddo
2521               enddo
2522             enddo
2523             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2524             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2525             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2526             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2527           endif
2528       enddo
2529       do i=1,nres-1
2530         vbld_inv_temp(1)=vbld_inv(i+1)
2531         if (i.lt.nres-1) then
2532           vbld_inv_temp(2)=vbld_inv(i+2)
2533           else
2534           vbld_inv_temp(2)=vbld_inv(i)
2535           endif
2536         do j=1,2
2537           do k=1,3
2538             do l=1,3
2539               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2540               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2541             enddo
2542           enddo
2543         enddo
2544       enddo
2545 #if defined(PARVEC) && defined(MPI)
2546       if (nfgtasks1.gt.1) then
2547         time00=MPI_Wtime()
2548 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2549 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2550 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2551         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2552      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2553      &   FG_COMM1,IERR)
2554         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2558      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2559      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2560         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2561      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2562      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2563         time_gather=time_gather+MPI_Wtime()-time00
2564       endif
2565 c      if (fg_rank.eq.0) then
2566 c        write (iout,*) "Arrays UY and UZ"
2567 c        do i=1,nres-1
2568 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2569 c     &     (uz(k,i),k=1,3)
2570 c        enddo
2571 c      endif
2572 #endif
2573       return
2574       end
2575 C-----------------------------------------------------------------------------
2576       subroutine check_vecgrad
2577       implicit real*8 (a-h,o-z)
2578       include 'DIMENSIONS'
2579       include 'COMMON.IOUNITS'
2580       include 'COMMON.GEO'
2581       include 'COMMON.VAR'
2582       include 'COMMON.LOCAL'
2583       include 'COMMON.CHAIN'
2584       include 'COMMON.VECTORS'
2585       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2586       dimension uyt(3,maxres),uzt(3,maxres)
2587       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2588       double precision delta /1.0d-7/
2589       call vec_and_deriv
2590 cd      do i=1,nres
2591 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2592 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2593 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2594 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2595 cd     &     (dc_norm(if90,i),if90=1,3)
2596 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2597 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2598 cd          write(iout,'(a)')
2599 cd      enddo
2600       do i=1,nres
2601         do j=1,2
2602           do k=1,3
2603             do l=1,3
2604               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2605               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2606             enddo
2607           enddo
2608         enddo
2609       enddo
2610       call vec_and_deriv
2611       do i=1,nres
2612         do j=1,3
2613           uyt(j,i)=uy(j,i)
2614           uzt(j,i)=uz(j,i)
2615         enddo
2616       enddo
2617       do i=1,nres
2618 cd        write (iout,*) 'i=',i
2619         do k=1,3
2620           erij(k)=dc_norm(k,i)
2621         enddo
2622         do j=1,3
2623           do k=1,3
2624             dc_norm(k,i)=erij(k)
2625           enddo
2626           dc_norm(j,i)=dc_norm(j,i)+delta
2627 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2628 c          do k=1,3
2629 c            dc_norm(k,i)=dc_norm(k,i)/fac
2630 c          enddo
2631 c          write (iout,*) (dc_norm(k,i),k=1,3)
2632 c          write (iout,*) (erij(k),k=1,3)
2633           call vec_and_deriv
2634           do k=1,3
2635             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2636             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2637             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2638             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2639           enddo
2640 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2641 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2642 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2643         enddo
2644         do k=1,3
2645           dc_norm(k,i)=erij(k)
2646         enddo
2647 cd        do k=1,3
2648 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2649 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2650 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2651 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2652 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2653 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2654 cd          write (iout,'(a)')
2655 cd        enddo
2656       enddo
2657       return
2658       end
2659 C--------------------------------------------------------------------------
2660       subroutine set_matrices
2661       implicit real*8 (a-h,o-z)
2662       include 'DIMENSIONS'
2663 #ifdef MPI
2664       include "mpif.h"
2665       include "COMMON.SETUP"
2666       integer IERR
2667       integer status(MPI_STATUS_SIZE)
2668 #endif
2669       include 'COMMON.IOUNITS'
2670       include 'COMMON.GEO'
2671       include 'COMMON.VAR'
2672       include 'COMMON.LOCAL'
2673       include 'COMMON.CHAIN'
2674       include 'COMMON.DERIV'
2675       include 'COMMON.INTERACT'
2676       include 'COMMON.CONTACTS'
2677       include 'COMMON.TORSION'
2678       include 'COMMON.VECTORS'
2679       include 'COMMON.FFIELD'
2680       double precision auxvec(2),auxmat(2,2)
2681 C
2682 C Compute the virtual-bond-torsional-angle dependent quantities needed
2683 C to calculate the el-loc multibody terms of various order.
2684 C
2685 c      write(iout,*) 'nphi=',nphi,nres
2686 #ifdef PARMAT
2687       do i=ivec_start+2,ivec_end+2
2688 #else
2689       do i=3,nres+1
2690 #endif
2691 #ifdef NEWCORR
2692         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2693           iti = itortyp(itype(i-2))
2694         else
2695           iti=ntortyp+1
2696         endif
2697 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2698         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2699           iti1 = itortyp(itype(i-1))
2700         else
2701           iti1=ntortyp+1
2702         endif
2703 c        write(iout,*),i
2704         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2705      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2706      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2707         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2708      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2709      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2710 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2711 c     &*(cos(theta(i)/2.0)
2712         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2713      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2714      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2715 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2716 c     &*(cos(theta(i)/2.0)
2717         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2718      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2719      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2720 c        if (ggb1(1,i).eq.0.0d0) then
2721 c        write(iout,*) 'i=',i,ggb1(1,i),
2722 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2723 c     &bnew1(2,1,iti)*cos(theta(i)),
2724 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2725 c        endif
2726         b1(2,i-2)=bnew1(1,2,iti)
2727         gtb1(2,i-2)=0.0
2728         b2(2,i-2)=bnew2(1,2,iti)
2729         gtb2(2,i-2)=0.0
2730         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2731         EE(1,2,i-2)=eeold(1,2,iti)
2732         EE(2,1,i-2)=eeold(2,1,iti)
2733         EE(2,2,i-2)=eeold(2,2,iti)
2734         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2735         gtEE(1,2,i-2)=0.0d0
2736         gtEE(2,2,i-2)=0.0d0
2737         gtEE(2,1,i-2)=0.0d0
2738 c        EE(2,2,iti)=0.0d0
2739 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2740 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2741 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2742 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2743        b1tilde(1,i-2)=b1(1,i-2)
2744        b1tilde(2,i-2)=-b1(2,i-2)
2745        b2tilde(1,i-2)=b2(1,i-2)
2746        b2tilde(2,i-2)=-b2(2,i-2)
2747 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2748 c       write(iout,*)  'b1=',b1(1,i-2)
2749 c       write (iout,*) 'theta=', theta(i-1)
2750        enddo
2751 #else
2752         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2753           iti = itortyp(itype(i-2))
2754         else
2755           iti=ntortyp+1
2756         endif
2757 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2758         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2759           iti1 = itortyp(itype(i-1))
2760         else
2761           iti1=ntortyp+1
2762         endif
2763         b1(1,i-2)=b(3,iti)
2764         b1(2,i-2)=b(5,iti)
2765         b2(1,i-2)=b(2,iti)
2766         b2(2,i-2)=b(4,iti)
2767        b1tilde(1,i-2)=b1(1,i-2)
2768        b1tilde(2,i-2)=-b1(2,i-2)
2769        b2tilde(1,i-2)=b2(1,i-2)
2770        b2tilde(2,i-2)=-b2(2,i-2)
2771         EE(1,2,i-2)=eeold(1,2,iti)
2772         EE(2,1,i-2)=eeold(2,1,iti)
2773         EE(2,2,i-2)=eeold(2,2,iti)
2774         EE(1,1,i-2)=eeold(1,1,iti)
2775       enddo
2776 #endif
2777 #ifdef PARMAT
2778       do i=ivec_start+2,ivec_end+2
2779 #else
2780       do i=3,nres+1
2781 #endif
2782         if (i .lt. nres+1) then
2783           sin1=dsin(phi(i))
2784           cos1=dcos(phi(i))
2785           sintab(i-2)=sin1
2786           costab(i-2)=cos1
2787           obrot(1,i-2)=cos1
2788           obrot(2,i-2)=sin1
2789           sin2=dsin(2*phi(i))
2790           cos2=dcos(2*phi(i))
2791           sintab2(i-2)=sin2
2792           costab2(i-2)=cos2
2793           obrot2(1,i-2)=cos2
2794           obrot2(2,i-2)=sin2
2795           Ug(1,1,i-2)=-cos1
2796           Ug(1,2,i-2)=-sin1
2797           Ug(2,1,i-2)=-sin1
2798           Ug(2,2,i-2)= cos1
2799           Ug2(1,1,i-2)=-cos2
2800           Ug2(1,2,i-2)=-sin2
2801           Ug2(2,1,i-2)=-sin2
2802           Ug2(2,2,i-2)= cos2
2803         else
2804           costab(i-2)=1.0d0
2805           sintab(i-2)=0.0d0
2806           obrot(1,i-2)=1.0d0
2807           obrot(2,i-2)=0.0d0
2808           obrot2(1,i-2)=0.0d0
2809           obrot2(2,i-2)=0.0d0
2810           Ug(1,1,i-2)=1.0d0
2811           Ug(1,2,i-2)=0.0d0
2812           Ug(2,1,i-2)=0.0d0
2813           Ug(2,2,i-2)=1.0d0
2814           Ug2(1,1,i-2)=0.0d0
2815           Ug2(1,2,i-2)=0.0d0
2816           Ug2(2,1,i-2)=0.0d0
2817           Ug2(2,2,i-2)=0.0d0
2818         endif
2819         if (i .gt. 3 .and. i .lt. nres+1) then
2820           obrot_der(1,i-2)=-sin1
2821           obrot_der(2,i-2)= cos1
2822           Ugder(1,1,i-2)= sin1
2823           Ugder(1,2,i-2)=-cos1
2824           Ugder(2,1,i-2)=-cos1
2825           Ugder(2,2,i-2)=-sin1
2826           dwacos2=cos2+cos2
2827           dwasin2=sin2+sin2
2828           obrot2_der(1,i-2)=-dwasin2
2829           obrot2_der(2,i-2)= dwacos2
2830           Ug2der(1,1,i-2)= dwasin2
2831           Ug2der(1,2,i-2)=-dwacos2
2832           Ug2der(2,1,i-2)=-dwacos2
2833           Ug2der(2,2,i-2)=-dwasin2
2834         else
2835           obrot_der(1,i-2)=0.0d0
2836           obrot_der(2,i-2)=0.0d0
2837           Ugder(1,1,i-2)=0.0d0
2838           Ugder(1,2,i-2)=0.0d0
2839           Ugder(2,1,i-2)=0.0d0
2840           Ugder(2,2,i-2)=0.0d0
2841           obrot2_der(1,i-2)=0.0d0
2842           obrot2_der(2,i-2)=0.0d0
2843           Ug2der(1,1,i-2)=0.0d0
2844           Ug2der(1,2,i-2)=0.0d0
2845           Ug2der(2,1,i-2)=0.0d0
2846           Ug2der(2,2,i-2)=0.0d0
2847         endif
2848 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2849         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2850           iti = itortyp(itype(i-2))
2851         else
2852           iti=ntortyp
2853         endif
2854 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2855         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2856           iti1 = itortyp(itype(i-1))
2857         else
2858           iti1=ntortyp
2859         endif
2860 cd        write (iout,*) '*******i',i,' iti1',iti
2861 cd        write (iout,*) 'b1',b1(:,iti)
2862 cd        write (iout,*) 'b2',b2(:,iti)
2863 cd         write (iout,*) "phi(",i,")=",phi(i)," sin1",sin1," cos1",cos1
2864 cd         write (iout,*) 'Ug',Ug(:,:,i-2)
2865 c        if (i .gt. iatel_s+2) then
2866         if (i .gt. nnt+2) then
2867           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2868 #ifdef NEWCORR
2869           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2870 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2871 #endif
2872 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2873 c     &    EE(1,2,iti),EE(2,2,iti)
2874           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2875           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2876 c          write(iout,*) "Macierz EUG",
2877 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2878 c     &    eug(2,2,i-2)
2879           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2880      &    then
2881           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2882           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2883           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2884           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2885           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2886           endif
2887         else
2888           do k=1,2
2889             Ub2(k,i-2)=0.0d0
2890             Ctobr(k,i-2)=0.0d0
2891             Dtobr2(k,i-2)=0.0d0
2892             do l=1,2
2893               EUg(l,k,i-2)=0.0d0
2894               CUg(l,k,i-2)=0.0d0
2895               DUg(l,k,i-2)=0.0d0
2896               DtUg2(l,k,i-2)=0.0d0
2897             enddo
2898           enddo
2899         endif
2900         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2901         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2902         do k=1,2
2903           muder(k,i-2)=Ub2der(k,i-2)
2904         enddo
2905 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2906         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2907           if (itype(i-1).le.ntyp) then
2908             iti1 = itortyp(itype(i-1))
2909           else
2910             iti1=ntortyp
2911           endif
2912         else
2913           iti1=ntortyp
2914         endif
2915         do k=1,2
2916           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2917         enddo
2918 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2919 cd        write (iout,*) 'mu  ',mu(:,i-2),i-2
2920 cd        write (iout,*) 'b1  ',b1(:,i-1),i-2
2921 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2922 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2923 cd        write (iout,*) 'b2  ',b2(:,i-2),i-2
2924 cd        write (iout,*) 'mu1',mu1(:,i-2)
2925 cd        write (iout,*) 'mu2',mu2(:,i-2)
2926         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2927      &  then
2928         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2929         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2930         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2931         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2932         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2933 C Vectors and matrices dependent on a single virtual-bond dihedral.
2934         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2935         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2936         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2937         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2938         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2939         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2940         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2941         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2942         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2943         endif
2944       enddo
2945 C Matrices dependent on two consecutive virtual-bond dihedrals.
2946 C The order of matrices is from left to right.
2947       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2948      &then
2949 c      do i=max0(ivec_start,2),ivec_end
2950       do i=2,nres-1
2951         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2952         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2953         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2954         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2955         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2956         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2957         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2958         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2959       enddo
2960       endif
2961 #if defined(MPI) && defined(PARMAT)
2962 #ifdef DEBUG
2963 c      if (fg_rank.eq.0) then
2964         write (iout,*) "Arrays UG and UGDER before GATHER"
2965         do i=1,nres-1
2966           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2967      &     ((ug(l,k,i),l=1,2),k=1,2),
2968      &     ((ugder(l,k,i),l=1,2),k=1,2)
2969         enddo
2970         write (iout,*) "Arrays UG2 and UG2DER"
2971         do i=1,nres-1
2972           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2973      &     ((ug2(l,k,i),l=1,2),k=1,2),
2974      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2975         enddo
2976         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2977         do i=1,nres-1
2978           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2979      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2980      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2981         enddo
2982         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2983         do i=1,nres-1
2984           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2985      &     costab(i),sintab(i),costab2(i),sintab2(i)
2986         enddo
2987         write (iout,*) "Array MUDER"
2988         do i=1,nres-1
2989           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2990         enddo
2991 c      endif
2992 #endif
2993       if (nfgtasks.gt.1) then
2994         time00=MPI_Wtime()
2995 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2996 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2997 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2998 #ifdef MATGATHER
2999         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3000      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3001      &   FG_COMM1,IERR)
3002         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3003      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3004      &   FG_COMM1,IERR)
3005         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3006      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3007      &   FG_COMM1,IERR)
3008         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3009      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3010      &   FG_COMM1,IERR)
3011         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3012      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3013      &   FG_COMM1,IERR)
3014         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3015      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3016      &   FG_COMM1,IERR)
3017         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3018      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3019      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3020         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3021      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3022      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3023         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3024      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3025      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3026         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3027      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3028      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3029         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3030      &  then
3031         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3039      &   FG_COMM1,IERR)
3040        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3047      &   ivec_count(fg_rank1),
3048      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3049      &   FG_COMM1,IERR)
3050         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3051      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3052      &   FG_COMM1,IERR)
3053         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3054      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3055      &   FG_COMM1,IERR)
3056         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3057      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3058      &   FG_COMM1,IERR)
3059         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3060      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3061      &   FG_COMM1,IERR)
3062         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3063      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3064      &   FG_COMM1,IERR)
3065         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3066      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3067      &   FG_COMM1,IERR)
3068         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3069      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3070      &   FG_COMM1,IERR)
3071         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3072      &   ivec_count(fg_rank1),
3073      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3074      &   FG_COMM1,IERR)
3075         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3076      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3077      &   FG_COMM1,IERR)
3078        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3079      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3080      &   FG_COMM1,IERR)
3081         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3082      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3083      &   FG_COMM1,IERR)
3084        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3085      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3086      &   FG_COMM1,IERR)
3087         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3088      &   ivec_count(fg_rank1),
3089      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3092      &   ivec_count(fg_rank1),
3093      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3094      &   FG_COMM1,IERR)
3095         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3096      &   ivec_count(fg_rank1),
3097      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3098      &   MPI_MAT2,FG_COMM1,IERR)
3099         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3100      &   ivec_count(fg_rank1),
3101      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3102      &   MPI_MAT2,FG_COMM1,IERR)
3103         endif
3104 #else
3105 c Passes matrix info through the ring
3106       isend=fg_rank1
3107       irecv=fg_rank1-1
3108       if (irecv.lt.0) irecv=nfgtasks1-1
3109       iprev=irecv
3110       inext=fg_rank1+1
3111       if (inext.ge.nfgtasks1) inext=0
3112       do i=1,nfgtasks1-1
3113 c        write (iout,*) "isend",isend," irecv",irecv
3114 c        call flush(iout)
3115         lensend=lentyp(isend)
3116         lenrecv=lentyp(irecv)
3117 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3118 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3119 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3120 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3121 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3122 c        write (iout,*) "Gather ROTAT1"
3123 c        call flush(iout)
3124 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3125 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3126 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3127 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3128 c        write (iout,*) "Gather ROTAT2"
3129 c        call flush(iout)
3130         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3131      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3132      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3133      &   iprev,4400+irecv,FG_COMM,status,IERR)
3134 c        write (iout,*) "Gather ROTAT_OLD"
3135 c        call flush(iout)
3136         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3137      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3138      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3139      &   iprev,5500+irecv,FG_COMM,status,IERR)
3140 c        write (iout,*) "Gather PRECOMP11"
3141 c        call flush(iout)
3142         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3143      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3144      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3145      &   iprev,6600+irecv,FG_COMM,status,IERR)
3146 c        write (iout,*) "Gather PRECOMP12"
3147 c        call flush(iout)
3148         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3149      &  then
3150         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3151      &   MPI_ROTAT2(lensend),inext,7700+isend,
3152      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3153      &   iprev,7700+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather PRECOMP21"
3155 c        call flush(iout)
3156         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3157      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3158      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3159      &   iprev,8800+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather PRECOMP22"
3161 c        call flush(iout)
3162         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3163      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3164      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3165      &   MPI_PRECOMP23(lenrecv),
3166      &   iprev,9900+irecv,FG_COMM,status,IERR)
3167 c        write (iout,*) "Gather PRECOMP23"
3168 c        call flush(iout)
3169         endif
3170         isend=irecv
3171         irecv=irecv-1
3172         if (irecv.lt.0) irecv=nfgtasks1-1
3173       enddo
3174 #endif
3175         time_gather=time_gather+MPI_Wtime()-time00
3176       endif
3177 #ifdef DEBUG
3178 c      if (fg_rank.eq.0) then
3179         write (iout,*) "Arrays UG and UGDER"
3180         do i=1,nres-1
3181           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3182      &     ((ug(l,k,i),l=1,2),k=1,2),
3183      &     ((ugder(l,k,i),l=1,2),k=1,2)
3184         enddo
3185         write (iout,*) "Arrays UG2 and UG2DER"
3186         do i=1,nres-1
3187           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3188      &     ((ug2(l,k,i),l=1,2),k=1,2),
3189      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3190         enddo
3191         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3192         do i=1,nres-1
3193           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3194      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3195      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3196         enddo
3197         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3198         do i=1,nres-1
3199           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3200      &     costab(i),sintab(i),costab2(i),sintab2(i)
3201         enddo
3202         write (iout,*) "Array MUDER"
3203         do i=1,nres-1
3204           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3205         enddo
3206 c      endif
3207 #endif
3208 #endif
3209 cd      do i=1,nres
3210 cd        iti = itortyp(itype(i))
3211 cd        write (iout,*) i
3212 cd        do j=1,2
3213 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3214 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3215 cd        enddo
3216 cd      enddo
3217       return
3218       end
3219 C--------------------------------------------------------------------------
3220       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3221 C
3222 C This subroutine calculates the average interaction energy and its gradient
3223 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3224 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3225 C The potential depends both on the distance of peptide-group centers and on
3226 C the orientation of the CA-CA virtual bonds.
3227 C
3228       implicit real*8 (a-h,o-z)
3229 #ifdef MPI
3230       include 'mpif.h'
3231 #endif
3232       include 'DIMENSIONS'
3233       include 'COMMON.CONTROL'
3234       include 'COMMON.SETUP'
3235       include 'COMMON.IOUNITS'
3236       include 'COMMON.GEO'
3237       include 'COMMON.VAR'
3238       include 'COMMON.LOCAL'
3239       include 'COMMON.CHAIN'
3240       include 'COMMON.DERIV'
3241       include 'COMMON.INTERACT'
3242       include 'COMMON.CONTACTS'
3243       include 'COMMON.TORSION'
3244       include 'COMMON.VECTORS'
3245       include 'COMMON.FFIELD'
3246       include 'COMMON.TIME1'
3247       include 'COMMON.SPLITELE'
3248       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3249      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3250       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3251      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3252       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3253      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3254      &    num_conti,j1,j2
3255 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3256 #ifdef MOMENT
3257       double precision scal_el /1.0d0/
3258 #else
3259       double precision scal_el /0.5d0/
3260 #endif
3261 C 12/13/98
3262 C 13-go grudnia roku pamietnego...
3263       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3264      &                   0.0d0,1.0d0,0.0d0,
3265      &                   0.0d0,0.0d0,1.0d0/
3266 cd      write(iout,*) 'In EELEC'
3267 cd      do i=1,nloctyp
3268 cd        write(iout,*) 'Type',i
3269 cd        write(iout,*) 'B1',B1(:,i)
3270 cd        write(iout,*) 'B2',B2(:,i)
3271 cd        write(iout,*) 'CC',CC(:,:,i)
3272 cd        write(iout,*) 'DD',DD(:,:,i)
3273 cd        write(iout,*) 'EE',EE(:,:,i)
3274 cd      enddo
3275 cd      call check_vecgrad
3276 cd      stop
3277       if (icheckgrad.eq.1) then
3278         do i=1,nres-1
3279           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3280           do k=1,3
3281             dc_norm(k,i)=dc(k,i)*fac
3282           enddo
3283 c          write (iout,*) 'i',i,' fac',fac
3284         enddo
3285       endif
3286       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3287      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3288      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3289 c        call vec_and_deriv
3290 #ifdef TIMING
3291         time01=MPI_Wtime()
3292 #endif
3293         call set_matrices
3294 #ifdef TIMING
3295         time_mat=time_mat+MPI_Wtime()-time01
3296 #endif
3297       endif
3298 cd      do i=1,nres-1
3299 cd        write (iout,*) 'i=',i
3300 cd        do k=1,3
3301 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3302 cd        enddo
3303 cd        do k=1,3
3304 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3305 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3306 cd        enddo
3307 cd      enddo
3308       t_eelecij=0.0d0
3309       ees=0.0D0
3310       evdw1=0.0D0
3311       eel_loc=0.0d0
3312       eello_turn3=0.0d0
3313       eello_turn4=0.0d0
3314       ind=0
3315       do i=1,nres
3316         num_cont_hb(i)=0
3317       enddo
3318 cd      print '(a)','Enter EELEC'
3319 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3320       do i=1,nres
3321         gel_loc_loc(i)=0.0d0
3322         gcorr_loc(i)=0.0d0
3323       enddo
3324 c
3325 c
3326 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3327 C
3328 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3329 C
3330 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3331       do i=iturn3_start,iturn3_end
3332 CAna        if (i.le.1) cycle
3333 C        write(iout,*) "tu jest i",i
3334         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3335 C changes suggested by Ana to avoid out of bounds
3336 CAna     & .or.((i+4).gt.nres)
3337 CAna     & .or.((i-1).le.0)
3338 C end of changes by Ana
3339      &  .or. itype(i+2).eq.ntyp1
3340      &  .or. itype(i+3).eq.ntyp1) cycle
3341 CAna        if(i.gt.1)then
3342 CAna          if(itype(i-1).eq.ntyp1)cycle
3343 CAna        end if
3344 CAna        if(i.LT.nres-3)then
3345 CAna          if (itype(i+4).eq.ntyp1) cycle
3346 CAna        end if
3347         dxi=dc(1,i)
3348         dyi=dc(2,i)
3349         dzi=dc(3,i)
3350         dx_normi=dc_norm(1,i)
3351         dy_normi=dc_norm(2,i)
3352         dz_normi=dc_norm(3,i)
3353         xmedi=c(1,i)+0.5d0*dxi
3354         ymedi=c(2,i)+0.5d0*dyi
3355         zmedi=c(3,i)+0.5d0*dzi
3356           xmedi=mod(xmedi,boxxsize)
3357           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3358           ymedi=mod(ymedi,boxysize)
3359           if (ymedi.lt.0) ymedi=ymedi+boxysize
3360           zmedi=mod(zmedi,boxzsize)
3361           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3362         num_conti=0
3363         call eelecij(i,i+2,ees,evdw1,eel_loc)
3364         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3365         num_cont_hb(i)=num_conti
3366       enddo
3367       do i=iturn4_start,iturn4_end
3368 cAna        if (i.le.1) cycle
3369         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3370 C changes suggested by Ana to avoid out of bounds
3371 cAna     & .or.((i+5).gt.nres)
3372 cAna     & .or.((i-1).le.0)
3373 C end of changes suggested by Ana
3374      &    .or. itype(i+3).eq.ntyp1
3375      &    .or. itype(i+4).eq.ntyp1
3376 cAna     &    .or. itype(i+5).eq.ntyp1
3377 cAna     &    .or. itype(i).eq.ntyp1
3378 cAna     &    .or. itype(i-1).eq.ntyp1
3379      &                             ) cycle
3380         dxi=dc(1,i)
3381         dyi=dc(2,i)
3382         dzi=dc(3,i)
3383         dx_normi=dc_norm(1,i)
3384         dy_normi=dc_norm(2,i)
3385         dz_normi=dc_norm(3,i)
3386         xmedi=c(1,i)+0.5d0*dxi
3387         ymedi=c(2,i)+0.5d0*dyi
3388         zmedi=c(3,i)+0.5d0*dzi
3389 C Return atom into box, boxxsize is size of box in x dimension
3390 c  194   continue
3391 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3392 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3393 C Condition for being inside the proper box
3394 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3395 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3396 c        go to 194
3397 c        endif
3398 c  195   continue
3399 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3400 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3401 C Condition for being inside the proper box
3402 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3403 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3404 c        go to 195
3405 c        endif
3406 c  196   continue
3407 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3408 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3409 C Condition for being inside the proper box
3410 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3411 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3412 c        go to 196
3413 c        endif
3414           xmedi=mod(xmedi,boxxsize)
3415           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3416           ymedi=mod(ymedi,boxysize)
3417           if (ymedi.lt.0) ymedi=ymedi+boxysize
3418           zmedi=mod(zmedi,boxzsize)
3419           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3420
3421         num_conti=num_cont_hb(i)
3422 c        write(iout,*) "JESTEM W PETLI"
3423         call eelecij(i,i+3,ees,evdw1,eel_loc)
3424         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3425      &   call eturn4(i,eello_turn4)
3426         num_cont_hb(i)=num_conti
3427       enddo   ! i
3428 C Loop over all neighbouring boxes
3429 C      do xshift=-1,1
3430 C      do yshift=-1,1
3431 C      do zshift=-1,1
3432 c
3433 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3434 c
3435       do i=iatel_s,iatel_e
3436 cAna        if (i.le.1) cycle
3437         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3438 C changes suggested by Ana to avoid out of bounds
3439 cAna     & .or.((i+2).gt.nres)
3440 cAna     & .or.((i-1).le.0)
3441 C end of changes by Ana
3442 cAna     &  .or. itype(i+2).eq.ntyp1
3443 cAna     &  .or. itype(i-1).eq.ntyp1
3444      &                ) cycle
3445         dxi=dc(1,i)
3446         dyi=dc(2,i)
3447         dzi=dc(3,i)
3448         dx_normi=dc_norm(1,i)
3449         dy_normi=dc_norm(2,i)
3450         dz_normi=dc_norm(3,i)
3451         xmedi=c(1,i)+0.5d0*dxi
3452         ymedi=c(2,i)+0.5d0*dyi
3453         zmedi=c(3,i)+0.5d0*dzi
3454           xmedi=mod(xmedi,boxxsize)
3455           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3456           ymedi=mod(ymedi,boxysize)
3457           if (ymedi.lt.0) ymedi=ymedi+boxysize
3458           zmedi=mod(zmedi,boxzsize)
3459           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3460 C          xmedi=xmedi+xshift*boxxsize
3461 C          ymedi=ymedi+yshift*boxysize
3462 C          zmedi=zmedi+zshift*boxzsize
3463
3464 C Return tom into box, boxxsize is size of box in x dimension
3465 c  164   continue
3466 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3467 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3468 C Condition for being inside the proper box
3469 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3470 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3471 c        go to 164
3472 c        endif
3473 c  165   continue
3474 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3475 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3476 C Condition for being inside the proper box
3477 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3478 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3479 c        go to 165
3480 c        endif
3481 c  166   continue
3482 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3483 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3484 cC Condition for being inside the proper box
3485 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3486 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3487 c        go to 166
3488 c        endif
3489
3490 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3491         num_conti=num_cont_hb(i)
3492         do j=ielstart(i),ielend(i)
3493 C          write (iout,*) i,j
3494 cAna         if (j.le.1) cycle
3495           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3496 C changes suggested by Ana to avoid out of bounds
3497 cAna     & .or.((j+2).gt.nres)
3498 cAna     & .or.((j-1).le.0)
3499 C end of changes by Ana
3500 cAna     & .or.itype(j+2).eq.ntyp1
3501 cAna     & .or.itype(j-1).eq.ntyp1
3502      &) cycle
3503           call eelecij(i,j,ees,evdw1,eel_loc)
3504         enddo ! j
3505         num_cont_hb(i)=num_conti
3506       enddo   ! i
3507 C     enddo   ! zshift
3508 C      enddo   ! yshift
3509 C      enddo   ! xshift
3510
3511 c      write (iout,*) "Number of loop steps in EELEC:",ind
3512 cd      do i=1,nres
3513 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3514 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3515 cd      enddo
3516 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3517 ccc      eel_loc=eel_loc+eello_turn3
3518 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3519       return
3520       end
3521 C-------------------------------------------------------------------------------
3522       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3523       implicit real*8 (a-h,o-z)
3524       include 'DIMENSIONS'
3525 #ifdef MPI
3526       include "mpif.h"
3527 #endif
3528       include 'COMMON.CONTROL'
3529       include 'COMMON.IOUNITS'
3530       include 'COMMON.GEO'
3531       include 'COMMON.VAR'
3532       include 'COMMON.LOCAL'
3533       include 'COMMON.CHAIN'
3534       include 'COMMON.DERIV'
3535       include 'COMMON.INTERACT'
3536       include 'COMMON.CONTACTS'
3537       include 'COMMON.TORSION'
3538       include 'COMMON.VECTORS'
3539       include 'COMMON.FFIELD'
3540       include 'COMMON.TIME1'
3541       include 'COMMON.SPLITELE'
3542       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3543      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3544       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3545      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3546      &    gmuij2(4),gmuji2(4)
3547       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3548      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3549      &    num_conti,j1,j2
3550 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3551 #ifdef MOMENT
3552       double precision scal_el /1.0d0/
3553 #else
3554       double precision scal_el /0.5d0/
3555 #endif
3556 C 12/13/98
3557 C 13-go grudnia roku pamietnego...
3558       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3559      &                   0.0d0,1.0d0,0.0d0,
3560      &                   0.0d0,0.0d0,1.0d0/
3561 c          time00=MPI_Wtime()
3562 cd      write (iout,*) "eelecij",i,j
3563 c          ind=ind+1
3564           iteli=itel(i)
3565           itelj=itel(j)
3566           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3567           aaa=app(iteli,itelj)
3568           bbb=bpp(iteli,itelj)
3569           ael6i=ael6(iteli,itelj)
3570           ael3i=ael3(iteli,itelj)
3571           dxj=dc(1,j)
3572           dyj=dc(2,j)
3573           dzj=dc(3,j)
3574           dx_normj=dc_norm(1,j)
3575           dy_normj=dc_norm(2,j)
3576           dz_normj=dc_norm(3,j)
3577 C          xj=c(1,j)+0.5D0*dxj-xmedi
3578 C          yj=c(2,j)+0.5D0*dyj-ymedi
3579 C          zj=c(3,j)+0.5D0*dzj-zmedi
3580           xj=c(1,j)+0.5D0*dxj
3581           yj=c(2,j)+0.5D0*dyj
3582           zj=c(3,j)+0.5D0*dzj
3583           xj=mod(xj,boxxsize)
3584           if (xj.lt.0) xj=xj+boxxsize
3585           yj=mod(yj,boxysize)
3586           if (yj.lt.0) yj=yj+boxysize
3587           zj=mod(zj,boxzsize)
3588           if (zj.lt.0) zj=zj+boxzsize
3589           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3590       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3591       xj_safe=xj
3592       yj_safe=yj
3593       zj_safe=zj
3594       isubchap=0
3595       do xshift=-1,1
3596       do yshift=-1,1
3597       do zshift=-1,1
3598           xj=xj_safe+xshift*boxxsize
3599           yj=yj_safe+yshift*boxysize
3600           zj=zj_safe+zshift*boxzsize
3601           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3602           if(dist_temp.lt.dist_init) then
3603             dist_init=dist_temp
3604             xj_temp=xj
3605             yj_temp=yj
3606             zj_temp=zj
3607             isubchap=1
3608           endif
3609        enddo
3610        enddo
3611        enddo
3612        if (isubchap.eq.1) then
3613           xj=xj_temp-xmedi
3614           yj=yj_temp-ymedi
3615           zj=zj_temp-zmedi
3616        else
3617           xj=xj_safe-xmedi
3618           yj=yj_safe-ymedi
3619           zj=zj_safe-zmedi
3620        endif
3621 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3622 c  174   continue
3623 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3624 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3625 C Condition for being inside the proper box
3626 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3627 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3628 c        go to 174
3629 c        endif
3630 c  175   continue
3631 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3632 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3633 C Condition for being inside the proper box
3634 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3635 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3636 c        go to 175
3637 c        endif
3638 c  176   continue
3639 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3640 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3641 C Condition for being inside the proper box
3642 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3643 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3644 c        go to 176
3645 c        endif
3646 C        endif !endPBC condintion
3647 C        xj=xj-xmedi
3648 C        yj=yj-ymedi
3649 C        zj=zj-zmedi
3650           rij=xj*xj+yj*yj+zj*zj
3651
3652             sss=sscale(sqrt(rij))
3653             sssgrad=sscagrad(sqrt(rij))
3654 c            if (sss.gt.0.0d0) then
3655           rrmij=1.0D0/rij
3656           rij=dsqrt(rij)
3657           rmij=1.0D0/rij
3658           r3ij=rrmij*rmij
3659           r6ij=r3ij*r3ij
3660           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3661           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3662           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3663           fac=cosa-3.0D0*cosb*cosg
3664           ev1=aaa*r6ij*r6ij
3665 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3666           if (j.eq.i+2) ev1=scal_el*ev1
3667           ev2=bbb*r6ij
3668           fac3=ael6i*r6ij
3669           fac4=ael3i*r3ij
3670           evdwij=(ev1+ev2)
3671           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3672           el2=fac4*fac
3673 C MARYSIA
3674           eesij=(el1+el2)
3675 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3676           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3677           ees=ees+eesij
3678           evdw1=evdw1+evdwij*sss
3679 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3680 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3681 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3682 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3683
3684           if (energy_dec) then
3685               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3686      &'evdw1',i,j,evdwij
3687 c     &,iteli,itelj,aaa,evdw1
3688               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3689           endif
3690
3691 C
3692 C Calculate contributions to the Cartesian gradient.
3693 C
3694 #ifdef SPLITELE
3695           facvdw=-6*rrmij*(ev1+evdwij)*sss
3696           facel=-3*rrmij*(el1+eesij)
3697           fac1=fac
3698           erij(1)=xj*rmij
3699           erij(2)=yj*rmij
3700           erij(3)=zj*rmij
3701 *
3702 * Radial derivatives. First process both termini of the fragment (i,j)
3703 *
3704           ggg(1)=facel*xj
3705           ggg(2)=facel*yj
3706           ggg(3)=facel*zj
3707 c          do k=1,3
3708 c            ghalf=0.5D0*ggg(k)
3709 c            gelc(k,i)=gelc(k,i)+ghalf
3710 c            gelc(k,j)=gelc(k,j)+ghalf
3711 c          enddo
3712 c 9/28/08 AL Gradient compotents will be summed only at the end
3713           do k=1,3
3714             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3715             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3716           enddo
3717 *
3718 * Loop over residues i+1 thru j-1.
3719 *
3720 cgrad          do k=i+1,j-1
3721 cgrad            do l=1,3
3722 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3723 cgrad            enddo
3724 cgrad          enddo
3725           if (sss.gt.0.0) then
3726           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3727           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3728           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3729           else
3730           ggg(1)=0.0
3731           ggg(2)=0.0
3732           ggg(3)=0.0
3733           endif
3734 c          do k=1,3
3735 c            ghalf=0.5D0*ggg(k)
3736 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3737 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3738 c          enddo
3739 c 9/28/08 AL Gradient compotents will be summed only at the end
3740           do k=1,3
3741             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3742             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3743           enddo
3744 *
3745 * Loop over residues i+1 thru j-1.
3746 *
3747 cgrad          do k=i+1,j-1
3748 cgrad            do l=1,3
3749 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3750 cgrad            enddo
3751 cgrad          enddo
3752 #else
3753 C MARYSIA
3754           facvdw=(ev1+evdwij)*sss
3755           facel=(el1+eesij)
3756           fac1=fac
3757           fac=-3*rrmij*(facvdw+facvdw+facel)
3758           erij(1)=xj*rmij
3759           erij(2)=yj*rmij
3760           erij(3)=zj*rmij
3761 *
3762 * Radial derivatives. First process both termini of the fragment (i,j)
3763 *
3764           ggg(1)=fac*xj
3765           ggg(2)=fac*yj
3766           ggg(3)=fac*zj
3767 c          do k=1,3
3768 c            ghalf=0.5D0*ggg(k)
3769 c            gelc(k,i)=gelc(k,i)+ghalf
3770 c            gelc(k,j)=gelc(k,j)+ghalf
3771 c          enddo
3772 c 9/28/08 AL Gradient compotents will be summed only at the end
3773           do k=1,3
3774             gelc_long(k,j)=gelc(k,j)+ggg(k)
3775             gelc_long(k,i)=gelc(k,i)-ggg(k)
3776           enddo
3777 *
3778 * Loop over residues i+1 thru j-1.
3779 *
3780 cgrad          do k=i+1,j-1
3781 cgrad            do l=1,3
3782 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3783 cgrad            enddo
3784 cgrad          enddo
3785 c 9/28/08 AL Gradient compotents will be summed only at the end
3786           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3787           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3788           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3789           do k=1,3
3790             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3791             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3792           enddo
3793 #endif
3794 *
3795 * Angular part
3796 *
3797           ecosa=2.0D0*fac3*fac1+fac4
3798           fac4=-3.0D0*fac4
3799           fac3=-6.0D0*fac3
3800           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3801           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3802           do k=1,3
3803             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3804             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3805           enddo
3806 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3807 cd   &          (dcosg(k),k=1,3)
3808           do k=1,3
3809             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3810           enddo
3811 c          do k=1,3
3812 c            ghalf=0.5D0*ggg(k)
3813 c            gelc(k,i)=gelc(k,i)+ghalf
3814 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3815 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3816 c            gelc(k,j)=gelc(k,j)+ghalf
3817 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3818 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3819 c          enddo
3820 cgrad          do k=i+1,j-1
3821 cgrad            do l=1,3
3822 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3823 cgrad            enddo
3824 cgrad          enddo
3825           do k=1,3
3826             gelc(k,i)=gelc(k,i)
3827      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3828      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3829             gelc(k,j)=gelc(k,j)
3830      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3831      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3832             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3833             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3834           enddo
3835 C MARYSIA
3836 c          endif !sscale
3837           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3838      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3839      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3840 C
3841 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3842 C   energy of a peptide unit is assumed in the form of a second-order
3843 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3844 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3845 C   are computed for EVERY pair of non-contiguous peptide groups.
3846 C
3847
3848           if (j.lt.nres-1) then
3849             j1=j+1
3850             j2=j-1
3851           else
3852             j1=j-1
3853             j2=j-2
3854           endif
3855           kkk=0
3856           lll=0
3857           do k=1,2
3858             do l=1,2
3859               kkk=kkk+1
3860               muij(kkk)=mu(k,i)*mu(l,j)
3861 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3862 #ifdef NEWCORR
3863              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3864 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3865              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3866              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3867 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3868              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3869 #endif
3870             enddo
3871           enddo
3872 cd         write (iout,*) 'EELEC: i',i,' j',j
3873 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3874 cd          write(iout,*) 'muij',muij
3875           ury=scalar(uy(1,i),erij)
3876           urz=scalar(uz(1,i),erij)
3877           vry=scalar(uy(1,j),erij)
3878           vrz=scalar(uz(1,j),erij)
3879           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3880           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3881           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3882           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3883           fac=dsqrt(-ael6i)*r3ij
3884           a22=a22*fac
3885           a23=a23*fac
3886           a32=a32*fac
3887           a33=a33*fac
3888 cd          write (iout,'(4i5,4f10.5)')
3889 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3890 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3891 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3892 cd     &      uy(:,j),uz(:,j)
3893 cd          write (iout,'(4f10.5)')
3894 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3895 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3896 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3897 cd           write (iout,'(9f10.5/)')
3898 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3899 C Derivatives of the elements of A in virtual-bond vectors
3900           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3901           do k=1,3
3902             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3903             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3904             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3905             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3906             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3907             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3908             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3909             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3910             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3911             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3912             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3913             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3914           enddo
3915 C Compute radial contributions to the gradient
3916           facr=-3.0d0*rrmij
3917           a22der=a22*facr
3918           a23der=a23*facr
3919           a32der=a32*facr
3920           a33der=a33*facr
3921           agg(1,1)=a22der*xj
3922           agg(2,1)=a22der*yj
3923           agg(3,1)=a22der*zj
3924           agg(1,2)=a23der*xj
3925           agg(2,2)=a23der*yj
3926           agg(3,2)=a23der*zj
3927           agg(1,3)=a32der*xj
3928           agg(2,3)=a32der*yj
3929           agg(3,3)=a32der*zj
3930           agg(1,4)=a33der*xj
3931           agg(2,4)=a33der*yj
3932           agg(3,4)=a33der*zj
3933 C Add the contributions coming from er
3934           fac3=-3.0d0*fac
3935           do k=1,3
3936             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3937             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3938             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3939             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3940           enddo
3941           do k=1,3
3942 C Derivatives in DC(i)
3943 cgrad            ghalf1=0.5d0*agg(k,1)
3944 cgrad            ghalf2=0.5d0*agg(k,2)
3945 cgrad            ghalf3=0.5d0*agg(k,3)
3946 cgrad            ghalf4=0.5d0*agg(k,4)
3947             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3948      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3949             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3950      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3951             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3952      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3953             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3954      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3955 C Derivatives in DC(i+1)
3956             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3957      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3958             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3959      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3960             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3961      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3962             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3963      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3964 C Derivatives in DC(j)
3965             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3966      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3967             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3968      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3969             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3970      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3971             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3972      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3973 C Derivatives in DC(j+1) or DC(nres-1)
3974             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3975      &      -3.0d0*vryg(k,3)*ury)
3976             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3977      &      -3.0d0*vrzg(k,3)*ury)
3978             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3979      &      -3.0d0*vryg(k,3)*urz)
3980             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3981      &      -3.0d0*vrzg(k,3)*urz)
3982 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3983 cgrad              do l=1,4
3984 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3985 cgrad              enddo
3986 cgrad            endif
3987           enddo
3988           acipa(1,1)=a22
3989           acipa(1,2)=a23
3990           acipa(2,1)=a32
3991           acipa(2,2)=a33
3992           a22=-a22
3993           a23=-a23
3994           do l=1,2
3995             do k=1,3
3996               agg(k,l)=-agg(k,l)
3997               aggi(k,l)=-aggi(k,l)
3998               aggi1(k,l)=-aggi1(k,l)
3999               aggj(k,l)=-aggj(k,l)
4000               aggj1(k,l)=-aggj1(k,l)
4001             enddo
4002           enddo
4003           if (j.lt.nres-1) then
4004             a22=-a22
4005             a32=-a32
4006             do l=1,3,2
4007               do k=1,3
4008                 agg(k,l)=-agg(k,l)
4009                 aggi(k,l)=-aggi(k,l)
4010                 aggi1(k,l)=-aggi1(k,l)
4011                 aggj(k,l)=-aggj(k,l)
4012                 aggj1(k,l)=-aggj1(k,l)
4013               enddo
4014             enddo
4015           else
4016             a22=-a22
4017             a23=-a23
4018             a32=-a32
4019             a33=-a33
4020             do l=1,4
4021               do k=1,3
4022                 agg(k,l)=-agg(k,l)
4023                 aggi(k,l)=-aggi(k,l)
4024                 aggi1(k,l)=-aggi1(k,l)
4025                 aggj(k,l)=-aggj(k,l)
4026                 aggj1(k,l)=-aggj1(k,l)
4027               enddo
4028             enddo
4029           endif
4030           ENDIF ! WCORR
4031           IF (wel_loc.gt.0.0d0) THEN
4032 C Contribution to the local-electrostatic energy coming from the i-j pair
4033           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4034      &     +a33*muij(4)
4035 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4036 c     &                     ' eel_loc_ij',eel_loc_ij
4037 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4038 C Calculate patrial derivative for theta angle
4039 #ifdef NEWCORR
4040          geel_loc_ij=a22*gmuij1(1)
4041      &     +a23*gmuij1(2)
4042      &     +a32*gmuij1(3)
4043      &     +a33*gmuij1(4)
4044 c         write(iout,*) "derivative over thatai"
4045 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4046 c     &   a33*gmuij1(4)
4047          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4048      &      geel_loc_ij*wel_loc
4049 c         write(iout,*) "derivative over thatai-1"
4050 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4051 c     &   a33*gmuij2(4)
4052          geel_loc_ij=
4053      &     a22*gmuij2(1)
4054      &     +a23*gmuij2(2)
4055      &     +a32*gmuij2(3)
4056      &     +a33*gmuij2(4)
4057          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4058      &      geel_loc_ij*wel_loc
4059 c  Derivative over j residue
4060          geel_loc_ji=a22*gmuji1(1)
4061      &     +a23*gmuji1(2)
4062      &     +a32*gmuji1(3)
4063      &     +a33*gmuji1(4)
4064 c         write(iout,*) "derivative over thataj"
4065 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4066 c     &   a33*gmuji1(4)
4067
4068         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4069      &      geel_loc_ji*wel_loc
4070          geel_loc_ji=
4071      &     +a22*gmuji2(1)
4072      &     +a23*gmuji2(2)
4073      &     +a32*gmuji2(3)
4074      &     +a33*gmuji2(4)
4075 c         write(iout,*) "derivative over thataj-1"
4076 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4077 c     &   a33*gmuji2(4)
4078          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4079      &      geel_loc_ji*wel_loc
4080 #endif
4081 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4082
4083           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4084      &            'eelloc',i,j,eel_loc_ij
4085 c           if (eel_loc_ij.ne.0)
4086 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4087 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4088
4089           eel_loc=eel_loc+eel_loc_ij
4090 C Partial derivatives in virtual-bond dihedral angles gamma
4091           if (i.gt.1)
4092      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4093      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4094      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4095           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4096      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4097      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4098 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4099           do l=1,3
4100             ggg(l)=agg(l,1)*muij(1)+
4101      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4102             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4103             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4104 cgrad            ghalf=0.5d0*ggg(l)
4105 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4106 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4107           enddo
4108 cgrad          do k=i+1,j2
4109 cgrad            do l=1,3
4110 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4111 cgrad            enddo
4112 cgrad          enddo
4113 C Remaining derivatives of eello
4114           do l=1,3
4115             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4116      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4117             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4118      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4119             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4120      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4121             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4122      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4123           enddo
4124           ENDIF
4125 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4126 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4127           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4128      &       .and. num_conti.le.maxconts) then
4129 c            write (iout,*) i,j," entered corr"
4130 C
4131 C Calculate the contact function. The ith column of the array JCONT will
4132 C contain the numbers of atoms that make contacts with the atom I (of numbers
4133 C greater than I). The arrays FACONT and GACONT will contain the values of
4134 C the contact function and its derivative.
4135 c           r0ij=1.02D0*rpp(iteli,itelj)
4136 c           r0ij=1.11D0*rpp(iteli,itelj)
4137             r0ij=2.20D0*rpp(iteli,itelj)
4138 c           r0ij=1.55D0*rpp(iteli,itelj)
4139             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4140             if (fcont.gt.0.0D0) then
4141               num_conti=num_conti+1
4142               if (num_conti.gt.maxconts) then
4143                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4144      &                         ' will skip next contacts for this conf.'
4145               else
4146                 jcont_hb(num_conti,i)=j
4147 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4148 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4149                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4150      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4151 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4152 C  terms.
4153                 d_cont(num_conti,i)=rij
4154 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4155 C     --- Electrostatic-interaction matrix ---
4156                 a_chuj(1,1,num_conti,i)=a22
4157                 a_chuj(1,2,num_conti,i)=a23
4158                 a_chuj(2,1,num_conti,i)=a32
4159                 a_chuj(2,2,num_conti,i)=a33
4160 C     --- Gradient of rij
4161                 do kkk=1,3
4162                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4163                 enddo
4164                 kkll=0
4165                 do k=1,2
4166                   do l=1,2
4167                     kkll=kkll+1
4168                     do m=1,3
4169                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4170                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4171                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4172                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4173                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4174                     enddo
4175                   enddo
4176                 enddo
4177                 ENDIF
4178                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4179 C Calculate contact energies
4180                 cosa4=4.0D0*cosa
4181                 wij=cosa-3.0D0*cosb*cosg
4182                 cosbg1=cosb+cosg
4183                 cosbg2=cosb-cosg
4184 c               fac3=dsqrt(-ael6i)/r0ij**3
4185                 fac3=dsqrt(-ael6i)*r3ij
4186 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4187                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4188                 if (ees0tmp.gt.0) then
4189                   ees0pij=dsqrt(ees0tmp)
4190                 else
4191                   ees0pij=0
4192                 endif
4193 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4194                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4195                 if (ees0tmp.gt.0) then
4196                   ees0mij=dsqrt(ees0tmp)
4197                 else
4198                   ees0mij=0
4199                 endif
4200 c               ees0mij=0.0D0
4201                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4202                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4203 C Diagnostics. Comment out or remove after debugging!
4204 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4205 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4206 c               ees0m(num_conti,i)=0.0D0
4207 C End diagnostics.
4208 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4209 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4210 C Angular derivatives of the contact function
4211                 ees0pij1=fac3/ees0pij
4212                 ees0mij1=fac3/ees0mij
4213                 fac3p=-3.0D0*fac3*rrmij
4214                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4215                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4216 c               ees0mij1=0.0D0
4217                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4218                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4219                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4220                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4221                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4222                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4223                 ecosap=ecosa1+ecosa2
4224                 ecosbp=ecosb1+ecosb2
4225                 ecosgp=ecosg1+ecosg2
4226                 ecosam=ecosa1-ecosa2
4227                 ecosbm=ecosb1-ecosb2
4228                 ecosgm=ecosg1-ecosg2
4229 C Diagnostics
4230 c               ecosap=ecosa1
4231 c               ecosbp=ecosb1
4232 c               ecosgp=ecosg1
4233 c               ecosam=0.0D0
4234 c               ecosbm=0.0D0
4235 c               ecosgm=0.0D0
4236 C End diagnostics
4237                 facont_hb(num_conti,i)=fcont
4238                 fprimcont=fprimcont/rij
4239 cd              facont_hb(num_conti,i)=1.0D0
4240 C Following line is for diagnostics.
4241 cd              fprimcont=0.0D0
4242                 do k=1,3
4243                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4244                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4245                 enddo
4246                 do k=1,3
4247                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4248                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4249                 enddo
4250                 gggp(1)=gggp(1)+ees0pijp*xj
4251                 gggp(2)=gggp(2)+ees0pijp*yj
4252                 gggp(3)=gggp(3)+ees0pijp*zj
4253                 gggm(1)=gggm(1)+ees0mijp*xj
4254                 gggm(2)=gggm(2)+ees0mijp*yj
4255                 gggm(3)=gggm(3)+ees0mijp*zj
4256 C Derivatives due to the contact function
4257                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4258                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4259                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4260                 do k=1,3
4261 c
4262 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4263 c          following the change of gradient-summation algorithm.
4264 c
4265 cgrad                  ghalfp=0.5D0*gggp(k)
4266 cgrad                  ghalfm=0.5D0*gggm(k)
4267                   gacontp_hb1(k,num_conti,i)=!ghalfp
4268      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4269      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4270                   gacontp_hb2(k,num_conti,i)=!ghalfp
4271      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4272      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4273                   gacontp_hb3(k,num_conti,i)=gggp(k)
4274                   gacontm_hb1(k,num_conti,i)=!ghalfm
4275      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4276      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4277                   gacontm_hb2(k,num_conti,i)=!ghalfm
4278      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4279      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4280                   gacontm_hb3(k,num_conti,i)=gggm(k)
4281                 enddo
4282 C Diagnostics. Comment out or remove after debugging!
4283 cdiag           do k=1,3
4284 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4285 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4286 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4287 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4288 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4289 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4290 cdiag           enddo
4291               ENDIF ! wcorr
4292               endif  ! num_conti.le.maxconts
4293             endif  ! fcont.gt.0
4294           endif    ! j.gt.i+1
4295           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4296             do k=1,4
4297               do l=1,3
4298                 ghalf=0.5d0*agg(l,k)
4299                 aggi(l,k)=aggi(l,k)+ghalf
4300                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4301                 aggj(l,k)=aggj(l,k)+ghalf
4302               enddo
4303             enddo
4304             if (j.eq.nres-1 .and. i.lt.j-2) then
4305               do k=1,4
4306                 do l=1,3
4307                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4308                 enddo
4309               enddo
4310             endif
4311           endif
4312 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4313       return
4314       end
4315 C-----------------------------------------------------------------------------
4316       subroutine eturn3(i,eello_turn3)
4317 C Third- and fourth-order contributions from turns
4318       implicit real*8 (a-h,o-z)
4319       include 'DIMENSIONS'
4320       include 'COMMON.IOUNITS'
4321       include 'COMMON.GEO'
4322       include 'COMMON.VAR'
4323       include 'COMMON.LOCAL'
4324       include 'COMMON.CHAIN'
4325       include 'COMMON.DERIV'
4326       include 'COMMON.INTERACT'
4327       include 'COMMON.CONTACTS'
4328       include 'COMMON.TORSION'
4329       include 'COMMON.VECTORS'
4330       include 'COMMON.FFIELD'
4331       include 'COMMON.CONTROL'
4332       dimension ggg(3)
4333       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4334      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4335      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4336      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4337      &  auxgmat2(2,2),auxgmatt2(2,2)
4338       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4339      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4340       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4341      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4342      &    num_conti,j1,j2
4343       j=i+2
4344 c      write (iout,*) "eturn3",i,j,j1,j2
4345       a_temp(1,1)=a22
4346       a_temp(1,2)=a23
4347       a_temp(2,1)=a32
4348       a_temp(2,2)=a33
4349 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4350 C
4351 C               Third-order contributions
4352 C
4353 C                 (i+2)o----(i+3)
4354 C                      | |
4355 C                      | |
4356 C                 (i+1)o----i
4357 C
4358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4359 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4360         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4361 c auxalary matices for theta gradient
4362 c auxalary matrix for i+1 and constant i+2
4363         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4364 c auxalary matrix for i+2 and constant i+1
4365         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4366         call transpose2(auxmat(1,1),auxmat1(1,1))
4367         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4368         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4369         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4370         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4371         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4372         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4373 C Derivatives in theta
4374         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4375      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4376         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4377      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4378
4379         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4380      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4381 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4382 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4383 cd     &    ' eello_turn3_num',4*eello_turn3_num
4384 C Derivatives in gamma(i)
4385         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4386         call transpose2(auxmat2(1,1),auxmat3(1,1))
4387         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4388         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4389 C Derivatives in gamma(i+1)
4390         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4391         call transpose2(auxmat2(1,1),auxmat3(1,1))
4392         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4393         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4394      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4395 C Cartesian derivatives
4396 !DIR$ UNROLL(0)
4397         do l=1,3
4398 c            ghalf1=0.5d0*agg(l,1)
4399 c            ghalf2=0.5d0*agg(l,2)
4400 c            ghalf3=0.5d0*agg(l,3)
4401 c            ghalf4=0.5d0*agg(l,4)
4402           a_temp(1,1)=aggi(l,1)!+ghalf1
4403           a_temp(1,2)=aggi(l,2)!+ghalf2
4404           a_temp(2,1)=aggi(l,3)!+ghalf3
4405           a_temp(2,2)=aggi(l,4)!+ghalf4
4406           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4407           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4408      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4409           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4410           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4411           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4412           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4413           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4414           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4415      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4416           a_temp(1,1)=aggj(l,1)!+ghalf1
4417           a_temp(1,2)=aggj(l,2)!+ghalf2
4418           a_temp(2,1)=aggj(l,3)!+ghalf3
4419           a_temp(2,2)=aggj(l,4)!+ghalf4
4420           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4421           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4422      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4423           a_temp(1,1)=aggj1(l,1)
4424           a_temp(1,2)=aggj1(l,2)
4425           a_temp(2,1)=aggj1(l,3)
4426           a_temp(2,2)=aggj1(l,4)
4427           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4428           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4429      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4430         enddo
4431       return
4432       end
4433 C-------------------------------------------------------------------------------
4434       subroutine eturn4(i,eello_turn4)
4435 C Third- and fourth-order contributions from turns
4436       implicit real*8 (a-h,o-z)
4437       include 'DIMENSIONS'
4438       include 'COMMON.IOUNITS'
4439       include 'COMMON.GEO'
4440       include 'COMMON.VAR'
4441       include 'COMMON.LOCAL'
4442       include 'COMMON.CHAIN'
4443       include 'COMMON.DERIV'
4444       include 'COMMON.INTERACT'
4445       include 'COMMON.CONTACTS'
4446       include 'COMMON.TORSION'
4447       include 'COMMON.VECTORS'
4448       include 'COMMON.FFIELD'
4449       include 'COMMON.CONTROL'
4450       dimension ggg(3)
4451       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4452      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4453      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4454      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4455      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4456      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4457      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4458       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4459      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4460       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4461      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4462      &    num_conti,j1,j2
4463       j=i+3
4464 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4465 C
4466 C               Fourth-order contributions
4467 C
4468 C                 (i+3)o----(i+4)
4469 C                     /  |
4470 C               (i+2)o   |
4471 C                     \  |
4472 C                 (i+1)o----i
4473 C
4474 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4475 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4476 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4477 c        write(iout,*)"WCHODZE W PROGRAM"
4478         a_temp(1,1)=a22
4479         a_temp(1,2)=a23
4480         a_temp(2,1)=a32
4481         a_temp(2,2)=a33
4482         iti1=itortyp(itype(i+1))
4483         iti2=itortyp(itype(i+2))
4484         iti3=itortyp(itype(i+3))
4485 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4486         call transpose2(EUg(1,1,i+1),e1t(1,1))
4487         call transpose2(Eug(1,1,i+2),e2t(1,1))
4488         call transpose2(Eug(1,1,i+3),e3t(1,1))
4489 C Ematrix derivative in theta
4490         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4491         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4492         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4493         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4494 c       eta1 in derivative theta
4495         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4496         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4497 c       auxgvec is derivative of Ub2 so i+3 theta
4498         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4499 c       auxalary matrix of E i+1
4500         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4501 c        s1=0.0
4502 c        gs1=0.0
4503         s1=scalar2(b1(1,i+2),auxvec(1))
4504 c derivative of theta i+2 with constant i+3
4505         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4506 c derivative of theta i+2 with constant i+2
4507         gs32=scalar2(b1(1,i+2),auxgvec(1))
4508 c derivative of E matix in theta of i+1
4509         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4510
4511         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4512 c       ea31 in derivative theta
4513         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4514         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4515 c auxilary matrix auxgvec of Ub2 with constant E matirx
4516         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4517 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4518         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4519
4520 c        s2=0.0
4521 c        gs2=0.0
4522         s2=scalar2(b1(1,i+1),auxvec(1))
4523 c derivative of theta i+1 with constant i+3
4524         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4525 c derivative of theta i+2 with constant i+1
4526         gs21=scalar2(b1(1,i+1),auxgvec(1))
4527 c derivative of theta i+3 with constant i+1
4528         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4529 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4530 c     &  gtb1(1,i+1)
4531         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4532 c two derivatives over diffetent matrices
4533 c gtae3e2 is derivative over i+3
4534         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4535 c ae3gte2 is derivative over i+2
4536         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4537         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4538 c three possible derivative over theta E matices
4539 c i+1
4540         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4541 c i+2
4542         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4543 c i+3
4544         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4545         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4546
4547         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4548         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4549         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4550
4551         eello_turn4=eello_turn4-(s1+s2+s3)
4552 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4553 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4554 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4555 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4556 cd     &    ' eello_turn4_num',8*eello_turn4_num
4557 #ifdef NEWCORR
4558         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4559      &                  -(gs13+gsE13+gsEE1)*wturn4
4560         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4561      &                    -(gs23+gs21+gsEE2)*wturn4
4562         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4563      &                    -(gs32+gsE31+gsEE3)*wturn4
4564 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4565 c     &   gs2
4566 #endif
4567         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4568      &      'eturn4',i,j,-(s1+s2+s3)
4569 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4570 c     &    ' eello_turn4_num',8*eello_turn4_num
4571 C Derivatives in gamma(i)
4572         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4573         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4574         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4575         s1=scalar2(b1(1,i+2),auxvec(1))
4576         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4577         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4578         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4579 C Derivatives in gamma(i+1)
4580         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4581         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4582         s2=scalar2(b1(1,i+1),auxvec(1))
4583         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4584         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4585         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4586         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4587 C Derivatives in gamma(i+2)
4588         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4589         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4590         s1=scalar2(b1(1,i+2),auxvec(1))
4591         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4592         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4593         s2=scalar2(b1(1,i+1),auxvec(1))
4594         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4595         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4596         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4597         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4598 C Cartesian derivatives
4599 C Derivatives of this turn contributions in DC(i+2)
4600         if (j.lt.nres-1) then
4601           do l=1,3
4602             a_temp(1,1)=agg(l,1)
4603             a_temp(1,2)=agg(l,2)
4604             a_temp(2,1)=agg(l,3)
4605             a_temp(2,2)=agg(l,4)
4606             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4607             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4608             s1=scalar2(b1(1,i+2),auxvec(1))
4609             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4610             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4611             s2=scalar2(b1(1,i+1),auxvec(1))
4612             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4613             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4614             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4615             ggg(l)=-(s1+s2+s3)
4616             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4617           enddo
4618         endif
4619 C Remaining derivatives of this turn contribution
4620         do l=1,3
4621           a_temp(1,1)=aggi(l,1)
4622           a_temp(1,2)=aggi(l,2)
4623           a_temp(2,1)=aggi(l,3)
4624           a_temp(2,2)=aggi(l,4)
4625           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4626           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4627           s1=scalar2(b1(1,i+2),auxvec(1))
4628           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4629           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4630           s2=scalar2(b1(1,i+1),auxvec(1))
4631           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4632           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4633           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4634           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4635           a_temp(1,1)=aggi1(l,1)
4636           a_temp(1,2)=aggi1(l,2)
4637           a_temp(2,1)=aggi1(l,3)
4638           a_temp(2,2)=aggi1(l,4)
4639           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4640           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4641           s1=scalar2(b1(1,i+2),auxvec(1))
4642           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4643           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4644           s2=scalar2(b1(1,i+1),auxvec(1))
4645           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4646           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4647           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4648           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4649           a_temp(1,1)=aggj(l,1)
4650           a_temp(1,2)=aggj(l,2)
4651           a_temp(2,1)=aggj(l,3)
4652           a_temp(2,2)=aggj(l,4)
4653           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4654           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4655           s1=scalar2(b1(1,i+2),auxvec(1))
4656           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4657           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4658           s2=scalar2(b1(1,i+1),auxvec(1))
4659           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4660           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4661           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4662           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4663           a_temp(1,1)=aggj1(l,1)
4664           a_temp(1,2)=aggj1(l,2)
4665           a_temp(2,1)=aggj1(l,3)
4666           a_temp(2,2)=aggj1(l,4)
4667           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4668           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4669           s1=scalar2(b1(1,i+2),auxvec(1))
4670           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4671           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4672           s2=scalar2(b1(1,i+1),auxvec(1))
4673           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4674           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4675           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4676 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4677           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4678         enddo
4679       return
4680       end
4681 C-----------------------------------------------------------------------------
4682       subroutine vecpr(u,v,w)
4683       implicit real*8(a-h,o-z)
4684       dimension u(3),v(3),w(3)
4685       w(1)=u(2)*v(3)-u(3)*v(2)
4686       w(2)=-u(1)*v(3)+u(3)*v(1)
4687       w(3)=u(1)*v(2)-u(2)*v(1)
4688       return
4689       end
4690 C-----------------------------------------------------------------------------
4691       subroutine unormderiv(u,ugrad,unorm,ungrad)
4692 C This subroutine computes the derivatives of a normalized vector u, given
4693 C the derivatives computed without normalization conditions, ugrad. Returns
4694 C ungrad.
4695       implicit none
4696       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4697       double precision vec(3)
4698       double precision scalar
4699       integer i,j
4700 c      write (2,*) 'ugrad',ugrad
4701 c      write (2,*) 'u',u
4702       do i=1,3
4703         vec(i)=scalar(ugrad(1,i),u(1))
4704       enddo
4705 c      write (2,*) 'vec',vec
4706       do i=1,3
4707         do j=1,3
4708           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4709         enddo
4710       enddo
4711 c      write (2,*) 'ungrad',ungrad
4712       return
4713       end
4714 C-----------------------------------------------------------------------------
4715       subroutine escp_soft_sphere(evdw2,evdw2_14)
4716 C
4717 C This subroutine calculates the excluded-volume interaction energy between
4718 C peptide-group centers and side chains and its gradient in virtual-bond and
4719 C side-chain vectors.
4720 C
4721       implicit real*8 (a-h,o-z)
4722       include 'DIMENSIONS'
4723       include 'COMMON.GEO'
4724       include 'COMMON.VAR'
4725       include 'COMMON.LOCAL'
4726       include 'COMMON.CHAIN'
4727       include 'COMMON.DERIV'
4728       include 'COMMON.INTERACT'
4729       include 'COMMON.FFIELD'
4730       include 'COMMON.IOUNITS'
4731       include 'COMMON.CONTROL'
4732       dimension ggg(3)
4733       evdw2=0.0D0
4734       evdw2_14=0.0d0
4735       r0_scp=4.5d0
4736 cd    print '(a)','Enter ESCP'
4737 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4738 C      do xshift=-1,1
4739 C      do yshift=-1,1
4740 C      do zshift=-1,1
4741       do i=iatscp_s,iatscp_e
4742         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4743         iteli=itel(i)
4744         xi=0.5D0*(c(1,i)+c(1,i+1))
4745         yi=0.5D0*(c(2,i)+c(2,i+1))
4746         zi=0.5D0*(c(3,i)+c(3,i+1))
4747 C Return atom into box, boxxsize is size of box in x dimension
4748 c  134   continue
4749 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4750 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4751 C Condition for being inside the proper box
4752 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4753 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4754 c        go to 134
4755 c        endif
4756 c  135   continue
4757 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4758 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4759 C Condition for being inside the proper box
4760 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4761 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4762 c        go to 135
4763 c c       endif
4764 c  136   continue
4765 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4766 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4767 cC Condition for being inside the proper box
4768 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4769 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4770 c        go to 136
4771 c        endif
4772           xi=mod(xi,boxxsize)
4773           if (xi.lt.0) xi=xi+boxxsize
4774           yi=mod(yi,boxysize)
4775           if (yi.lt.0) yi=yi+boxysize
4776           zi=mod(zi,boxzsize)
4777           if (zi.lt.0) zi=zi+boxzsize
4778 C          xi=xi+xshift*boxxsize
4779 C          yi=yi+yshift*boxysize
4780 C          zi=zi+zshift*boxzsize
4781         do iint=1,nscp_gr(i)
4782
4783         do j=iscpstart(i,iint),iscpend(i,iint)
4784           if (itype(j).eq.ntyp1) cycle
4785           itypj=iabs(itype(j))
4786 C Uncomment following three lines for SC-p interactions
4787 c         xj=c(1,nres+j)-xi
4788 c         yj=c(2,nres+j)-yi
4789 c         zj=c(3,nres+j)-zi
4790 C Uncomment following three lines for Ca-p interactions
4791           xj=c(1,j)
4792           yj=c(2,j)
4793           zj=c(3,j)
4794 c  174   continue
4795 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4796 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4797 C Condition for being inside the proper box
4798 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4799 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4800 c        go to 174
4801 c        endif
4802 c  175   continue
4803 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4804 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4805 cC Condition for being inside the proper box
4806 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4807 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4808 c        go to 175
4809 c        endif
4810 c  176   continue
4811 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4812 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4813 C Condition for being inside the proper box
4814 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4815 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4816 c        go to 176
4817           xj=mod(xj,boxxsize)
4818           if (xj.lt.0) xj=xj+boxxsize
4819           yj=mod(yj,boxysize)
4820           if (yj.lt.0) yj=yj+boxysize
4821           zj=mod(zj,boxzsize)
4822           if (zj.lt.0) zj=zj+boxzsize
4823       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4824       xj_safe=xj
4825       yj_safe=yj
4826       zj_safe=zj
4827       subchap=0
4828       do xshift=-1,1
4829       do yshift=-1,1
4830       do zshift=-1,1
4831           xj=xj_safe+xshift*boxxsize
4832           yj=yj_safe+yshift*boxysize
4833           zj=zj_safe+zshift*boxzsize
4834           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4835           if(dist_temp.lt.dist_init) then
4836             dist_init=dist_temp
4837             xj_temp=xj
4838             yj_temp=yj
4839             zj_temp=zj
4840             subchap=1
4841           endif
4842        enddo
4843        enddo
4844        enddo
4845        if (subchap.eq.1) then
4846           xj=xj_temp-xi
4847           yj=yj_temp-yi
4848           zj=zj_temp-zi
4849        else
4850           xj=xj_safe-xi
4851           yj=yj_safe-yi
4852           zj=zj_safe-zi
4853        endif
4854 c c       endif
4855 C          xj=xj-xi
4856 C          yj=yj-yi
4857 C          zj=zj-zi
4858           rij=xj*xj+yj*yj+zj*zj
4859
4860           r0ij=r0_scp
4861           r0ijsq=r0ij*r0ij
4862           if (rij.lt.r0ijsq) then
4863             evdwij=0.25d0*(rij-r0ijsq)**2
4864             fac=rij-r0ijsq
4865           else
4866             evdwij=0.0d0
4867             fac=0.0d0
4868           endif
4869           evdw2=evdw2+evdwij
4870 C
4871 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4872 C
4873           ggg(1)=xj*fac
4874           ggg(2)=yj*fac
4875           ggg(3)=zj*fac
4876 cgrad          if (j.lt.i) then
4877 cd          write (iout,*) 'j<i'
4878 C Uncomment following three lines for SC-p interactions
4879 c           do k=1,3
4880 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4881 c           enddo
4882 cgrad          else
4883 cd          write (iout,*) 'j>i'
4884 cgrad            do k=1,3
4885 cgrad              ggg(k)=-ggg(k)
4886 C Uncomment following line for SC-p interactions
4887 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4888 cgrad            enddo
4889 cgrad          endif
4890 cgrad          do k=1,3
4891 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4892 cgrad          enddo
4893 cgrad          kstart=min0(i+1,j)
4894 cgrad          kend=max0(i-1,j-1)
4895 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4896 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4897 cgrad          do k=kstart,kend
4898 cgrad            do l=1,3
4899 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4900 cgrad            enddo
4901 cgrad          enddo
4902           do k=1,3
4903             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4904             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4905           enddo
4906         enddo
4907
4908         enddo ! iint
4909       enddo ! i
4910 C      enddo !zshift
4911 C      enddo !yshift
4912 C      enddo !xshift
4913       return
4914       end
4915 C-----------------------------------------------------------------------------
4916       subroutine escp(evdw2,evdw2_14)
4917 C
4918 C This subroutine calculates the excluded-volume interaction energy between
4919 C peptide-group centers and side chains and its gradient in virtual-bond and
4920 C side-chain vectors.
4921 C
4922       implicit real*8 (a-h,o-z)
4923       include 'DIMENSIONS'
4924       include 'COMMON.GEO'
4925       include 'COMMON.VAR'
4926       include 'COMMON.LOCAL'
4927       include 'COMMON.CHAIN'
4928       include 'COMMON.DERIV'
4929       include 'COMMON.INTERACT'
4930       include 'COMMON.FFIELD'
4931       include 'COMMON.IOUNITS'
4932       include 'COMMON.CONTROL'
4933       include 'COMMON.SPLITELE'
4934       dimension ggg(3)
4935       evdw2=0.0D0
4936       evdw2_14=0.0d0
4937 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4938 cd    print '(a)','Enter ESCP'
4939 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4940 C      do xshift=-1,1
4941 C      do yshift=-1,1
4942 C      do zshift=-1,1
4943       do i=iatscp_s,iatscp_e
4944         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4945         iteli=itel(i)
4946         xi=0.5D0*(c(1,i)+c(1,i+1))
4947         yi=0.5D0*(c(2,i)+c(2,i+1))
4948         zi=0.5D0*(c(3,i)+c(3,i+1))
4949           xi=mod(xi,boxxsize)
4950           if (xi.lt.0) xi=xi+boxxsize
4951           yi=mod(yi,boxysize)
4952           if (yi.lt.0) yi=yi+boxysize
4953           zi=mod(zi,boxzsize)
4954           if (zi.lt.0) zi=zi+boxzsize
4955 c          xi=xi+xshift*boxxsize
4956 c          yi=yi+yshift*boxysize
4957 c          zi=zi+zshift*boxzsize
4958 c        print *,xi,yi,zi,'polozenie i'
4959 C Return atom into box, boxxsize is size of box in x dimension
4960 c  134   continue
4961 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4962 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4963 C Condition for being inside the proper box
4964 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4965 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4966 c        go to 134
4967 c        endif
4968 c  135   continue
4969 c          print *,xi,boxxsize,"pierwszy"
4970
4971 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4972 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4973 C Condition for being inside the proper box
4974 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4975 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4976 c        go to 135
4977 c        endif
4978 c  136   continue
4979 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4980 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4981 C Condition for being inside the proper box
4982 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4983 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4984 c        go to 136
4985 c        endif
4986         do iint=1,nscp_gr(i)
4987
4988         do j=iscpstart(i,iint),iscpend(i,iint)
4989           itypj=iabs(itype(j))
4990           if (itypj.eq.ntyp1) cycle
4991 C Uncomment following three lines for SC-p interactions
4992 c         xj=c(1,nres+j)-xi
4993 c         yj=c(2,nres+j)-yi
4994 c         zj=c(3,nres+j)-zi
4995 C Uncomment following three lines for Ca-p interactions
4996           xj=c(1,j)
4997           yj=c(2,j)
4998           zj=c(3,j)
4999           xj=mod(xj,boxxsize)
5000           if (xj.lt.0) xj=xj+boxxsize
5001           yj=mod(yj,boxysize)
5002           if (yj.lt.0) yj=yj+boxysize
5003           zj=mod(zj,boxzsize)
5004           if (zj.lt.0) zj=zj+boxzsize
5005 c  174   continue
5006 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5007 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5008 C Condition for being inside the proper box
5009 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5010 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5011 c        go to 174
5012 c        endif
5013 c  175   continue
5014 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5015 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5016 cC Condition for being inside the proper box
5017 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5018 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5019 c        go to 175
5020 c        endif
5021 c  176   continue
5022 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5023 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5024 C Condition for being inside the proper box
5025 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5026 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5027 c        go to 176
5028 c        endif
5029 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5030       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5031       xj_safe=xj
5032       yj_safe=yj
5033       zj_safe=zj
5034       subchap=0
5035       do xshift=-1,1
5036       do yshift=-1,1
5037       do zshift=-1,1
5038           xj=xj_safe+xshift*boxxsize
5039           yj=yj_safe+yshift*boxysize
5040           zj=zj_safe+zshift*boxzsize
5041           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5042           if(dist_temp.lt.dist_init) then
5043             dist_init=dist_temp
5044             xj_temp=xj
5045             yj_temp=yj
5046             zj_temp=zj
5047             subchap=1
5048           endif
5049        enddo
5050        enddo
5051        enddo
5052        if (subchap.eq.1) then
5053           xj=xj_temp-xi
5054           yj=yj_temp-yi
5055           zj=zj_temp-zi
5056        else
5057           xj=xj_safe-xi
5058           yj=yj_safe-yi
5059           zj=zj_safe-zi
5060        endif
5061 c          print *,xj,yj,zj,'polozenie j'
5062           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5063 c          print *,rrij
5064           sss=sscale(1.0d0/(dsqrt(rrij)))
5065 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5066 c          if (sss.eq.0) print *,'czasem jest OK'
5067           if (sss.le.0.0d0) cycle
5068           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5069           fac=rrij**expon2
5070           e1=fac*fac*aad(itypj,iteli)
5071           e2=fac*bad(itypj,iteli)
5072           if (iabs(j-i) .le. 2) then
5073             e1=scal14*e1
5074             e2=scal14*e2
5075             evdw2_14=evdw2_14+(e1+e2)*sss
5076           endif
5077           evdwij=e1+e2
5078           evdw2=evdw2+evdwij*sss
5079           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5080      &        'evdw2',i,j,evdwij
5081 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5082 C
5083 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5084 C
5085           fac=-(evdwij+e1)*rrij*sss
5086           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5087           ggg(1)=xj*fac
5088           ggg(2)=yj*fac
5089           ggg(3)=zj*fac
5090 cgrad          if (j.lt.i) then
5091 cd          write (iout,*) 'j<i'
5092 C Uncomment following three lines for SC-p interactions
5093 c           do k=1,3
5094 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5095 c           enddo
5096 cgrad          else
5097 cd          write (iout,*) 'j>i'
5098 cgrad            do k=1,3
5099 cgrad              ggg(k)=-ggg(k)
5100 C Uncomment following line for SC-p interactions
5101 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5102 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5103 cgrad            enddo
5104 cgrad          endif
5105 cgrad          do k=1,3
5106 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5107 cgrad          enddo
5108 cgrad          kstart=min0(i+1,j)
5109 cgrad          kend=max0(i-1,j-1)
5110 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5111 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5112 cgrad          do k=kstart,kend
5113 cgrad            do l=1,3
5114 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5115 cgrad            enddo
5116 cgrad          enddo
5117           do k=1,3
5118             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5119             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5120           enddo
5121 c        endif !endif for sscale cutoff
5122         enddo ! j
5123
5124         enddo ! iint
5125       enddo ! i
5126 c      enddo !zshift
5127 c      enddo !yshift
5128 c      enddo !xshift
5129       do i=1,nct
5130         do j=1,3
5131           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5132           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5133           gradx_scp(j,i)=expon*gradx_scp(j,i)
5134         enddo
5135       enddo
5136 C******************************************************************************
5137 C
5138 C                              N O T E !!!
5139 C
5140 C To save time the factor EXPON has been extracted from ALL components
5141 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5142 C use!
5143 C
5144 C******************************************************************************
5145       return
5146       end
5147 C--------------------------------------------------------------------------
5148       subroutine edis(ehpb)
5149 C
5150 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5151 C
5152       implicit real*8 (a-h,o-z)
5153       include 'DIMENSIONS'
5154       include 'COMMON.SBRIDGE'
5155       include 'COMMON.CHAIN'
5156       include 'COMMON.DERIV'
5157       include 'COMMON.VAR'
5158       include 'COMMON.INTERACT'
5159       include 'COMMON.IOUNITS'
5160       dimension ggg(3)
5161       ehpb=0.0D0
5162 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5163 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5164       if (link_end.eq.0) return
5165       do i=link_start,link_end
5166 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5167 C CA-CA distance used in regularization of structure.
5168         ii=ihpb(i)
5169         jj=jhpb(i)
5170 C iii and jjj point to the residues for which the distance is assigned.
5171         if (ii.gt.nres) then
5172           iii=ii-nres
5173           jjj=jj-nres
5174         else
5175           iii=ii
5176           jjj=jj
5177         endif
5178 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5179 c     &    dhpb(i),dhpb1(i),forcon(i)
5180 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5181 C    distance and angle dependent SS bond potential.
5182 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5183 C     & iabs(itype(jjj)).eq.1) then
5184 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5185 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5186         if (.not.dyn_ss .and. i.le.nss) then
5187 C 15/02/13 CC dynamic SSbond - additional check
5188          if (ii.gt.nres
5189      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5190           call ssbond_ene(iii,jjj,eij)
5191           ehpb=ehpb+2*eij
5192          endif
5193 cd          write (iout,*) "eij",eij
5194         else
5195 C Calculate the distance between the two points and its difference from the
5196 C target distance.
5197           dd=dist(ii,jj)
5198             rdis=dd-dhpb(i)
5199 C Get the force constant corresponding to this distance.
5200             waga=forcon(i)
5201 C Calculate the contribution to energy.
5202             ehpb=ehpb+waga*rdis*rdis
5203 C
5204 C Evaluate gradient.
5205 C
5206             fac=waga*rdis/dd
5207 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5208 cd   &   ' waga=',waga,' fac=',fac
5209             do j=1,3
5210               ggg(j)=fac*(c(j,jj)-c(j,ii))
5211             enddo
5212 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5213 C If this is a SC-SC distance, we need to calculate the contributions to the
5214 C Cartesian gradient in the SC vectors (ghpbx).
5215           if (iii.lt.ii) then
5216           do j=1,3
5217             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5218             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5219           enddo
5220           endif
5221 cgrad        do j=iii,jjj-1
5222 cgrad          do k=1,3
5223 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5224 cgrad          enddo
5225 cgrad        enddo
5226           do k=1,3
5227             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5228             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5229           enddo
5230         endif
5231       enddo
5232       ehpb=0.5D0*ehpb
5233       return
5234       end
5235 C--------------------------------------------------------------------------
5236       subroutine ssbond_ene(i,j,eij)
5237 C
5238 C Calculate the distance and angle dependent SS-bond potential energy
5239 C using a free-energy function derived based on RHF/6-31G** ab initio
5240 C calculations of diethyl disulfide.
5241 C
5242 C A. Liwo and U. Kozlowska, 11/24/03
5243 C
5244       implicit real*8 (a-h,o-z)
5245       include 'DIMENSIONS'
5246       include 'COMMON.SBRIDGE'
5247       include 'COMMON.CHAIN'
5248       include 'COMMON.DERIV'
5249       include 'COMMON.LOCAL'
5250       include 'COMMON.INTERACT'
5251       include 'COMMON.VAR'
5252       include 'COMMON.IOUNITS'
5253       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5254       itypi=iabs(itype(i))
5255       xi=c(1,nres+i)
5256       yi=c(2,nres+i)
5257       zi=c(3,nres+i)
5258       dxi=dc_norm(1,nres+i)
5259       dyi=dc_norm(2,nres+i)
5260       dzi=dc_norm(3,nres+i)
5261 c      dsci_inv=dsc_inv(itypi)
5262       dsci_inv=vbld_inv(nres+i)
5263       itypj=iabs(itype(j))
5264 c      dscj_inv=dsc_inv(itypj)
5265       dscj_inv=vbld_inv(nres+j)
5266       xj=c(1,nres+j)-xi
5267       yj=c(2,nres+j)-yi
5268       zj=c(3,nres+j)-zi
5269       dxj=dc_norm(1,nres+j)
5270       dyj=dc_norm(2,nres+j)
5271       dzj=dc_norm(3,nres+j)
5272       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5273       rij=dsqrt(rrij)
5274       erij(1)=xj*rij
5275       erij(2)=yj*rij
5276       erij(3)=zj*rij
5277       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5278       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5279       om12=dxi*dxj+dyi*dyj+dzi*dzj
5280       do k=1,3
5281         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5282         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5283       enddo
5284       rij=1.0d0/rij
5285       deltad=rij-d0cm
5286       deltat1=1.0d0-om1
5287       deltat2=1.0d0+om2
5288       deltat12=om2-om1+2.0d0
5289       cosphi=om12-om1*om2
5290       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5291      &  +akct*deltad*deltat12
5292      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5293 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5294 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5295 c     &  " deltat12",deltat12," eij",eij
5296       ed=2*akcm*deltad+akct*deltat12
5297       pom1=akct*deltad
5298       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5299       eom1=-2*akth*deltat1-pom1-om2*pom2
5300       eom2= 2*akth*deltat2+pom1-om1*pom2
5301       eom12=pom2
5302       do k=1,3
5303         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5304         ghpbx(k,i)=ghpbx(k,i)-ggk
5305      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5306      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5307         ghpbx(k,j)=ghpbx(k,j)+ggk
5308      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5309      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5310         ghpbc(k,i)=ghpbc(k,i)-ggk
5311         ghpbc(k,j)=ghpbc(k,j)+ggk
5312       enddo
5313 C
5314 C Calculate the components of the gradient in DC and X
5315 C
5316 cgrad      do k=i,j-1
5317 cgrad        do l=1,3
5318 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5319 cgrad        enddo
5320 cgrad      enddo
5321       return
5322       end
5323 C--------------------------------------------------------------------------
5324       subroutine ebond(estr)
5325 c
5326 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5327 c
5328       implicit real*8 (a-h,o-z)
5329       include 'DIMENSIONS'
5330       include 'COMMON.LOCAL'
5331       include 'COMMON.GEO'
5332       include 'COMMON.INTERACT'
5333       include 'COMMON.DERIV'
5334       include 'COMMON.VAR'
5335       include 'COMMON.CHAIN'
5336       include 'COMMON.IOUNITS'
5337       include 'COMMON.NAMES'
5338       include 'COMMON.FFIELD'
5339       include 'COMMON.CONTROL'
5340       include 'COMMON.SETUP'
5341       double precision u(3),ud(3)
5342       estr=0.0d0
5343       estr1=0.0d0
5344       do i=ibondp_start,ibondp_end
5345         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5346 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5347 c          do j=1,3
5348 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5349 c     &      *dc(j,i-1)/vbld(i)
5350 c          enddo
5351 c          if (energy_dec) write(iout,*)
5352 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5353 c        else
5354 C       Checking if it involves dummy (NH3+ or COO-) group
5355          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5356 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5357         diff = vbld(i)-vbldpDUM
5358          else
5359 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5360         diff = vbld(i)-vbldp0
5361          endif
5362         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5363      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5364         estr=estr+diff*diff
5365         do j=1,3
5366           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5367         enddo
5368 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5369 c        endif
5370       enddo
5371       estr=0.5d0*AKP*estr+estr1
5372 c
5373 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5374 c
5375       do i=ibond_start,ibond_end
5376         iti=iabs(itype(i))
5377         if (iti.ne.10 .and. iti.ne.ntyp1) then
5378           nbi=nbondterm(iti)
5379           if (nbi.eq.1) then
5380             diff=vbld(i+nres)-vbldsc0(1,iti)
5381             if (energy_dec)  write (iout,*)
5382      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5383      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5384             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5385             do j=1,3
5386               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5387             enddo
5388           else
5389             do j=1,nbi
5390               diff=vbld(i+nres)-vbldsc0(j,iti)
5391               ud(j)=aksc(j,iti)*diff
5392               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5393             enddo
5394             uprod=u(1)
5395             do j=2,nbi
5396               uprod=uprod*u(j)
5397             enddo
5398             usum=0.0d0
5399             usumsqder=0.0d0
5400             do j=1,nbi
5401               uprod1=1.0d0
5402               uprod2=1.0d0
5403               do k=1,nbi
5404                 if (k.ne.j) then
5405                   uprod1=uprod1*u(k)
5406                   uprod2=uprod2*u(k)*u(k)
5407                 endif
5408               enddo
5409               usum=usum+uprod1
5410               usumsqder=usumsqder+ud(j)*uprod2
5411             enddo
5412             estr=estr+uprod/usum
5413             do j=1,3
5414              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5415             enddo
5416           endif
5417         endif
5418       enddo
5419       return
5420       end
5421 #ifdef CRYST_THETA
5422 C--------------------------------------------------------------------------
5423       subroutine ebend(etheta)
5424 C
5425 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5426 C angles gamma and its derivatives in consecutive thetas and gammas.
5427 C
5428       implicit real*8 (a-h,o-z)
5429       include 'DIMENSIONS'
5430       include 'COMMON.LOCAL'
5431       include 'COMMON.GEO'
5432       include 'COMMON.INTERACT'
5433       include 'COMMON.DERIV'
5434       include 'COMMON.VAR'
5435       include 'COMMON.CHAIN'
5436       include 'COMMON.IOUNITS'
5437       include 'COMMON.NAMES'
5438       include 'COMMON.FFIELD'
5439       include 'COMMON.CONTROL'
5440       common /calcthet/ term1,term2,termm,diffak,ratak,
5441      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5442      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5443       double precision y(2),z(2)
5444       delta=0.02d0*pi
5445 c      time11=dexp(-2*time)
5446 c      time12=1.0d0
5447       etheta=0.0D0
5448 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5449       do i=ithet_start,ithet_end
5450         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5451      &  .or.itype(i).eq.ntyp1) cycle
5452 C Zero the energy function and its derivative at 0 or pi.
5453         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5454         it=itype(i-1)
5455         ichir1=isign(1,itype(i-2))
5456         ichir2=isign(1,itype(i))
5457          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5458          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5459          if (itype(i-1).eq.10) then
5460           itype1=isign(10,itype(i-2))
5461           ichir11=isign(1,itype(i-2))
5462           ichir12=isign(1,itype(i-2))
5463           itype2=isign(10,itype(i))
5464           ichir21=isign(1,itype(i))
5465           ichir22=isign(1,itype(i))
5466          endif
5467
5468         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5469 #ifdef OSF
5470           phii=phi(i)
5471           if (phii.ne.phii) phii=150.0
5472 #else
5473           phii=phi(i)
5474 #endif
5475           y(1)=dcos(phii)
5476           y(2)=dsin(phii)
5477         else
5478           y(1)=0.0D0
5479           y(2)=0.0D0
5480         endif
5481         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5482 #ifdef OSF
5483           phii1=phi(i+1)
5484           if (phii1.ne.phii1) phii1=150.0
5485           phii1=pinorm(phii1)
5486           z(1)=cos(phii1)
5487 #else
5488           phii1=phi(i+1)
5489 #endif
5490           z(1)=dcos(phii1)
5491           z(2)=dsin(phii1)
5492         else
5493           z(1)=0.0D0
5494           z(2)=0.0D0
5495         endif
5496 C Calculate the "mean" value of theta from the part of the distribution
5497 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5498 C In following comments this theta will be referred to as t_c.
5499         thet_pred_mean=0.0d0
5500         do k=1,2
5501             athetk=athet(k,it,ichir1,ichir2)
5502             bthetk=bthet(k,it,ichir1,ichir2)
5503           if (it.eq.10) then
5504              athetk=athet(k,itype1,ichir11,ichir12)
5505              bthetk=bthet(k,itype2,ichir21,ichir22)
5506           endif
5507          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5508 c         write(iout,*) 'chuj tu', y(k),z(k)
5509         enddo
5510         dthett=thet_pred_mean*ssd
5511         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5512 C Derivatives of the "mean" values in gamma1 and gamma2.
5513         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5514      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5515          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5516      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5517          if (it.eq.10) then
5518       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5519      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5520         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5521      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5522          endif
5523         if (theta(i).gt.pi-delta) then
5524           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5525      &         E_tc0)
5526           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5527           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5528           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5529      &        E_theta)
5530           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5531      &        E_tc)
5532         else if (theta(i).lt.delta) then
5533           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5534           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5535           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5536      &        E_theta)
5537           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5538           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5539      &        E_tc)
5540         else
5541           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5542      &        E_theta,E_tc)
5543         endif
5544         etheta=etheta+ethetai
5545         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5546      &      'ebend',i,ethetai,theta(i),itype(i)
5547         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5548         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5549         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5550       enddo
5551 C Ufff.... We've done all this!!!
5552       return
5553       end
5554 C---------------------------------------------------------------------------
5555       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5556      &     E_tc)
5557       implicit real*8 (a-h,o-z)
5558       include 'DIMENSIONS'
5559       include 'COMMON.LOCAL'
5560       include 'COMMON.IOUNITS'
5561       common /calcthet/ term1,term2,termm,diffak,ratak,
5562      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5563      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5564 C Calculate the contributions to both Gaussian lobes.
5565 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5566 C The "polynomial part" of the "standard deviation" of this part of
5567 C the distributioni.
5568 ccc        write (iout,*) thetai,thet_pred_mean
5569         sig=polthet(3,it)
5570         do j=2,0,-1
5571           sig=sig*thet_pred_mean+polthet(j,it)
5572         enddo
5573 C Derivative of the "interior part" of the "standard deviation of the"
5574 C gamma-dependent Gaussian lobe in t_c.
5575         sigtc=3*polthet(3,it)
5576         do j=2,1,-1
5577           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5578         enddo
5579         sigtc=sig*sigtc
5580 C Set the parameters of both Gaussian lobes of the distribution.
5581 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5582         fac=sig*sig+sigc0(it)
5583         sigcsq=fac+fac
5584         sigc=1.0D0/sigcsq
5585 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5586         sigsqtc=-4.0D0*sigcsq*sigtc
5587 c       print *,i,sig,sigtc,sigsqtc
5588 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5589         sigtc=-sigtc/(fac*fac)
5590 C Following variable is sigma(t_c)**(-2)
5591         sigcsq=sigcsq*sigcsq
5592         sig0i=sig0(it)
5593         sig0inv=1.0D0/sig0i**2
5594         delthec=thetai-thet_pred_mean
5595         delthe0=thetai-theta0i
5596         term1=-0.5D0*sigcsq*delthec*delthec
5597         term2=-0.5D0*sig0inv*delthe0*delthe0
5598 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5599 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5600 C NaNs in taking the logarithm. We extract the largest exponent which is added
5601 C to the energy (this being the log of the distribution) at the end of energy
5602 C term evaluation for this virtual-bond angle.
5603         if (term1.gt.term2) then
5604           termm=term1
5605           term2=dexp(term2-termm)
5606           term1=1.0d0
5607         else
5608           termm=term2
5609           term1=dexp(term1-termm)
5610           term2=1.0d0
5611         endif
5612 C The ratio between the gamma-independent and gamma-dependent lobes of
5613 C the distribution is a Gaussian function of thet_pred_mean too.
5614         diffak=gthet(2,it)-thet_pred_mean
5615         ratak=diffak/gthet(3,it)**2
5616         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5617 C Let's differentiate it in thet_pred_mean NOW.
5618         aktc=ak*ratak
5619 C Now put together the distribution terms to make complete distribution.
5620         termexp=term1+ak*term2
5621         termpre=sigc+ak*sig0i
5622 C Contribution of the bending energy from this theta is just the -log of
5623 C the sum of the contributions from the two lobes and the pre-exponential
5624 C factor. Simple enough, isn't it?
5625         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5626 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5627 C NOW the derivatives!!!
5628 C 6/6/97 Take into account the deformation.
5629         E_theta=(delthec*sigcsq*term1
5630      &       +ak*delthe0*sig0inv*term2)/termexp
5631         E_tc=((sigtc+aktc*sig0i)/termpre
5632      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5633      &       aktc*term2)/termexp)
5634       return
5635       end
5636 c-----------------------------------------------------------------------------
5637       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5638       implicit real*8 (a-h,o-z)
5639       include 'DIMENSIONS'
5640       include 'COMMON.LOCAL'
5641       include 'COMMON.IOUNITS'
5642       common /calcthet/ term1,term2,termm,diffak,ratak,
5643      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5644      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5645       delthec=thetai-thet_pred_mean
5646       delthe0=thetai-theta0i
5647 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5648       t3 = thetai-thet_pred_mean
5649       t6 = t3**2
5650       t9 = term1
5651       t12 = t3*sigcsq
5652       t14 = t12+t6*sigsqtc
5653       t16 = 1.0d0
5654       t21 = thetai-theta0i
5655       t23 = t21**2
5656       t26 = term2
5657       t27 = t21*t26
5658       t32 = termexp
5659       t40 = t32**2
5660       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5661      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5662      & *(-t12*t9-ak*sig0inv*t27)
5663       return
5664       end
5665 #else
5666 C--------------------------------------------------------------------------
5667       subroutine ebend(etheta)
5668 C
5669 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5670 C angles gamma and its derivatives in consecutive thetas and gammas.
5671 C ab initio-derived potentials from
5672 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5673 C
5674       implicit real*8 (a-h,o-z)
5675       include 'DIMENSIONS'
5676       include 'COMMON.LOCAL'
5677       include 'COMMON.GEO'
5678       include 'COMMON.INTERACT'
5679       include 'COMMON.DERIV'
5680       include 'COMMON.VAR'
5681       include 'COMMON.CHAIN'
5682       include 'COMMON.IOUNITS'
5683       include 'COMMON.NAMES'
5684       include 'COMMON.FFIELD'
5685       include 'COMMON.CONTROL'
5686       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5687      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5688      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5689      & sinph1ph2(maxdouble,maxdouble)
5690       logical lprn /.false./, lprn1 /.false./
5691       etheta=0.0D0
5692       do i=ithet_start,ithet_end
5693 c        if (i.eq.2) cycle
5694 c        print *,i,itype(i-1),itype(i),itype(i-2)
5695         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5696      &  .or.(itype(i).eq.ntyp1)) cycle
5697 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5698
5699         if (iabs(itype(i+1)).eq.20) iblock=2
5700         if (iabs(itype(i+1)).ne.20) iblock=1
5701         dethetai=0.0d0
5702         dephii=0.0d0
5703         dephii1=0.0d0
5704         theti2=0.5d0*theta(i)
5705         ityp2=ithetyp((itype(i-1)))
5706         do k=1,nntheterm
5707           coskt(k)=dcos(k*theti2)
5708           sinkt(k)=dsin(k*theti2)
5709         enddo
5710         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5711 #ifdef OSF
5712           phii=phi(i)
5713           if (phii.ne.phii) phii=150.0
5714 #else
5715           phii=phi(i)
5716 #endif
5717           ityp1=ithetyp((itype(i-2)))
5718 C propagation of chirality for glycine type
5719           do k=1,nsingle
5720             cosph1(k)=dcos(k*phii)
5721             sinph1(k)=dsin(k*phii)
5722           enddo
5723         else
5724           phii=0.0d0
5725           ityp1=ithetyp(itype(i-2))
5726           do k=1,nsingle
5727             cosph1(k)=0.0d0
5728             sinph1(k)=0.0d0
5729           enddo
5730         endif
5731         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5732 #ifdef OSF
5733           phii1=phi(i+1)
5734           if (phii1.ne.phii1) phii1=150.0
5735           phii1=pinorm(phii1)
5736 #else
5737           phii1=phi(i+1)
5738 #endif
5739           ityp3=ithetyp((itype(i)))
5740           do k=1,nsingle
5741             cosph2(k)=dcos(k*phii1)
5742             sinph2(k)=dsin(k*phii1)
5743           enddo
5744         else
5745           phii1=0.0d0
5746           ityp3=ithetyp(itype(i))
5747           do k=1,nsingle
5748             cosph2(k)=0.0d0
5749             sinph2(k)=0.0d0
5750           enddo
5751         endif
5752         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5753         do k=1,ndouble
5754           do l=1,k-1
5755             ccl=cosph1(l)*cosph2(k-l)
5756             ssl=sinph1(l)*sinph2(k-l)
5757             scl=sinph1(l)*cosph2(k-l)
5758             csl=cosph1(l)*sinph2(k-l)
5759             cosph1ph2(l,k)=ccl-ssl
5760             cosph1ph2(k,l)=ccl+ssl
5761             sinph1ph2(l,k)=scl+csl
5762             sinph1ph2(k,l)=scl-csl
5763           enddo
5764         enddo
5765         if (lprn) then
5766         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5767      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5768         write (iout,*) "coskt and sinkt"
5769         do k=1,nntheterm
5770           write (iout,*) k,coskt(k),sinkt(k)
5771         enddo
5772         endif
5773         do k=1,ntheterm
5774           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5775           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5776      &      *coskt(k)
5777           if (lprn)
5778      &    write (iout,*) "k",k,"
5779      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5780      &     " ethetai",ethetai
5781         enddo
5782         if (lprn) then
5783         write (iout,*) "cosph and sinph"
5784         do k=1,nsingle
5785           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5786         enddo
5787         write (iout,*) "cosph1ph2 and sinph2ph2"
5788         do k=2,ndouble
5789           do l=1,k-1
5790             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5791      &         sinph1ph2(l,k),sinph1ph2(k,l)
5792           enddo
5793         enddo
5794         write(iout,*) "ethetai",ethetai
5795         endif
5796         do m=1,ntheterm2
5797           do k=1,nsingle
5798             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5799      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5800      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5801      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5802             ethetai=ethetai+sinkt(m)*aux
5803             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5804             dephii=dephii+k*sinkt(m)*(
5805      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5806      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5807             dephii1=dephii1+k*sinkt(m)*(
5808      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5809      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5810             if (lprn)
5811      &      write (iout,*) "m",m," k",k," bbthet",
5812      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5813      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5814      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5815      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5816           enddo
5817         enddo
5818         if (lprn)
5819      &  write(iout,*) "ethetai",ethetai
5820         do m=1,ntheterm3
5821           do k=2,ndouble
5822             do l=1,k-1
5823               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5824      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5825      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5826      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5827               ethetai=ethetai+sinkt(m)*aux
5828               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5829               dephii=dephii+l*sinkt(m)*(
5830      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5831      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5832      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5833      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5834               dephii1=dephii1+(k-l)*sinkt(m)*(
5835      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5836      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5837      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5838      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5839               if (lprn) then
5840               write (iout,*) "m",m," k",k," l",l," ffthet",
5841      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5842      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5843      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5844      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5845      &            " ethetai",ethetai
5846               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5847      &            cosph1ph2(k,l)*sinkt(m),
5848      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5849               endif
5850             enddo
5851           enddo
5852         enddo
5853 10      continue
5854 c        lprn1=.true.
5855         if (lprn1)
5856      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5857      &   i,theta(i)*rad2deg,phii*rad2deg,
5858      &   phii1*rad2deg,ethetai
5859 c        lprn1=.false.
5860         etheta=etheta+ethetai
5861         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5862      &      'ebend',i,ethetai
5863         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5864         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5865         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5866       enddo
5867       return
5868       end
5869 #endif
5870 #ifdef CRYST_SC
5871 c-----------------------------------------------------------------------------
5872       subroutine esc(escloc)
5873 C Calculate the local energy of a side chain and its derivatives in the
5874 C corresponding virtual-bond valence angles THETA and the spherical angles
5875 C ALPHA and OMEGA.
5876       implicit real*8 (a-h,o-z)
5877       include 'DIMENSIONS'
5878       include 'COMMON.GEO'
5879       include 'COMMON.LOCAL'
5880       include 'COMMON.VAR'
5881       include 'COMMON.INTERACT'
5882       include 'COMMON.DERIV'
5883       include 'COMMON.CHAIN'
5884       include 'COMMON.IOUNITS'
5885       include 'COMMON.NAMES'
5886       include 'COMMON.FFIELD'
5887       include 'COMMON.CONTROL'
5888       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5889      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5890       common /sccalc/ time11,time12,time112,theti,it,nlobit
5891       delta=0.02d0*pi
5892       escloc=0.0D0
5893 c     write (iout,'(a)') 'ESC'
5894       do i=loc_start,loc_end
5895         it=itype(i)
5896         if (it.eq.ntyp1) cycle
5897         if (it.eq.10) goto 1
5898         nlobit=nlob(iabs(it))
5899 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5900 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5901         theti=theta(i+1)-pipol
5902         x(1)=dtan(theti)
5903         x(2)=alph(i)
5904         x(3)=omeg(i)
5905
5906         if (x(2).gt.pi-delta) then
5907           xtemp(1)=x(1)
5908           xtemp(2)=pi-delta
5909           xtemp(3)=x(3)
5910           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5911           xtemp(2)=pi
5912           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5913           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5914      &        escloci,dersc(2))
5915           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5916      &        ddersc0(1),dersc(1))
5917           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5918      &        ddersc0(3),dersc(3))
5919           xtemp(2)=pi-delta
5920           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5921           xtemp(2)=pi
5922           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5923           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5924      &            dersc0(2),esclocbi,dersc02)
5925           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5926      &            dersc12,dersc01)
5927           call splinthet(x(2),0.5d0*delta,ss,ssd)
5928           dersc0(1)=dersc01
5929           dersc0(2)=dersc02
5930           dersc0(3)=0.0d0
5931           do k=1,3
5932             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5933           enddo
5934           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5935 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5936 c    &             esclocbi,ss,ssd
5937           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5938 c         escloci=esclocbi
5939 c         write (iout,*) escloci
5940         else if (x(2).lt.delta) then
5941           xtemp(1)=x(1)
5942           xtemp(2)=delta
5943           xtemp(3)=x(3)
5944           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5945           xtemp(2)=0.0d0
5946           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5947           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5948      &        escloci,dersc(2))
5949           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5950      &        ddersc0(1),dersc(1))
5951           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5952      &        ddersc0(3),dersc(3))
5953           xtemp(2)=delta
5954           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5955           xtemp(2)=0.0d0
5956           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5957           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5958      &            dersc0(2),esclocbi,dersc02)
5959           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5960      &            dersc12,dersc01)
5961           dersc0(1)=dersc01
5962           dersc0(2)=dersc02
5963           dersc0(3)=0.0d0
5964           call splinthet(x(2),0.5d0*delta,ss,ssd)
5965           do k=1,3
5966             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5967           enddo
5968           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5969 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5970 c    &             esclocbi,ss,ssd
5971           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5972 c         write (iout,*) escloci
5973         else
5974           call enesc(x,escloci,dersc,ddummy,.false.)
5975         endif
5976
5977         escloc=escloc+escloci
5978         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5979      &     'escloc',i,escloci
5980 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5981
5982         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5983      &   wscloc*dersc(1)
5984         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5985         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5986     1   continue
5987       enddo
5988       return
5989       end
5990 C---------------------------------------------------------------------------
5991       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5992       implicit real*8 (a-h,o-z)
5993       include 'DIMENSIONS'
5994       include 'COMMON.GEO'
5995       include 'COMMON.LOCAL'
5996       include 'COMMON.IOUNITS'
5997       common /sccalc/ time11,time12,time112,theti,it,nlobit
5998       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5999       double precision contr(maxlob,-1:1)
6000       logical mixed
6001 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6002         escloc_i=0.0D0
6003         do j=1,3
6004           dersc(j)=0.0D0
6005           if (mixed) ddersc(j)=0.0d0
6006         enddo
6007         x3=x(3)
6008
6009 C Because of periodicity of the dependence of the SC energy in omega we have
6010 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6011 C To avoid underflows, first compute & store the exponents.
6012
6013         do iii=-1,1
6014
6015           x(3)=x3+iii*dwapi
6016
6017           do j=1,nlobit
6018             do k=1,3
6019               z(k)=x(k)-censc(k,j,it)
6020             enddo
6021             do k=1,3
6022               Axk=0.0D0
6023               do l=1,3
6024                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6025               enddo
6026               Ax(k,j,iii)=Axk
6027             enddo
6028             expfac=0.0D0
6029             do k=1,3
6030               expfac=expfac+Ax(k,j,iii)*z(k)
6031             enddo
6032             contr(j,iii)=expfac
6033           enddo ! j
6034
6035         enddo ! iii
6036
6037         x(3)=x3
6038 C As in the case of ebend, we want to avoid underflows in exponentiation and
6039 C subsequent NaNs and INFs in energy calculation.
6040 C Find the largest exponent
6041         emin=contr(1,-1)
6042         do iii=-1,1
6043           do j=1,nlobit
6044             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6045           enddo
6046         enddo
6047         emin=0.5D0*emin
6048 cd      print *,'it=',it,' emin=',emin
6049
6050 C Compute the contribution to SC energy and derivatives
6051         do iii=-1,1
6052
6053           do j=1,nlobit
6054 #ifdef OSF
6055             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6056             if(adexp.ne.adexp) adexp=1.0
6057             expfac=dexp(adexp)
6058 #else
6059             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6060 #endif
6061 cd          print *,'j=',j,' expfac=',expfac
6062             escloc_i=escloc_i+expfac
6063             do k=1,3
6064               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6065             enddo
6066             if (mixed) then
6067               do k=1,3,2
6068                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6069      &            +gaussc(k,2,j,it))*expfac
6070               enddo
6071             endif
6072           enddo
6073
6074         enddo ! iii
6075
6076         dersc(1)=dersc(1)/cos(theti)**2
6077         ddersc(1)=ddersc(1)/cos(theti)**2
6078         ddersc(3)=ddersc(3)
6079
6080         escloci=-(dlog(escloc_i)-emin)
6081         do j=1,3
6082           dersc(j)=dersc(j)/escloc_i
6083         enddo
6084         if (mixed) then
6085           do j=1,3,2
6086             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6087           enddo
6088         endif
6089       return
6090       end
6091 C------------------------------------------------------------------------------
6092       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6093       implicit real*8 (a-h,o-z)
6094       include 'DIMENSIONS'
6095       include 'COMMON.GEO'
6096       include 'COMMON.LOCAL'
6097       include 'COMMON.IOUNITS'
6098       common /sccalc/ time11,time12,time112,theti,it,nlobit
6099       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6100       double precision contr(maxlob)
6101       logical mixed
6102
6103       escloc_i=0.0D0
6104
6105       do j=1,3
6106         dersc(j)=0.0D0
6107       enddo
6108
6109       do j=1,nlobit
6110         do k=1,2
6111           z(k)=x(k)-censc(k,j,it)
6112         enddo
6113         z(3)=dwapi
6114         do k=1,3
6115           Axk=0.0D0
6116           do l=1,3
6117             Axk=Axk+gaussc(l,k,j,it)*z(l)
6118           enddo
6119           Ax(k,j)=Axk
6120         enddo
6121         expfac=0.0D0
6122         do k=1,3
6123           expfac=expfac+Ax(k,j)*z(k)
6124         enddo
6125         contr(j)=expfac
6126       enddo ! j
6127
6128 C As in the case of ebend, we want to avoid underflows in exponentiation and
6129 C subsequent NaNs and INFs in energy calculation.
6130 C Find the largest exponent
6131       emin=contr(1)
6132       do j=1,nlobit
6133         if (emin.gt.contr(j)) emin=contr(j)
6134       enddo
6135       emin=0.5D0*emin
6136
6137 C Compute the contribution to SC energy and derivatives
6138
6139       dersc12=0.0d0
6140       do j=1,nlobit
6141         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6142         escloc_i=escloc_i+expfac
6143         do k=1,2
6144           dersc(k)=dersc(k)+Ax(k,j)*expfac
6145         enddo
6146         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6147      &            +gaussc(1,2,j,it))*expfac
6148         dersc(3)=0.0d0
6149       enddo
6150
6151       dersc(1)=dersc(1)/cos(theti)**2
6152       dersc12=dersc12/cos(theti)**2
6153       escloci=-(dlog(escloc_i)-emin)
6154       do j=1,2
6155         dersc(j)=dersc(j)/escloc_i
6156       enddo
6157       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6158       return
6159       end
6160 #else
6161 c----------------------------------------------------------------------------------
6162       subroutine esc(escloc)
6163 C Calculate the local energy of a side chain and its derivatives in the
6164 C corresponding virtual-bond valence angles THETA and the spherical angles
6165 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6166 C added by Urszula Kozlowska. 07/11/2007
6167 C
6168       implicit real*8 (a-h,o-z)
6169       include 'DIMENSIONS'
6170       include 'COMMON.GEO'
6171       include 'COMMON.LOCAL'
6172       include 'COMMON.VAR'
6173       include 'COMMON.SCROT'
6174       include 'COMMON.INTERACT'
6175       include 'COMMON.DERIV'
6176       include 'COMMON.CHAIN'
6177       include 'COMMON.IOUNITS'
6178       include 'COMMON.NAMES'
6179       include 'COMMON.FFIELD'
6180       include 'COMMON.CONTROL'
6181       include 'COMMON.VECTORS'
6182       double precision x_prime(3),y_prime(3),z_prime(3)
6183      &    , sumene,dsc_i,dp2_i,x(65),
6184      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6185      &    de_dxx,de_dyy,de_dzz,de_dt
6186       double precision s1_t,s1_6_t,s2_t,s2_6_t
6187       double precision
6188      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6189      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6190      & dt_dCi(3),dt_dCi1(3)
6191       common /sccalc/ time11,time12,time112,theti,it,nlobit
6192       delta=0.02d0*pi
6193       escloc=0.0D0
6194       do i=loc_start,loc_end
6195         if (itype(i).eq.ntyp1) cycle
6196         costtab(i+1) =dcos(theta(i+1))
6197         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6198         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6199         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6200         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6201         cosfac=dsqrt(cosfac2)
6202         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6203         sinfac=dsqrt(sinfac2)
6204         it=iabs(itype(i))
6205         if (it.eq.10) goto 1
6206 c
6207 C  Compute the axes of tghe local cartesian coordinates system; store in
6208 c   x_prime, y_prime and z_prime
6209 c
6210         do j=1,3
6211           x_prime(j) = 0.00
6212           y_prime(j) = 0.00
6213           z_prime(j) = 0.00
6214         enddo
6215 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6216 C     &   dc_norm(3,i+nres)
6217         do j = 1,3
6218           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6219           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6220         enddo
6221         do j = 1,3
6222           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6223         enddo
6224 c       write (2,*) "i",i
6225 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6226 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6227 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6228 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6229 c      & " xy",scalar(x_prime(1),y_prime(1)),
6230 c      & " xz",scalar(x_prime(1),z_prime(1)),
6231 c      & " yy",scalar(y_prime(1),y_prime(1)),
6232 c      & " yz",scalar(y_prime(1),z_prime(1)),
6233 c      & " zz",scalar(z_prime(1),z_prime(1))
6234 c
6235 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6236 C to local coordinate system. Store in xx, yy, zz.
6237 c
6238         xx=0.0d0
6239         yy=0.0d0
6240         zz=0.0d0
6241         do j = 1,3
6242           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6243           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6244           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6245         enddo
6246
6247         xxtab(i)=xx
6248         yytab(i)=yy
6249         zztab(i)=zz
6250 C
6251 C Compute the energy of the ith side cbain
6252 C
6253 c        write (2,*) "xx",xx," yy",yy," zz",zz
6254         it=iabs(itype(i))
6255         do j = 1,65
6256           x(j) = sc_parmin(j,it)
6257         enddo
6258 #ifdef CHECK_COORD
6259 Cc diagnostics - remove later
6260         xx1 = dcos(alph(2))
6261         yy1 = dsin(alph(2))*dcos(omeg(2))
6262         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6263         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6264      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6265      &    xx1,yy1,zz1
6266 C,"  --- ", xx_w,yy_w,zz_w
6267 c end diagnostics
6268 #endif
6269         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6270      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6271      &   + x(10)*yy*zz
6272         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6273      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6274      & + x(20)*yy*zz
6275         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6276      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6277      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6278      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6279      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6280      &  +x(40)*xx*yy*zz
6281         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6282      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6283      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6284      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6285      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6286      &  +x(60)*xx*yy*zz
6287         dsc_i   = 0.743d0+x(61)
6288         dp2_i   = 1.9d0+x(62)
6289         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6290      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6291         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6292      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6293         s1=(1+x(63))/(0.1d0 + dscp1)
6294         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6295         s2=(1+x(65))/(0.1d0 + dscp2)
6296         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6297         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6298      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6299 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6300 c     &   sumene4,
6301 c     &   dscp1,dscp2,sumene
6302 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6303         escloc = escloc + sumene
6304         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6305      &     'escloc',i,sumene
6306 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6307 c     & ,zz,xx,yy
6308 c#define DEBUG
6309 #ifdef DEBUG
6310 C
6311 C This section to check the numerical derivatives of the energy of ith side
6312 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6313 C #define DEBUG in the code to turn it on.
6314 C
6315         write (2,*) "sumene               =",sumene
6316         aincr=1.0d-7
6317         xxsave=xx
6318         xx=xx+aincr
6319         write (2,*) xx,yy,zz
6320         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6321         de_dxx_num=(sumenep-sumene)/aincr
6322         xx=xxsave
6323         write (2,*) "xx+ sumene from enesc=",sumenep
6324         yysave=yy
6325         yy=yy+aincr
6326         write (2,*) xx,yy,zz
6327         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6328         de_dyy_num=(sumenep-sumene)/aincr
6329         yy=yysave
6330         write (2,*) "yy+ sumene from enesc=",sumenep
6331         zzsave=zz
6332         zz=zz+aincr
6333         write (2,*) xx,yy,zz
6334         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6335         de_dzz_num=(sumenep-sumene)/aincr
6336         zz=zzsave
6337         write (2,*) "zz+ sumene from enesc=",sumenep
6338         costsave=cost2tab(i+1)
6339         sintsave=sint2tab(i+1)
6340         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6341         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6342         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6343         de_dt_num=(sumenep-sumene)/aincr
6344         write (2,*) " t+ sumene from enesc=",sumenep
6345         cost2tab(i+1)=costsave
6346         sint2tab(i+1)=sintsave
6347 C End of diagnostics section.
6348 #endif
6349 C
6350 C Compute the gradient of esc
6351 C
6352 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6353         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6354         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6355         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6356         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6357         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6358         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6359         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6360         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6361         pom1=(sumene3*sint2tab(i+1)+sumene1)
6362      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6363         pom2=(sumene4*cost2tab(i+1)+sumene2)
6364      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6365         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6366         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6367      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6368      &  +x(40)*yy*zz
6369         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6370         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6371      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6372      &  +x(60)*yy*zz
6373         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6374      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6375      &        +(pom1+pom2)*pom_dx
6376 #ifdef DEBUG
6377         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6378 #endif
6379 C
6380         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6381         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6382      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6383      &  +x(40)*xx*zz
6384         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6385         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6386      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6387      &  +x(59)*zz**2 +x(60)*xx*zz
6388         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6389      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6390      &        +(pom1-pom2)*pom_dy
6391 #ifdef DEBUG
6392         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6393 #endif
6394 C
6395         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6396      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6397      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6398      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6399      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6400      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6401      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6402      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6403 #ifdef DEBUG
6404         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6405 #endif
6406 C
6407         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6408      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6409      &  +pom1*pom_dt1+pom2*pom_dt2
6410 #ifdef DEBUG
6411         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6412 #endif
6413 c#undef DEBUG
6414 c
6415 C
6416        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6417        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6418        cosfac2xx=cosfac2*xx
6419        sinfac2yy=sinfac2*yy
6420        do k = 1,3
6421          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6422      &      vbld_inv(i+1)
6423          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6424      &      vbld_inv(i)
6425          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6426          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6427 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6428 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6429 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6430 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6431          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6432          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6433          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6434          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6435          dZZ_Ci1(k)=0.0d0
6436          dZZ_Ci(k)=0.0d0
6437          do j=1,3
6438            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6439      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6440            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6441      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6442          enddo
6443
6444          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6445          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6446          dZZ_XYZ(k)=vbld_inv(i+nres)*
6447      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6448 c
6449          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6450          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6451        enddo
6452
6453        do k=1,3
6454          dXX_Ctab(k,i)=dXX_Ci(k)
6455          dXX_C1tab(k,i)=dXX_Ci1(k)
6456          dYY_Ctab(k,i)=dYY_Ci(k)
6457          dYY_C1tab(k,i)=dYY_Ci1(k)
6458          dZZ_Ctab(k,i)=dZZ_Ci(k)
6459          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6460          dXX_XYZtab(k,i)=dXX_XYZ(k)
6461          dYY_XYZtab(k,i)=dYY_XYZ(k)
6462          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6463        enddo
6464
6465        do k = 1,3
6466 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6467 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6468 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6469 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6470 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6471 c     &    dt_dci(k)
6472 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6473 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6474          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6475      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6476          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6477      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6478          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6479      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6480        enddo
6481 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6482 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6483
6484 C to check gradient call subroutine check_grad
6485
6486     1 continue
6487       enddo
6488       return
6489       end
6490 c------------------------------------------------------------------------------
6491       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6492       implicit none
6493       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6494      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6495       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6496      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6497      &   + x(10)*yy*zz
6498       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6499      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6500      & + x(20)*yy*zz
6501       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6502      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6503      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6504      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6505      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6506      &  +x(40)*xx*yy*zz
6507       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6508      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6509      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6510      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6511      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6512      &  +x(60)*xx*yy*zz
6513       dsc_i   = 0.743d0+x(61)
6514       dp2_i   = 1.9d0+x(62)
6515       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6516      &          *(xx*cost2+yy*sint2))
6517       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6518      &          *(xx*cost2-yy*sint2))
6519       s1=(1+x(63))/(0.1d0 + dscp1)
6520       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6521       s2=(1+x(65))/(0.1d0 + dscp2)
6522       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6523       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6524      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6525       enesc=sumene
6526       return
6527       end
6528 #endif
6529 c------------------------------------------------------------------------------
6530       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6531 C
6532 C This procedure calculates two-body contact function g(rij) and its derivative:
6533 C
6534 C           eps0ij                                     !       x < -1
6535 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6536 C            0                                         !       x > 1
6537 C
6538 C where x=(rij-r0ij)/delta
6539 C
6540 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6541 C
6542       implicit none
6543       double precision rij,r0ij,eps0ij,fcont,fprimcont
6544       double precision x,x2,x4,delta
6545 c     delta=0.02D0*r0ij
6546 c      delta=0.2D0*r0ij
6547       x=(rij-r0ij)/delta
6548       if (x.lt.-1.0D0) then
6549         fcont=eps0ij
6550         fprimcont=0.0D0
6551       else if (x.le.1.0D0) then
6552         x2=x*x
6553         x4=x2*x2
6554         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6555         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6556       else
6557         fcont=0.0D0
6558         fprimcont=0.0D0
6559       endif
6560       return
6561       end
6562 c------------------------------------------------------------------------------
6563       subroutine splinthet(theti,delta,ss,ssder)
6564       implicit real*8 (a-h,o-z)
6565       include 'DIMENSIONS'
6566       include 'COMMON.VAR'
6567       include 'COMMON.GEO'
6568       thetup=pi-delta
6569       thetlow=delta
6570       if (theti.gt.pipol) then
6571         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6572       else
6573         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6574         ssder=-ssder
6575       endif
6576       return
6577       end
6578 c------------------------------------------------------------------------------
6579       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6580       implicit none
6581       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6582       double precision ksi,ksi2,ksi3,a1,a2,a3
6583       a1=fprim0*delta/(f1-f0)
6584       a2=3.0d0-2.0d0*a1
6585       a3=a1-2.0d0
6586       ksi=(x-x0)/delta
6587       ksi2=ksi*ksi
6588       ksi3=ksi2*ksi
6589       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6590       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6591       return
6592       end
6593 c------------------------------------------------------------------------------
6594       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6595       implicit none
6596       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6597       double precision ksi,ksi2,ksi3,a1,a2,a3
6598       ksi=(x-x0)/delta
6599       ksi2=ksi*ksi
6600       ksi3=ksi2*ksi
6601       a1=fprim0x*delta
6602       a2=3*(f1x-f0x)-2*fprim0x*delta
6603       a3=fprim0x*delta-2*(f1x-f0x)
6604       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6605       return
6606       end
6607 C-----------------------------------------------------------------------------
6608 #ifdef CRYST_TOR
6609 C-----------------------------------------------------------------------------
6610       subroutine etor(etors,edihcnstr)
6611       implicit real*8 (a-h,o-z)
6612       include 'DIMENSIONS'
6613       include 'COMMON.VAR'
6614       include 'COMMON.GEO'
6615       include 'COMMON.LOCAL'
6616       include 'COMMON.TORSION'
6617       include 'COMMON.INTERACT'
6618       include 'COMMON.DERIV'
6619       include 'COMMON.CHAIN'
6620       include 'COMMON.NAMES'
6621       include 'COMMON.IOUNITS'
6622       include 'COMMON.FFIELD'
6623       include 'COMMON.TORCNSTR'
6624       include 'COMMON.CONTROL'
6625       logical lprn
6626 C Set lprn=.true. for debugging
6627       lprn=.false.
6628 c      lprn=.true.
6629       etors=0.0D0
6630       do i=iphi_start,iphi_end
6631       etors_ii=0.0D0
6632         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6633      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6634         itori=itortyp(itype(i-2))
6635         itori1=itortyp(itype(i-1))
6636         phii=phi(i)
6637         gloci=0.0D0
6638 C Proline-Proline pair is a special case...
6639         if (itori.eq.3 .and. itori1.eq.3) then
6640           if (phii.gt.-dwapi3) then
6641             cosphi=dcos(3*phii)
6642             fac=1.0D0/(1.0D0-cosphi)
6643             etorsi=v1(1,3,3)*fac
6644             etorsi=etorsi+etorsi
6645             etors=etors+etorsi-v1(1,3,3)
6646             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6647             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6648           endif
6649           do j=1,3
6650             v1ij=v1(j+1,itori,itori1)
6651             v2ij=v2(j+1,itori,itori1)
6652             cosphi=dcos(j*phii)
6653             sinphi=dsin(j*phii)
6654             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6655             if (energy_dec) etors_ii=etors_ii+
6656      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6657             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6658           enddo
6659         else
6660           do j=1,nterm_old
6661             v1ij=v1(j,itori,itori1)
6662             v2ij=v2(j,itori,itori1)
6663             cosphi=dcos(j*phii)
6664             sinphi=dsin(j*phii)
6665             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6666             if (energy_dec) etors_ii=etors_ii+
6667      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6668             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6669           enddo
6670         endif
6671         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6672              'etor',i,etors_ii
6673         if (lprn)
6674      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6675      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6676      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6677         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6678 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6679       enddo
6680 ! 6/20/98 - dihedral angle constraints
6681       edihcnstr=0.0d0
6682       do i=1,ndih_constr
6683         itori=idih_constr(i)
6684         phii=phi(itori)
6685         difi=phii-phi0(i)
6686         if (difi.gt.drange(i)) then
6687           difi=difi-drange(i)
6688           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6689           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6690         else if (difi.lt.-drange(i)) then
6691           difi=difi+drange(i)
6692           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6693           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6694         endif
6695 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6696 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6697       enddo
6698 !      write (iout,*) 'edihcnstr',edihcnstr
6699       return
6700       end
6701 c------------------------------------------------------------------------------
6702 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6703       subroutine e_modeller(ehomology_constr)
6704       ehomology_constr=0.0d0
6705       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6706       return
6707       end
6708 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6709
6710 c------------------------------------------------------------------------------
6711       subroutine etor_d(etors_d)
6712       etors_d=0.0d0
6713       return
6714       end
6715 c----------------------------------------------------------------------------
6716 #else
6717       subroutine etor(etors,edihcnstr)
6718       implicit real*8 (a-h,o-z)
6719       include 'DIMENSIONS'
6720       include 'COMMON.VAR'
6721       include 'COMMON.GEO'
6722       include 'COMMON.LOCAL'
6723       include 'COMMON.TORSION'
6724       include 'COMMON.INTERACT'
6725       include 'COMMON.DERIV'
6726       include 'COMMON.CHAIN'
6727       include 'COMMON.NAMES'
6728       include 'COMMON.IOUNITS'
6729       include 'COMMON.FFIELD'
6730       include 'COMMON.TORCNSTR'
6731       include 'COMMON.CONTROL'
6732       logical lprn
6733 C Set lprn=.true. for debugging
6734       lprn=.false.
6735 c     lprn=.true.
6736       etors=0.0D0
6737       do i=iphi_start,iphi_end
6738 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6739 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6740 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6741 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6742         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6743      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6744 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6745 C For introducing the NH3+ and COO- group please check the etor_d for reference
6746 C and guidance
6747         etors_ii=0.0D0
6748          if (iabs(itype(i)).eq.20) then
6749          iblock=2
6750          else
6751          iblock=1
6752          endif
6753         itori=itortyp(itype(i-2))
6754         itori1=itortyp(itype(i-1))
6755         phii=phi(i)
6756         gloci=0.0D0
6757 C Regular cosine and sine terms
6758         do j=1,nterm(itori,itori1,iblock)
6759           v1ij=v1(j,itori,itori1,iblock)
6760           v2ij=v2(j,itori,itori1,iblock)
6761           cosphi=dcos(j*phii)
6762           sinphi=dsin(j*phii)
6763           etors=etors+v1ij*cosphi+v2ij*sinphi
6764           if (energy_dec) etors_ii=etors_ii+
6765      &                v1ij*cosphi+v2ij*sinphi
6766           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6767         enddo
6768 C Lorentz terms
6769 C                         v1
6770 C  E = SUM ----------------------------------- - v1
6771 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6772 C
6773         cosphi=dcos(0.5d0*phii)
6774         sinphi=dsin(0.5d0*phii)
6775         do j=1,nlor(itori,itori1,iblock)
6776           vl1ij=vlor1(j,itori,itori1)
6777           vl2ij=vlor2(j,itori,itori1)
6778           vl3ij=vlor3(j,itori,itori1)
6779           pom=vl2ij*cosphi+vl3ij*sinphi
6780           pom1=1.0d0/(pom*pom+1.0d0)
6781           etors=etors+vl1ij*pom1
6782           if (energy_dec) etors_ii=etors_ii+
6783      &                vl1ij*pom1
6784           pom=-pom*pom1*pom1
6785           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6786         enddo
6787 C Subtract the constant term
6788         etors=etors-v0(itori,itori1,iblock)
6789           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6790      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6791         if (lprn)
6792      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6793      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6794      &  (v1(j,itori,itori1,iblock),j=1,6),
6795      &  (v2(j,itori,itori1,iblock),j=1,6)
6796         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6797 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6798       enddo
6799 ! 6/20/98 - dihedral angle constraints
6800       edihcnstr=0.0d0
6801 c      do i=1,ndih_constr
6802       do i=idihconstr_start,idihconstr_end
6803         itori=idih_constr(i)
6804         phii=phi(itori)
6805         difi=pinorm(phii-phi0(i))
6806         if (difi.gt.drange(i)) then
6807           difi=difi-drange(i)
6808           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6809           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6810         else if (difi.lt.-drange(i)) then
6811           difi=difi+drange(i)
6812           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6813           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6814         else
6815           difi=0.0
6816         endif
6817 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6818 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6819 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6820       enddo
6821 cd       write (iout,*) 'edihcnstr',edihcnstr
6822       return
6823       end
6824 c----------------------------------------------------------------------------
6825 c MODELLER restraint function
6826       subroutine e_modeller(ehomology_constr)
6827       implicit real*8 (a-h,o-z)
6828       include 'DIMENSIONS'
6829
6830       integer nnn, i, j, k, ki, irec, l
6831       integer katy, odleglosci, test7
6832       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6833       real*8 Eval,Erot
6834       real*8 distance(max_template),distancek(max_template),
6835      &    min_odl,godl(max_template),dih_diff(max_template)
6836
6837 c
6838 c     FP - 30/10/2014 Temporary specifications for homology restraints
6839 c
6840       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6841      &                 sgtheta
6842       double precision, dimension (maxres) :: guscdiff,usc_diff
6843       double precision, dimension (max_template) ::
6844      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6845      &           theta_diff
6846 c
6847
6848       include 'COMMON.SBRIDGE'
6849       include 'COMMON.CHAIN'
6850       include 'COMMON.GEO'
6851       include 'COMMON.DERIV'
6852       include 'COMMON.LOCAL'
6853       include 'COMMON.INTERACT'
6854       include 'COMMON.VAR'
6855       include 'COMMON.IOUNITS'
6856       include 'COMMON.MD'
6857       include 'COMMON.CONTROL'
6858 c
6859 c     From subroutine Econstr_back
6860 c
6861       include 'COMMON.NAMES'
6862       include 'COMMON.TIME1'
6863 c
6864
6865
6866       do i=1,19
6867         distancek(i)=9999999.9
6868       enddo
6869
6870
6871       odleg=0.0d0
6872
6873 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6874 c function)
6875 C AL 5/2/14 - Introduce list of restraints
6876 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6877 #ifdef DEBUG
6878       write(iout,*) "------- dist restrs start -------"
6879 #endif
6880       do ii = link_start_homo,link_end_homo
6881          i = ires_homo(ii)
6882          j = jres_homo(ii)
6883          dij=dist(i,j)
6884 c        write (iout,*) "dij(",i,j,") =",dij
6885          do k=1,constr_homology
6886 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6887            if(.not.l_homo(k,ii)) cycle
6888            distance(k)=odl(k,ii)-dij
6889 c          write (iout,*) "distance(",k,") =",distance(k)
6890 c
6891 c          For Gaussian-type Urestr
6892 c
6893            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6894 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6895 c          write (iout,*) "distancek(",k,") =",distancek(k)
6896 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6897 c
6898 c          For Lorentzian-type Urestr
6899 c
6900            if (waga_dist.lt.0.0d0) then
6901               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6902               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6903      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6904            endif
6905          enddo
6906
6907 c         min_odl=minval(distancek)
6908          do kk=1,constr_homology
6909           if(l_homo(kk,ii)) then
6910             min_odl=distancek(kk)
6911             exit
6912           endif
6913          enddo
6914          do kk=1,constr_homology
6915           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6916      &              min_odl=distancek(kk)
6917          enddo
6918
6919 c        write (iout,* )"min_odl",min_odl
6920 #ifdef DEBUG
6921          write (iout,*) "ij dij",i,j,dij
6922          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6923          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6924          write (iout,* )"min_odl",min_odl
6925 #endif
6926          odleg2=0.0d0
6927          do k=1,constr_homology
6928 c Nie wiem po co to liczycie jeszcze raz!
6929 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6930 c     &              (2*(sigma_odl(i,j,k))**2))
6931            if(.not.l_homo(k,ii)) cycle
6932            if (waga_dist.ge.0.0d0) then
6933 c
6934 c          For Gaussian-type Urestr
6935 c
6936             godl(k)=dexp(-distancek(k)+min_odl)
6937             odleg2=odleg2+godl(k)
6938 c
6939 c          For Lorentzian-type Urestr
6940 c
6941            else
6942             odleg2=odleg2+distancek(k)
6943            endif
6944
6945 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6946 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6947 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6948 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6949
6950          enddo
6951 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6952 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6953 #ifdef DEBUG
6954          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6955          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6956 #endif
6957            if (waga_dist.ge.0.0d0) then
6958 c
6959 c          For Gaussian-type Urestr
6960 c
6961               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6962 c
6963 c          For Lorentzian-type Urestr
6964 c
6965            else
6966               odleg=odleg+odleg2/constr_homology
6967            endif
6968 c
6969 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6970 c Gradient
6971 c
6972 c          For Gaussian-type Urestr
6973 c
6974          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6975          sum_sgodl=0.0d0
6976          do k=1,constr_homology
6977 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6978 c     &           *waga_dist)+min_odl
6979 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6980 c
6981          if(.not.l_homo(k,ii)) cycle
6982          if (waga_dist.ge.0.0d0) then
6983 c          For Gaussian-type Urestr
6984 c
6985            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6986 c
6987 c          For Lorentzian-type Urestr
6988 c
6989          else
6990            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6991      &           sigma_odlir(k,ii)**2)**2)
6992          endif
6993            sum_sgodl=sum_sgodl+sgodl
6994
6995 c            sgodl2=sgodl2+sgodl
6996 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6997 c      write(iout,*) "constr_homology=",constr_homology
6998 c      write(iout,*) i, j, k, "TEST K"
6999          enddo
7000          if (waga_dist.ge.0.0d0) then
7001 c
7002 c          For Gaussian-type Urestr
7003 c
7004             grad_odl3=waga_homology(iset)*waga_dist
7005      &                *sum_sgodl/(sum_godl*dij)
7006 c
7007 c          For Lorentzian-type Urestr
7008 c
7009          else
7010 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7011 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7012             grad_odl3=-waga_homology(iset)*waga_dist*
7013      &                sum_sgodl/(constr_homology*dij)
7014          endif
7015 c
7016 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7017
7018
7019 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7020 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7021 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7022
7023 ccc      write(iout,*) godl, sgodl, grad_odl3
7024
7025 c          grad_odl=grad_odl+grad_odl3
7026
7027          do jik=1,3
7028             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7029 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7030 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7031 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7032             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7033             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7034 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7035 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7036 c         if (i.eq.25.and.j.eq.27) then
7037 c         write(iout,*) "jik",jik,"i",i,"j",j
7038 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7039 c         write(iout,*) "grad_odl3",grad_odl3
7040 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7041 c         write(iout,*) "ggodl",ggodl
7042 c         write(iout,*) "ghpbc(",jik,i,")",
7043 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7044 c     &                 ghpbc(jik,j)
7045 c         endif
7046          enddo
7047 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7048 ccc     & dLOG(odleg2),"-odleg=", -odleg
7049
7050       enddo ! ii-loop for dist
7051 #ifdef DEBUG
7052       write(iout,*) "------- dist restrs end -------"
7053 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7054 c    &     waga_d.eq.1.0d0) call sum_gradient
7055 #endif
7056 c Pseudo-energy and gradient from dihedral-angle restraints from
7057 c homology templates
7058 c      write (iout,*) "End of distance loop"
7059 c      call flush(iout)
7060       kat=0.0d0
7061 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7062 #ifdef DEBUG
7063       write(iout,*) "------- dih restrs start -------"
7064       do i=idihconstr_start_homo,idihconstr_end_homo
7065         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7066       enddo
7067 #endif
7068       do i=idihconstr_start_homo,idihconstr_end_homo
7069         kat2=0.0d0
7070 c        betai=beta(i,i+1,i+2,i+3)
7071         betai = phi(i)
7072 c       write (iout,*) "betai =",betai
7073         do k=1,constr_homology
7074           dih_diff(k)=pinorm(dih(k,i)-betai)
7075 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7076 cd     &                  ,sigma_dih(k,i)
7077 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7078 c     &                                   -(6.28318-dih_diff(i,k))
7079 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7080 c     &                                   6.28318+dih_diff(i,k)
7081
7082           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7083 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7084           gdih(k)=dexp(kat3)
7085           kat2=kat2+gdih(k)
7086 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7087 c          write(*,*)""
7088         enddo
7089 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7090 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7091 #ifdef DEBUG
7092         write (iout,*) "i",i," betai",betai," kat2",kat2
7093         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7094 #endif
7095         if (kat2.le.1.0d-14) cycle
7096         kat=kat-dLOG(kat2/constr_homology)
7097 c       write (iout,*) "kat",kat ! sum of -ln-s
7098
7099 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7100 ccc     & dLOG(kat2), "-kat=", -kat
7101
7102 c ----------------------------------------------------------------------
7103 c Gradient
7104 c ----------------------------------------------------------------------
7105
7106         sum_gdih=kat2
7107         sum_sgdih=0.0d0
7108         do k=1,constr_homology
7109           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7110 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7111           sum_sgdih=sum_sgdih+sgdih
7112         enddo
7113 c       grad_dih3=sum_sgdih/sum_gdih
7114         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7115
7116 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7117 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7118 ccc     & gloc(nphi+i-3,icg)
7119         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7120 c        if (i.eq.25) then
7121 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7122 c        endif
7123 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7124 ccc     & gloc(nphi+i-3,icg)
7125
7126       enddo ! i-loop for dih
7127 #ifdef DEBUG
7128       write(iout,*) "------- dih restrs end -------"
7129 #endif
7130
7131 c Pseudo-energy and gradient for theta angle restraints from
7132 c homology templates
7133 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7134 c adapted
7135
7136 c
7137 c     For constr_homology reference structures (FP)
7138 c
7139 c     Uconst_back_tot=0.0d0
7140       Eval=0.0d0
7141       Erot=0.0d0
7142 c     Econstr_back legacy
7143       do i=1,nres
7144 c     do i=ithet_start,ithet_end
7145        dutheta(i)=0.0d0
7146 c     enddo
7147 c     do i=loc_start,loc_end
7148         do j=1,3
7149           duscdiff(j,i)=0.0d0
7150           duscdiffx(j,i)=0.0d0
7151         enddo
7152       enddo
7153 c
7154 c     do iref=1,nref
7155 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7156 c     write (iout,*) "waga_theta",waga_theta
7157       if (waga_theta.gt.0.0d0) then
7158 #ifdef DEBUG
7159       write (iout,*) "usampl",usampl
7160       write(iout,*) "------- theta restrs start -------"
7161 c     do i=ithet_start,ithet_end
7162 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7163 c     enddo
7164 #endif
7165 c     write (iout,*) "maxres",maxres,"nres",nres
7166
7167       do i=ithet_start,ithet_end
7168 c
7169 c     do i=1,nfrag_back
7170 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7171 c
7172 c Deviation of theta angles wrt constr_homology ref structures
7173 c
7174         utheta_i=0.0d0 ! argument of Gaussian for single k
7175         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7176 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7177 c       over residues in a fragment
7178 c       write (iout,*) "theta(",i,")=",theta(i)
7179         do k=1,constr_homology
7180 c
7181 c         dtheta_i=theta(j)-thetaref(j,iref)
7182 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7183           theta_diff(k)=thetatpl(k,i)-theta(i)
7184 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7185 cd     &                  ,sigma_theta(k,i)
7186
7187 c
7188           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7189 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7190           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7191           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
7192 c         Gradient for single Gaussian restraint in subr Econstr_back
7193 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7194 c
7195         enddo
7196 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7197 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7198
7199 c
7200 c         Gradient for multiple Gaussian restraint
7201         sum_gtheta=gutheta_i
7202         sum_sgtheta=0.0d0
7203         do k=1,constr_homology
7204 c        New generalized expr for multiple Gaussian from Econstr_back
7205          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7206 c
7207 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7208           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7209         enddo
7210 c       Final value of gradient using same var as in Econstr_back
7211         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7212      &      +sum_sgtheta/sum_gtheta*waga_theta
7213      &               *waga_homology(iset)
7214 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7215 c     &               *waga_homology(iset)
7216 c       dutheta(i)=sum_sgtheta/sum_gtheta
7217 c
7218 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7219         Eval=Eval-dLOG(gutheta_i/constr_homology)
7220 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7221 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7222 c       Uconst_back=Uconst_back+utheta(i)
7223       enddo ! (i-loop for theta)
7224 #ifdef DEBUG
7225       write(iout,*) "------- theta restrs end -------"
7226 #endif
7227       endif
7228 c
7229 c Deviation of local SC geometry
7230 c
7231 c Separation of two i-loops (instructed by AL - 11/3/2014)
7232 c
7233 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7234 c     write (iout,*) "waga_d",waga_d
7235
7236 #ifdef DEBUG
7237       write(iout,*) "------- SC restrs start -------"
7238       write (iout,*) "Initial duscdiff,duscdiffx"
7239       do i=loc_start,loc_end
7240         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7241      &                 (duscdiffx(jik,i),jik=1,3)
7242       enddo
7243 #endif
7244       do i=loc_start,loc_end
7245         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7246         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7247 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7248 c       write(iout,*) "xxtab, yytab, zztab"
7249 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7250         do k=1,constr_homology
7251 c
7252           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7253 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7254           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7255           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7256 c         write(iout,*) "dxx, dyy, dzz"
7257 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7258 c
7259           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7260 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7261 c         uscdiffk(k)=usc_diff(i)
7262           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7263           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
7264 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7265 c     &      xxref(j),yyref(j),zzref(j)
7266         enddo
7267 c
7268 c       Gradient
7269 c
7270 c       Generalized expression for multiple Gaussian acc to that for a single
7271 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7272 c
7273 c       Original implementation
7274 c       sum_guscdiff=guscdiff(i)
7275 c
7276 c       sum_sguscdiff=0.0d0
7277 c       do k=1,constr_homology
7278 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7279 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7280 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7281 c       enddo
7282 c
7283 c       Implementation of new expressions for gradient (Jan. 2015)
7284 c
7285 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7286         do k=1,constr_homology
7287 c
7288 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7289 c       before. Now the drivatives should be correct
7290 c
7291           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7292 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7293           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7294           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7295 c
7296 c         New implementation
7297 c
7298           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7299      &                 sigma_d(k,i) ! for the grad wrt r'
7300 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7301 c
7302 c
7303 c        New implementation
7304          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7305          do jik=1,3
7306             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7307      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7308      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7309             duscdiff(jik,i)=duscdiff(jik,i)+
7310      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7311      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7312             duscdiffx(jik,i)=duscdiffx(jik,i)+
7313      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7314      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7315 c
7316 #ifdef DEBUG
7317              write(iout,*) "jik",jik,"i",i
7318              write(iout,*) "dxx, dyy, dzz"
7319              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7320              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7321 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7322 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7323 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7324 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7325 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7326 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7327 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7328 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7329 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7330 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7331 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7332 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7333 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7334 c            endif
7335 #endif
7336          enddo
7337         enddo
7338 c
7339 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7340 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7341 c
7342 c        write (iout,*) i," uscdiff",uscdiff(i)
7343 c
7344 c Put together deviations from local geometry
7345
7346 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7347 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7348         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7349 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7350 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7351 c       Uconst_back=Uconst_back+usc_diff(i)
7352 c
7353 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7354 c
7355 c     New implment: multiplied by sum_sguscdiff
7356 c
7357
7358       enddo ! (i-loop for dscdiff)
7359
7360 c      endif
7361
7362 #ifdef DEBUG
7363       write(iout,*) "------- SC restrs end -------"
7364         write (iout,*) "------ After SC loop in e_modeller ------"
7365         do i=loc_start,loc_end
7366          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7367          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7368         enddo
7369       if (waga_theta.eq.1.0d0) then
7370       write (iout,*) "in e_modeller after SC restr end: dutheta"
7371       do i=ithet_start,ithet_end
7372         write (iout,*) i,dutheta(i)
7373       enddo
7374       endif
7375       if (waga_d.eq.1.0d0) then
7376       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7377       do i=1,nres
7378         write (iout,*) i,(duscdiff(j,i),j=1,3)
7379         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7380       enddo
7381       endif
7382 #endif
7383
7384 c Total energy from homology restraints
7385 #ifdef DEBUG
7386       write (iout,*) "odleg",odleg," kat",kat
7387 #endif
7388 c
7389 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7390 c
7391 c     ehomology_constr=odleg+kat
7392 c
7393 c     For Lorentzian-type Urestr
7394 c
7395
7396       if (waga_dist.ge.0.0d0) then
7397 c
7398 c          For Gaussian-type Urestr
7399 c
7400         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7401      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7402 c     write (iout,*) "ehomology_constr=",ehomology_constr
7403       else
7404 c
7405 c          For Lorentzian-type Urestr
7406 c
7407         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7408      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7409 c     write (iout,*) "ehomology_constr=",ehomology_constr
7410       endif
7411 #ifdef DEBUG
7412       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7413      & "Eval",waga_theta,eval,
7414      &   "Erot",waga_d,Erot
7415       write (iout,*) "ehomology_constr",ehomology_constr
7416 #endif
7417       return
7418 c
7419 c FP 01/15 end
7420 c
7421   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7422   747 format(a12,i4,i4,i4,f8.3,f8.3)
7423   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7424   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7425   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7426      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7427       end
7428
7429 c------------------------------------------------------------------------------
7430       subroutine etor_d(etors_d)
7431 C 6/23/01 Compute double torsional energy
7432       implicit real*8 (a-h,o-z)
7433       include 'DIMENSIONS'
7434       include 'COMMON.VAR'
7435       include 'COMMON.GEO'
7436       include 'COMMON.LOCAL'
7437       include 'COMMON.TORSION'
7438       include 'COMMON.INTERACT'
7439       include 'COMMON.DERIV'
7440       include 'COMMON.CHAIN'
7441       include 'COMMON.NAMES'
7442       include 'COMMON.IOUNITS'
7443       include 'COMMON.FFIELD'
7444       include 'COMMON.TORCNSTR'
7445       include 'COMMON.CONTROL'
7446       logical lprn
7447 C Set lprn=.true. for debugging
7448       lprn=.false.
7449 c     lprn=.true.
7450       etors_d=0.0D0
7451 c      write(iout,*) "a tu??"
7452       do i=iphid_start,iphid_end
7453 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7454 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7455 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7456 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7457 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7458          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7459      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7460      &  (itype(i+1).eq.ntyp1)) cycle
7461 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7462         etors_d_ii=0.0D0
7463         itori=itortyp(itype(i-2))
7464         itori1=itortyp(itype(i-1))
7465         itori2=itortyp(itype(i))
7466         phii=phi(i)
7467         phii1=phi(i+1)
7468         gloci1=0.0D0
7469         gloci2=0.0D0
7470         iblock=1
7471         if (iabs(itype(i+1)).eq.20) iblock=2
7472 C Iblock=2 Proline type
7473 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7474 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7475 C        if (itype(i+1).eq.ntyp1) iblock=3
7476 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7477 C IS or IS NOT need for this
7478 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7479 C        is (itype(i-3).eq.ntyp1) ntblock=2
7480 C        ntblock is N-terminal blocking group
7481
7482 C Regular cosine and sine terms
7483         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7484 C Example of changes for NH3+ blocking group
7485 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7486 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7487           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7488           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7489           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7490           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7491           cosphi1=dcos(j*phii)
7492           sinphi1=dsin(j*phii)
7493           cosphi2=dcos(j*phii1)
7494           sinphi2=dsin(j*phii1)
7495           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7496      &     v2cij*cosphi2+v2sij*sinphi2
7497           if (energy_dec) etors_d_ii=etors_d_ii+
7498      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7499           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7500           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7501         enddo
7502         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7503           do l=1,k-1
7504             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7505             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7506             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7507             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7508             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7509             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7510             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7511             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7512             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7513      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7514             if (energy_dec) etors_d_ii=etors_d_ii+
7515      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7516      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7517             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7518      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7519             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7520      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7521           enddo
7522         enddo
7523           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7524      &         'etor_d',i,etors_d_ii
7525         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7526         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7527       enddo
7528       return
7529       end
7530 #endif
7531 c------------------------------------------------------------------------------
7532       subroutine eback_sc_corr(esccor)
7533 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7534 c        conformational states; temporarily implemented as differences
7535 c        between UNRES torsional potentials (dependent on three types of
7536 c        residues) and the torsional potentials dependent on all 20 types
7537 c        of residues computed from AM1  energy surfaces of terminally-blocked
7538 c        amino-acid residues.
7539       implicit real*8 (a-h,o-z)
7540       include 'DIMENSIONS'
7541       include 'COMMON.VAR'
7542       include 'COMMON.GEO'
7543       include 'COMMON.LOCAL'
7544       include 'COMMON.TORSION'
7545       include 'COMMON.SCCOR'
7546       include 'COMMON.INTERACT'
7547       include 'COMMON.DERIV'
7548       include 'COMMON.CHAIN'
7549       include 'COMMON.NAMES'
7550       include 'COMMON.IOUNITS'
7551       include 'COMMON.FFIELD'
7552       include 'COMMON.CONTROL'
7553       logical lprn
7554 C Set lprn=.true. for debugging
7555       lprn=.false.
7556 c      lprn=.true.
7557 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7558       esccor=0.0D0
7559       do i=itau_start,itau_end
7560         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7561         isccori=isccortyp(itype(i-2))
7562         isccori1=isccortyp(itype(i-1))
7563 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7564         phii=phi(i)
7565         do intertyp=1,3 !intertyp
7566          esccor_ii=0.0D0
7567 cc Added 09 May 2012 (Adasko)
7568 cc  Intertyp means interaction type of backbone mainchain correlation:
7569 c   1 = SC...Ca...Ca...Ca
7570 c   2 = Ca...Ca...Ca...SC
7571 c   3 = SC...Ca...Ca...SCi
7572         gloci=0.0D0
7573         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7574      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7575      &      (itype(i-1).eq.ntyp1)))
7576      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7577      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7578      &     .or.(itype(i).eq.ntyp1)))
7579      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7580      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7581      &      (itype(i-3).eq.ntyp1)))) cycle
7582         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7583         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7584      & cycle
7585        do j=1,nterm_sccor(isccori,isccori1)
7586           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7587           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7588           cosphi=dcos(j*tauangle(intertyp,i))
7589           sinphi=dsin(j*tauangle(intertyp,i))
7590           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7591           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7592           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7593         enddo
7594          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7595      &         'esccor',i,intertyp,esccor_ii
7596 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7597         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7598         if (lprn)
7599      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7600      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7601      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7602      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7603         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7604        enddo !intertyp
7605       enddo
7606
7607       return
7608       end
7609 c----------------------------------------------------------------------------
7610       subroutine multibody(ecorr)
7611 C This subroutine calculates multi-body contributions to energy following
7612 C the idea of Skolnick et al. If side chains I and J make a contact and
7613 C at the same time side chains I+1 and J+1 make a contact, an extra
7614 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7615       implicit real*8 (a-h,o-z)
7616       include 'DIMENSIONS'
7617       include 'COMMON.IOUNITS'
7618       include 'COMMON.DERIV'
7619       include 'COMMON.INTERACT'
7620       include 'COMMON.CONTACTS'
7621       double precision gx(3),gx1(3)
7622       logical lprn
7623
7624 C Set lprn=.true. for debugging
7625       lprn=.false.
7626
7627       if (lprn) then
7628         write (iout,'(a)') 'Contact function values:'
7629         do i=nnt,nct-2
7630           write (iout,'(i2,20(1x,i2,f10.5))')
7631      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7632         enddo
7633       endif
7634       ecorr=0.0D0
7635       do i=nnt,nct
7636         do j=1,3
7637           gradcorr(j,i)=0.0D0
7638           gradxorr(j,i)=0.0D0
7639         enddo
7640       enddo
7641       do i=nnt,nct-2
7642
7643         DO ISHIFT = 3,4
7644
7645         i1=i+ishift
7646         num_conti=num_cont(i)
7647         num_conti1=num_cont(i1)
7648         do jj=1,num_conti
7649           j=jcont(jj,i)
7650           do kk=1,num_conti1
7651             j1=jcont(kk,i1)
7652             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7653 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7654 cd   &                   ' ishift=',ishift
7655 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7656 C The system gains extra energy.
7657               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7658             endif   ! j1==j+-ishift
7659           enddo     ! kk
7660         enddo       ! jj
7661
7662         ENDDO ! ISHIFT
7663
7664       enddo         ! i
7665       return
7666       end
7667 c------------------------------------------------------------------------------
7668       double precision function esccorr(i,j,k,l,jj,kk)
7669       implicit real*8 (a-h,o-z)
7670       include 'DIMENSIONS'
7671       include 'COMMON.IOUNITS'
7672       include 'COMMON.DERIV'
7673       include 'COMMON.INTERACT'
7674       include 'COMMON.CONTACTS'
7675       double precision gx(3),gx1(3)
7676       logical lprn
7677       lprn=.false.
7678       eij=facont(jj,i)
7679       ekl=facont(kk,k)
7680 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7681 C Calculate the multi-body contribution to energy.
7682 C Calculate multi-body contributions to the gradient.
7683 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7684 cd   & k,l,(gacont(m,kk,k),m=1,3)
7685       do m=1,3
7686         gx(m) =ekl*gacont(m,jj,i)
7687         gx1(m)=eij*gacont(m,kk,k)
7688         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7689         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7690         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7691         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7692       enddo
7693       do m=i,j-1
7694         do ll=1,3
7695           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7696         enddo
7697       enddo
7698       do m=k,l-1
7699         do ll=1,3
7700           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7701         enddo
7702       enddo
7703       esccorr=-eij*ekl
7704       return
7705       end
7706 c------------------------------------------------------------------------------
7707       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7708 C This subroutine calculates multi-body contributions to hydrogen-bonding
7709       implicit real*8 (a-h,o-z)
7710       include 'DIMENSIONS'
7711       include 'COMMON.IOUNITS'
7712 #ifdef MPI
7713       include "mpif.h"
7714       parameter (max_cont=maxconts)
7715       parameter (max_dim=26)
7716       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7717       double precision zapas(max_dim,maxconts,max_fg_procs),
7718      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7719       common /przechowalnia/ zapas
7720       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7721      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7722 #endif
7723       include 'COMMON.SETUP'
7724       include 'COMMON.FFIELD'
7725       include 'COMMON.DERIV'
7726       include 'COMMON.INTERACT'
7727       include 'COMMON.CONTACTS'
7728       include 'COMMON.CONTROL'
7729       include 'COMMON.LOCAL'
7730       double precision gx(3),gx1(3),time00
7731       logical lprn,ldone
7732
7733 C Set lprn=.true. for debugging
7734       lprn=.false.
7735 #ifdef MPI
7736       n_corr=0
7737       n_corr1=0
7738       if (nfgtasks.le.1) goto 30
7739       if (lprn) then
7740         write (iout,'(a)') 'Contact function values before RECEIVE:'
7741         do i=nnt,nct-2
7742           write (iout,'(2i3,50(1x,i2,f5.2))')
7743      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7744      &    j=1,num_cont_hb(i))
7745         enddo
7746       endif
7747       call flush(iout)
7748       do i=1,ntask_cont_from
7749         ncont_recv(i)=0
7750       enddo
7751       do i=1,ntask_cont_to
7752         ncont_sent(i)=0
7753       enddo
7754 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7755 c     & ntask_cont_to
7756 C Make the list of contacts to send to send to other procesors
7757 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7758 c      call flush(iout)
7759       do i=iturn3_start,iturn3_end
7760 c        write (iout,*) "make contact list turn3",i," num_cont",
7761 c     &    num_cont_hb(i)
7762         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7763       enddo
7764       do i=iturn4_start,iturn4_end
7765 c        write (iout,*) "make contact list turn4",i," num_cont",
7766 c     &   num_cont_hb(i)
7767         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7768       enddo
7769       do ii=1,nat_sent
7770         i=iat_sent(ii)
7771 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7772 c     &    num_cont_hb(i)
7773         do j=1,num_cont_hb(i)
7774         do k=1,4
7775           jjc=jcont_hb(j,i)
7776           iproc=iint_sent_local(k,jjc,ii)
7777 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7778           if (iproc.gt.0) then
7779             ncont_sent(iproc)=ncont_sent(iproc)+1
7780             nn=ncont_sent(iproc)
7781             zapas(1,nn,iproc)=i
7782             zapas(2,nn,iproc)=jjc
7783             zapas(3,nn,iproc)=facont_hb(j,i)
7784             zapas(4,nn,iproc)=ees0p(j,i)
7785             zapas(5,nn,iproc)=ees0m(j,i)
7786             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7787             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7788             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7789             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7790             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7791             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7792             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7793             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7794             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7795             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7796             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7797             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7798             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7799             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7800             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7801             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7802             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7803             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7804             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7805             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7806             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7807           endif
7808         enddo
7809         enddo
7810       enddo
7811       if (lprn) then
7812       write (iout,*)
7813      &  "Numbers of contacts to be sent to other processors",
7814      &  (ncont_sent(i),i=1,ntask_cont_to)
7815       write (iout,*) "Contacts sent"
7816       do ii=1,ntask_cont_to
7817         nn=ncont_sent(ii)
7818         iproc=itask_cont_to(ii)
7819         write (iout,*) nn," contacts to processor",iproc,
7820      &   " of CONT_TO_COMM group"
7821         do i=1,nn
7822           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7823         enddo
7824       enddo
7825       call flush(iout)
7826       endif
7827       CorrelType=477
7828       CorrelID=fg_rank+1
7829       CorrelType1=478
7830       CorrelID1=nfgtasks+fg_rank+1
7831       ireq=0
7832 C Receive the numbers of needed contacts from other processors
7833       do ii=1,ntask_cont_from
7834         iproc=itask_cont_from(ii)
7835         ireq=ireq+1
7836         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7837      &    FG_COMM,req(ireq),IERR)
7838       enddo
7839 c      write (iout,*) "IRECV ended"
7840 c      call flush(iout)
7841 C Send the number of contacts needed by other processors
7842       do ii=1,ntask_cont_to
7843         iproc=itask_cont_to(ii)
7844         ireq=ireq+1
7845         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7846      &    FG_COMM,req(ireq),IERR)
7847       enddo
7848 c      write (iout,*) "ISEND ended"
7849 c      write (iout,*) "number of requests (nn)",ireq
7850       call flush(iout)
7851       if (ireq.gt.0)
7852      &  call MPI_Waitall(ireq,req,status_array,ierr)
7853 c      write (iout,*)
7854 c     &  "Numbers of contacts to be received from other processors",
7855 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7856 c      call flush(iout)
7857 C Receive contacts
7858       ireq=0
7859       do ii=1,ntask_cont_from
7860         iproc=itask_cont_from(ii)
7861         nn=ncont_recv(ii)
7862 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7863 c     &   " of CONT_TO_COMM group"
7864         call flush(iout)
7865         if (nn.gt.0) then
7866           ireq=ireq+1
7867           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7868      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7869 c          write (iout,*) "ireq,req",ireq,req(ireq)
7870         endif
7871       enddo
7872 C Send the contacts to processors that need them
7873       do ii=1,ntask_cont_to
7874         iproc=itask_cont_to(ii)
7875         nn=ncont_sent(ii)
7876 c        write (iout,*) nn," contacts to processor",iproc,
7877 c     &   " of CONT_TO_COMM group"
7878         if (nn.gt.0) then
7879           ireq=ireq+1
7880           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7881      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7882 c          write (iout,*) "ireq,req",ireq,req(ireq)
7883 c          do i=1,nn
7884 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7885 c          enddo
7886         endif
7887       enddo
7888 c      write (iout,*) "number of requests (contacts)",ireq
7889 c      write (iout,*) "req",(req(i),i=1,4)
7890 c      call flush(iout)
7891       if (ireq.gt.0)
7892      & call MPI_Waitall(ireq,req,status_array,ierr)
7893       do iii=1,ntask_cont_from
7894         iproc=itask_cont_from(iii)
7895         nn=ncont_recv(iii)
7896         if (lprn) then
7897         write (iout,*) "Received",nn," contacts from processor",iproc,
7898      &   " of CONT_FROM_COMM group"
7899         call flush(iout)
7900         do i=1,nn
7901           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7902         enddo
7903         call flush(iout)
7904         endif
7905         do i=1,nn
7906           ii=zapas_recv(1,i,iii)
7907 c Flag the received contacts to prevent double-counting
7908           jj=-zapas_recv(2,i,iii)
7909 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7910 c          call flush(iout)
7911           nnn=num_cont_hb(ii)+1
7912           num_cont_hb(ii)=nnn
7913           jcont_hb(nnn,ii)=jj
7914           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7915           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7916           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7917           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7918           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7919           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7920           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7921           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7922           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7923           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7924           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7925           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7926           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7927           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7928           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7929           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7930           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7931           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7932           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7933           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7934           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7935           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7936           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7937           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7938         enddo
7939       enddo
7940       call flush(iout)
7941       if (lprn) then
7942         write (iout,'(a)') 'Contact function values after receive:'
7943         do i=nnt,nct-2
7944           write (iout,'(2i3,50(1x,i3,f5.2))')
7945      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7946      &    j=1,num_cont_hb(i))
7947         enddo
7948         call flush(iout)
7949       endif
7950    30 continue
7951 #endif
7952       if (lprn) then
7953         write (iout,'(a)') 'Contact function values:'
7954         do i=nnt,nct-2
7955           write (iout,'(2i3,50(1x,i3,f5.2))')
7956      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7957      &    j=1,num_cont_hb(i))
7958         enddo
7959       endif
7960       ecorr=0.0D0
7961 C Remove the loop below after debugging !!!
7962       do i=nnt,nct
7963         do j=1,3
7964           gradcorr(j,i)=0.0D0
7965           gradxorr(j,i)=0.0D0
7966         enddo
7967       enddo
7968 C Calculate the local-electrostatic correlation terms
7969       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7970         i1=i+1
7971         num_conti=num_cont_hb(i)
7972         num_conti1=num_cont_hb(i+1)
7973         do jj=1,num_conti
7974           j=jcont_hb(jj,i)
7975           jp=iabs(j)
7976           do kk=1,num_conti1
7977             j1=jcont_hb(kk,i1)
7978             jp1=iabs(j1)
7979 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7980 c     &         ' jj=',jj,' kk=',kk
7981             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7982      &          .or. j.lt.0 .and. j1.gt.0) .and.
7983      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7984 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7985 C The system gains extra energy.
7986               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7987               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7988      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7989               n_corr=n_corr+1
7990             else if (j1.eq.j) then
7991 C Contacts I-J and I-(J+1) occur simultaneously.
7992 C The system loses extra energy.
7993 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7994             endif
7995           enddo ! kk
7996           do kk=1,num_conti
7997             j1=jcont_hb(kk,i)
7998 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7999 c    &         ' jj=',jj,' kk=',kk
8000             if (j1.eq.j+1) then
8001 C Contacts I-J and (I+1)-J occur simultaneously.
8002 C The system loses extra energy.
8003 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8004             endif ! j1==j+1
8005           enddo ! kk
8006         enddo ! jj
8007       enddo ! i
8008       return
8009       end
8010 c------------------------------------------------------------------------------
8011       subroutine add_hb_contact(ii,jj,itask)
8012       implicit real*8 (a-h,o-z)
8013       include "DIMENSIONS"
8014       include "COMMON.IOUNITS"
8015       integer max_cont
8016       integer max_dim
8017       parameter (max_cont=maxconts)
8018       parameter (max_dim=26)
8019       include "COMMON.CONTACTS"
8020       double precision zapas(max_dim,maxconts,max_fg_procs),
8021      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8022       common /przechowalnia/ zapas
8023       integer i,j,ii,jj,iproc,itask(4),nn
8024 c      write (iout,*) "itask",itask
8025       do i=1,2
8026         iproc=itask(i)
8027         if (iproc.gt.0) then
8028           do j=1,num_cont_hb(ii)
8029             jjc=jcont_hb(j,ii)
8030 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8031             if (jjc.eq.jj) then
8032               ncont_sent(iproc)=ncont_sent(iproc)+1
8033               nn=ncont_sent(iproc)
8034               zapas(1,nn,iproc)=ii
8035               zapas(2,nn,iproc)=jjc
8036               zapas(3,nn,iproc)=facont_hb(j,ii)
8037               zapas(4,nn,iproc)=ees0p(j,ii)
8038               zapas(5,nn,iproc)=ees0m(j,ii)
8039               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8040               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8041               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8042               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8043               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8044               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8045               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8046               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8047               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8048               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8049               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8050               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8051               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8052               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8053               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8054               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8055               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8056               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8057               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8058               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8059               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8060               exit
8061             endif
8062           enddo
8063         endif
8064       enddo
8065       return
8066       end
8067 c------------------------------------------------------------------------------
8068       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8069      &  n_corr1)
8070 C This subroutine calculates multi-body contributions to hydrogen-bonding
8071       implicit real*8 (a-h,o-z)
8072       include 'DIMENSIONS'
8073       include 'COMMON.IOUNITS'
8074 #ifdef MPI
8075       include "mpif.h"
8076       parameter (max_cont=maxconts)
8077       parameter (max_dim=70)
8078       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8079       double precision zapas(max_dim,maxconts,max_fg_procs),
8080      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8081       common /przechowalnia/ zapas
8082       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8083      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8084 #endif
8085       include 'COMMON.SETUP'
8086       include 'COMMON.FFIELD'
8087       include 'COMMON.DERIV'
8088       include 'COMMON.LOCAL'
8089       include 'COMMON.INTERACT'
8090       include 'COMMON.CONTACTS'
8091       include 'COMMON.CHAIN'
8092       include 'COMMON.CONTROL'
8093       double precision gx(3),gx1(3)
8094       integer num_cont_hb_old(maxres)
8095       logical lprn,ldone
8096       double precision eello4,eello5,eelo6,eello_turn6
8097       external eello4,eello5,eello6,eello_turn6
8098 C Set lprn=.true. for debugging
8099       lprn=.false.
8100       eturn6=0.0d0
8101 #ifdef MPI
8102       do i=1,nres
8103         num_cont_hb_old(i)=num_cont_hb(i)
8104       enddo
8105       n_corr=0
8106       n_corr1=0
8107       if (nfgtasks.le.1) goto 30
8108       if (lprn) then
8109         write (iout,'(a)') 'Contact function values before RECEIVE:'
8110         do i=nnt,nct-2
8111           write (iout,'(2i3,50(1x,i2,f5.2))')
8112      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8113      &    j=1,num_cont_hb(i))
8114         enddo
8115       endif
8116       call flush(iout)
8117       do i=1,ntask_cont_from
8118         ncont_recv(i)=0
8119       enddo
8120       do i=1,ntask_cont_to
8121         ncont_sent(i)=0
8122       enddo
8123 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8124 c     & ntask_cont_to
8125 C Make the list of contacts to send to send to other procesors
8126       do i=iturn3_start,iturn3_end
8127 c        write (iout,*) "make contact list turn3",i," num_cont",
8128 c     &    num_cont_hb(i)
8129         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8130       enddo
8131       do i=iturn4_start,iturn4_end
8132 c        write (iout,*) "make contact list turn4",i," num_cont",
8133 c     &   num_cont_hb(i)
8134         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8135       enddo
8136       do ii=1,nat_sent
8137         i=iat_sent(ii)
8138 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8139 c     &    num_cont_hb(i)
8140         do j=1,num_cont_hb(i)
8141         do k=1,4
8142           jjc=jcont_hb(j,i)
8143           iproc=iint_sent_local(k,jjc,ii)
8144 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8145           if (iproc.ne.0) then
8146             ncont_sent(iproc)=ncont_sent(iproc)+1
8147             nn=ncont_sent(iproc)
8148             zapas(1,nn,iproc)=i
8149             zapas(2,nn,iproc)=jjc
8150             zapas(3,nn,iproc)=d_cont(j,i)
8151             ind=3
8152             do kk=1,3
8153               ind=ind+1
8154               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8155             enddo
8156             do kk=1,2
8157               do ll=1,2
8158                 ind=ind+1
8159                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8160               enddo
8161             enddo
8162             do jj=1,5
8163               do kk=1,3
8164                 do ll=1,2
8165                   do mm=1,2
8166                     ind=ind+1
8167                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8168                   enddo
8169                 enddo
8170               enddo
8171             enddo
8172           endif
8173         enddo
8174         enddo
8175       enddo
8176       if (lprn) then
8177       write (iout,*)
8178      &  "Numbers of contacts to be sent to other processors",
8179      &  (ncont_sent(i),i=1,ntask_cont_to)
8180       write (iout,*) "Contacts sent"
8181       do ii=1,ntask_cont_to
8182         nn=ncont_sent(ii)
8183         iproc=itask_cont_to(ii)
8184         write (iout,*) nn," contacts to processor",iproc,
8185      &   " of CONT_TO_COMM group"
8186         do i=1,nn
8187           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8188         enddo
8189       enddo
8190       call flush(iout)
8191       endif
8192       CorrelType=477
8193       CorrelID=fg_rank+1
8194       CorrelType1=478
8195       CorrelID1=nfgtasks+fg_rank+1
8196       ireq=0
8197 C Receive the numbers of needed contacts from other processors
8198       do ii=1,ntask_cont_from
8199         iproc=itask_cont_from(ii)
8200         ireq=ireq+1
8201         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8202      &    FG_COMM,req(ireq),IERR)
8203       enddo
8204 c      write (iout,*) "IRECV ended"
8205 c      call flush(iout)
8206 C Send the number of contacts needed by other processors
8207       do ii=1,ntask_cont_to
8208         iproc=itask_cont_to(ii)
8209         ireq=ireq+1
8210         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8211      &    FG_COMM,req(ireq),IERR)
8212       enddo
8213 c      write (iout,*) "ISEND ended"
8214 c      write (iout,*) "number of requests (nn)",ireq
8215       call flush(iout)
8216       if (ireq.gt.0)
8217      &  call MPI_Waitall(ireq,req,status_array,ierr)
8218 c      write (iout,*)
8219 c     &  "Numbers of contacts to be received from other processors",
8220 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8221 c      call flush(iout)
8222 C Receive contacts
8223       ireq=0
8224       do ii=1,ntask_cont_from
8225         iproc=itask_cont_from(ii)
8226         nn=ncont_recv(ii)
8227 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8228 c     &   " of CONT_TO_COMM group"
8229         call flush(iout)
8230         if (nn.gt.0) then
8231           ireq=ireq+1
8232           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8233      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8234 c          write (iout,*) "ireq,req",ireq,req(ireq)
8235         endif
8236       enddo
8237 C Send the contacts to processors that need them
8238       do ii=1,ntask_cont_to
8239         iproc=itask_cont_to(ii)
8240         nn=ncont_sent(ii)
8241 c        write (iout,*) nn," contacts to processor",iproc,
8242 c     &   " of CONT_TO_COMM group"
8243         if (nn.gt.0) then
8244           ireq=ireq+1
8245           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8246      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8247 c          write (iout,*) "ireq,req",ireq,req(ireq)
8248 c          do i=1,nn
8249 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8250 c          enddo
8251         endif
8252       enddo
8253 c      write (iout,*) "number of requests (contacts)",ireq
8254 c      write (iout,*) "req",(req(i),i=1,4)
8255 c      call flush(iout)
8256       if (ireq.gt.0)
8257      & call MPI_Waitall(ireq,req,status_array,ierr)
8258       do iii=1,ntask_cont_from
8259         iproc=itask_cont_from(iii)
8260         nn=ncont_recv(iii)
8261         if (lprn) then
8262         write (iout,*) "Received",nn," contacts from processor",iproc,
8263      &   " of CONT_FROM_COMM group"
8264         call flush(iout)
8265         do i=1,nn
8266           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8267         enddo
8268         call flush(iout)
8269         endif
8270         do i=1,nn
8271           ii=zapas_recv(1,i,iii)
8272 c Flag the received contacts to prevent double-counting
8273           jj=-zapas_recv(2,i,iii)
8274 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8275 c          call flush(iout)
8276           nnn=num_cont_hb(ii)+1
8277           num_cont_hb(ii)=nnn
8278           jcont_hb(nnn,ii)=jj
8279           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8280           ind=3
8281           do kk=1,3
8282             ind=ind+1
8283             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8284           enddo
8285           do kk=1,2
8286             do ll=1,2
8287               ind=ind+1
8288               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8289             enddo
8290           enddo
8291           do jj=1,5
8292             do kk=1,3
8293               do ll=1,2
8294                 do mm=1,2
8295                   ind=ind+1
8296                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8297                 enddo
8298               enddo
8299             enddo
8300           enddo
8301         enddo
8302       enddo
8303       call flush(iout)
8304       if (lprn) then
8305         write (iout,'(a)') 'Contact function values after receive:'
8306         do i=nnt,nct-2
8307           write (iout,'(2i3,50(1x,i3,5f6.3))')
8308      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8309      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8310         enddo
8311         call flush(iout)
8312       endif
8313    30 continue
8314 #endif
8315       if (lprn) then
8316         write (iout,'(a)') 'Contact function values:'
8317         do i=nnt,nct-2
8318           write (iout,'(2i3,50(1x,i2,5f6.3))')
8319      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8320      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8321         enddo
8322       endif
8323       ecorr=0.0D0
8324       ecorr5=0.0d0
8325       ecorr6=0.0d0
8326 C Remove the loop below after debugging !!!
8327       do i=nnt,nct
8328         do j=1,3
8329           gradcorr(j,i)=0.0D0
8330           gradxorr(j,i)=0.0D0
8331         enddo
8332       enddo
8333 C Calculate the dipole-dipole interaction energies
8334       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8335       do i=iatel_s,iatel_e+1
8336         num_conti=num_cont_hb(i)
8337         do jj=1,num_conti
8338           j=jcont_hb(jj,i)
8339 #ifdef MOMENT
8340           call dipole(i,j,jj)
8341 #endif
8342         enddo
8343       enddo
8344       endif
8345 C Calculate the local-electrostatic correlation terms
8346 c                write (iout,*) "gradcorr5 in eello5 before loop"
8347 c                do iii=1,nres
8348 c                  write (iout,'(i5,3f10.5)')
8349 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8350 c                enddo
8351       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8352 c        write (iout,*) "corr loop i",i
8353         i1=i+1
8354         num_conti=num_cont_hb(i)
8355         num_conti1=num_cont_hb(i+1)
8356         do jj=1,num_conti
8357           j=jcont_hb(jj,i)
8358           jp=iabs(j)
8359           do kk=1,num_conti1
8360             j1=jcont_hb(kk,i1)
8361             jp1=iabs(j1)
8362 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8363 c     &         ' jj=',jj,' kk=',kk
8364 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8365             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8366      &          .or. j.lt.0 .and. j1.gt.0) .and.
8367      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8368 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8369 C The system gains extra energy.
8370               n_corr=n_corr+1
8371               sqd1=dsqrt(d_cont(jj,i))
8372               sqd2=dsqrt(d_cont(kk,i1))
8373               sred_geom = sqd1*sqd2
8374               IF (sred_geom.lt.cutoff_corr) THEN
8375                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8376      &            ekont,fprimcont)
8377 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8378 cd     &         ' jj=',jj,' kk=',kk
8379                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8380                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8381                 do l=1,3
8382                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8383                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8384                 enddo
8385                 n_corr1=n_corr1+1
8386 cd               write (iout,*) 'sred_geom=',sred_geom,
8387 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8388 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8389 cd               write (iout,*) "g_contij",g_contij
8390 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8391 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8392                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8393                 if (wcorr4.gt.0.0d0)
8394      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8395                   if (energy_dec.and.wcorr4.gt.0.0d0)
8396      1                 write (iout,'(a6,4i5,0pf7.3)')
8397      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8398 c                write (iout,*) "gradcorr5 before eello5"
8399 c                do iii=1,nres
8400 c                  write (iout,'(i5,3f10.5)')
8401 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8402 c                enddo
8403                 if (wcorr5.gt.0.0d0)
8404      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8405 c                write (iout,*) "gradcorr5 after eello5"
8406 c                do iii=1,nres
8407 c                  write (iout,'(i5,3f10.5)')
8408 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8409 c                enddo
8410                   if (energy_dec.and.wcorr5.gt.0.0d0)
8411      1                 write (iout,'(a6,4i5,0pf7.3)')
8412      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8413 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8414 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8415                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8416      &               .or. wturn6.eq.0.0d0))then
8417 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8418                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8419                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8420      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8421 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8422 cd     &            'ecorr6=',ecorr6
8423 cd                write (iout,'(4e15.5)') sred_geom,
8424 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8425 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8426 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8427                 else if (wturn6.gt.0.0d0
8428      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8429 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8430                   eturn6=eturn6+eello_turn6(i,jj,kk)
8431                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8432      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8433 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8434                 endif
8435               ENDIF
8436 1111          continue
8437             endif
8438           enddo ! kk
8439         enddo ! jj
8440       enddo ! i
8441       do i=1,nres
8442         num_cont_hb(i)=num_cont_hb_old(i)
8443       enddo
8444 c                write (iout,*) "gradcorr5 in eello5"
8445 c                do iii=1,nres
8446 c                  write (iout,'(i5,3f10.5)')
8447 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8448 c                enddo
8449       return
8450       end
8451 c------------------------------------------------------------------------------
8452       subroutine add_hb_contact_eello(ii,jj,itask)
8453       implicit real*8 (a-h,o-z)
8454       include "DIMENSIONS"
8455       include "COMMON.IOUNITS"
8456       integer max_cont
8457       integer max_dim
8458       parameter (max_cont=maxconts)
8459       parameter (max_dim=70)
8460       include "COMMON.CONTACTS"
8461       double precision zapas(max_dim,maxconts,max_fg_procs),
8462      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8463       common /przechowalnia/ zapas
8464       integer i,j,ii,jj,iproc,itask(4),nn
8465 c      write (iout,*) "itask",itask
8466       do i=1,2
8467         iproc=itask(i)
8468         if (iproc.gt.0) then
8469           do j=1,num_cont_hb(ii)
8470             jjc=jcont_hb(j,ii)
8471 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8472             if (jjc.eq.jj) then
8473               ncont_sent(iproc)=ncont_sent(iproc)+1
8474               nn=ncont_sent(iproc)
8475               zapas(1,nn,iproc)=ii
8476               zapas(2,nn,iproc)=jjc
8477               zapas(3,nn,iproc)=d_cont(j,ii)
8478               ind=3
8479               do kk=1,3
8480                 ind=ind+1
8481                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8482               enddo
8483               do kk=1,2
8484                 do ll=1,2
8485                   ind=ind+1
8486                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8487                 enddo
8488               enddo
8489               do jj=1,5
8490                 do kk=1,3
8491                   do ll=1,2
8492                     do mm=1,2
8493                       ind=ind+1
8494                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8495                     enddo
8496                   enddo
8497                 enddo
8498               enddo
8499               exit
8500             endif
8501           enddo
8502         endif
8503       enddo
8504       return
8505       end
8506 c------------------------------------------------------------------------------
8507       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8508       implicit real*8 (a-h,o-z)
8509       include 'DIMENSIONS'
8510       include 'COMMON.IOUNITS'
8511       include 'COMMON.DERIV'
8512       include 'COMMON.INTERACT'
8513       include 'COMMON.CONTACTS'
8514       double precision gx(3),gx1(3)
8515       logical lprn
8516       lprn=.false.
8517       eij=facont_hb(jj,i)
8518       ekl=facont_hb(kk,k)
8519       ees0pij=ees0p(jj,i)
8520       ees0pkl=ees0p(kk,k)
8521       ees0mij=ees0m(jj,i)
8522       ees0mkl=ees0m(kk,k)
8523       ekont=eij*ekl
8524       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8525 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8526 C Following 4 lines for diagnostics.
8527 cd    ees0pkl=0.0D0
8528 cd    ees0pij=1.0D0
8529 cd    ees0mkl=0.0D0
8530 cd    ees0mij=1.0D0
8531 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8532 c     & 'Contacts ',i,j,
8533 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8534 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8535 c     & 'gradcorr_long'
8536 C Calculate the multi-body contribution to energy.
8537 c      ecorr=ecorr+ekont*ees
8538 C Calculate multi-body contributions to the gradient.
8539       coeffpees0pij=coeffp*ees0pij
8540       coeffmees0mij=coeffm*ees0mij
8541       coeffpees0pkl=coeffp*ees0pkl
8542       coeffmees0mkl=coeffm*ees0mkl
8543       do ll=1,3
8544 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8545         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8546      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8547      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8548         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8549      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8550      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8551 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8552         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8553      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8554      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8555         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8556      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8557      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8558         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8559      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8560      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8561         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8562         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8563         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8564      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8565      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8566         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8567         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8568 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8569       enddo
8570 c      write (iout,*)
8571 cgrad      do m=i+1,j-1
8572 cgrad        do ll=1,3
8573 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8574 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8575 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8576 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8577 cgrad        enddo
8578 cgrad      enddo
8579 cgrad      do m=k+1,l-1
8580 cgrad        do ll=1,3
8581 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8582 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8583 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8584 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8585 cgrad        enddo
8586 cgrad      enddo
8587 c      write (iout,*) "ehbcorr",ekont*ees
8588       ehbcorr=ekont*ees
8589       return
8590       end
8591 #ifdef MOMENT
8592 C---------------------------------------------------------------------------
8593       subroutine dipole(i,j,jj)
8594       implicit real*8 (a-h,o-z)
8595       include 'DIMENSIONS'
8596       include 'COMMON.IOUNITS'
8597       include 'COMMON.CHAIN'
8598       include 'COMMON.FFIELD'
8599       include 'COMMON.DERIV'
8600       include 'COMMON.INTERACT'
8601       include 'COMMON.CONTACTS'
8602       include 'COMMON.TORSION'
8603       include 'COMMON.VAR'
8604       include 'COMMON.GEO'
8605       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8606      &  auxmat(2,2)
8607       iti1 = itortyp(itype(i+1))
8608       if (j.lt.nres-1) then
8609         itj1 = itortyp(itype(j+1))
8610       else
8611         itj1=ntortyp
8612       endif
8613       do iii=1,2
8614         dipi(iii,1)=Ub2(iii,i)
8615         dipderi(iii)=Ub2der(iii,i)
8616         dipi(iii,2)=b1(iii,i+1)
8617         dipj(iii,1)=Ub2(iii,j)
8618         dipderj(iii)=Ub2der(iii,j)
8619         dipj(iii,2)=b1(iii,j+1)
8620       enddo
8621       kkk=0
8622       do iii=1,2
8623         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8624         do jjj=1,2
8625           kkk=kkk+1
8626           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8627         enddo
8628       enddo
8629       do kkk=1,5
8630         do lll=1,3
8631           mmm=0
8632           do iii=1,2
8633             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8634      &        auxvec(1))
8635             do jjj=1,2
8636               mmm=mmm+1
8637               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8638             enddo
8639           enddo
8640         enddo
8641       enddo
8642       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8643       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8644       do iii=1,2
8645         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8646       enddo
8647       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8648       do iii=1,2
8649         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8650       enddo
8651       return
8652       end
8653 #endif
8654 C---------------------------------------------------------------------------
8655       subroutine calc_eello(i,j,k,l,jj,kk)
8656 C
8657 C This subroutine computes matrices and vectors needed to calculate
8658 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8659 C
8660       implicit real*8 (a-h,o-z)
8661       include 'DIMENSIONS'
8662       include 'COMMON.IOUNITS'
8663       include 'COMMON.CHAIN'
8664       include 'COMMON.DERIV'
8665       include 'COMMON.INTERACT'
8666       include 'COMMON.CONTACTS'
8667       include 'COMMON.TORSION'
8668       include 'COMMON.VAR'
8669       include 'COMMON.GEO'
8670       include 'COMMON.FFIELD'
8671       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8672      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8673       logical lprn
8674       common /kutas/ lprn
8675 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8676 cd     & ' jj=',jj,' kk=',kk
8677 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8678 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8679 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8680       do iii=1,2
8681         do jjj=1,2
8682           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8683           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8684         enddo
8685       enddo
8686       call transpose2(aa1(1,1),aa1t(1,1))
8687       call transpose2(aa2(1,1),aa2t(1,1))
8688       do kkk=1,5
8689         do lll=1,3
8690           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8691      &      aa1tder(1,1,lll,kkk))
8692           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8693      &      aa2tder(1,1,lll,kkk))
8694         enddo
8695       enddo
8696       if (l.eq.j+1) then
8697 C parallel orientation of the two CA-CA-CA frames.
8698         if (i.gt.1) then
8699           iti=itortyp(itype(i))
8700         else
8701           iti=ntortyp
8702         endif
8703         itk1=itortyp(itype(k+1))
8704         itj=itortyp(itype(j))
8705         if (l.lt.nres-1) then
8706           itl1=itortyp(itype(l+1))
8707         else
8708           itl1=ntortyp
8709         endif
8710 C A1 kernel(j+1) A2T
8711 cd        do iii=1,2
8712 cd          write (iout,'(3f10.5,5x,3f10.5)')
8713 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8714 cd        enddo
8715         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8716      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8717      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8718 C Following matrices are needed only for 6-th order cumulants
8719         IF (wcorr6.gt.0.0d0) THEN
8720         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8721      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8722      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8723         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8724      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8725      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8726      &   ADtEAderx(1,1,1,1,1,1))
8727         lprn=.false.
8728         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8729      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8730      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8731      &   ADtEA1derx(1,1,1,1,1,1))
8732         ENDIF
8733 C End 6-th order cumulants
8734 cd        lprn=.false.
8735 cd        if (lprn) then
8736 cd        write (2,*) 'In calc_eello6'
8737 cd        do iii=1,2
8738 cd          write (2,*) 'iii=',iii
8739 cd          do kkk=1,5
8740 cd            write (2,*) 'kkk=',kkk
8741 cd            do jjj=1,2
8742 cd              write (2,'(3(2f10.5),5x)')
8743 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8744 cd            enddo
8745 cd          enddo
8746 cd        enddo
8747 cd        endif
8748         call transpose2(EUgder(1,1,k),auxmat(1,1))
8749         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8750         call transpose2(EUg(1,1,k),auxmat(1,1))
8751         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8752         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8753         do iii=1,2
8754           do kkk=1,5
8755             do lll=1,3
8756               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8757      &          EAEAderx(1,1,lll,kkk,iii,1))
8758             enddo
8759           enddo
8760         enddo
8761 C A1T kernel(i+1) A2
8762         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8763      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8764      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8765 C Following matrices are needed only for 6-th order cumulants
8766         IF (wcorr6.gt.0.0d0) THEN
8767         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8768      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8769      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8770         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8771      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8772      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8773      &   ADtEAderx(1,1,1,1,1,2))
8774         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8775      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8776      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8777      &   ADtEA1derx(1,1,1,1,1,2))
8778         ENDIF
8779 C End 6-th order cumulants
8780         call transpose2(EUgder(1,1,l),auxmat(1,1))
8781         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8782         call transpose2(EUg(1,1,l),auxmat(1,1))
8783         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8784         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8785         do iii=1,2
8786           do kkk=1,5
8787             do lll=1,3
8788               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8789      &          EAEAderx(1,1,lll,kkk,iii,2))
8790             enddo
8791           enddo
8792         enddo
8793 C AEAb1 and AEAb2
8794 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8795 C They are needed only when the fifth- or the sixth-order cumulants are
8796 C indluded.
8797         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8798         call transpose2(AEA(1,1,1),auxmat(1,1))
8799         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8800         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8801         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8802         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8803         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8804         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8805         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8806         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8807         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8808         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8809         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8810         call transpose2(AEA(1,1,2),auxmat(1,1))
8811         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8812         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8813         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8814         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8815         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8816         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8817         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8818         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8819         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8820         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8821         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8822 C Calculate the Cartesian derivatives of the vectors.
8823         do iii=1,2
8824           do kkk=1,5
8825             do lll=1,3
8826               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8827               call matvec2(auxmat(1,1),b1(1,i),
8828      &          AEAb1derx(1,lll,kkk,iii,1,1))
8829               call matvec2(auxmat(1,1),Ub2(1,i),
8830      &          AEAb2derx(1,lll,kkk,iii,1,1))
8831               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8832      &          AEAb1derx(1,lll,kkk,iii,2,1))
8833               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8834      &          AEAb2derx(1,lll,kkk,iii,2,1))
8835               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8836               call matvec2(auxmat(1,1),b1(1,j),
8837      &          AEAb1derx(1,lll,kkk,iii,1,2))
8838               call matvec2(auxmat(1,1),Ub2(1,j),
8839      &          AEAb2derx(1,lll,kkk,iii,1,2))
8840               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8841      &          AEAb1derx(1,lll,kkk,iii,2,2))
8842               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8843      &          AEAb2derx(1,lll,kkk,iii,2,2))
8844             enddo
8845           enddo
8846         enddo
8847         ENDIF
8848 C End vectors
8849       else
8850 C Antiparallel orientation of the two CA-CA-CA frames.
8851         if (i.gt.1) then
8852           iti=itortyp(itype(i))
8853         else
8854           iti=ntortyp
8855         endif
8856         itk1=itortyp(itype(k+1))
8857         itl=itortyp(itype(l))
8858         itj=itortyp(itype(j))
8859         if (j.lt.nres-1) then
8860           itj1=itortyp(itype(j+1))
8861         else
8862           itj1=ntortyp
8863         endif
8864 C A2 kernel(j-1)T A1T
8865         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8866      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8867      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8868 C Following matrices are needed only for 6-th order cumulants
8869         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8870      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8871         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8872      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8873      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8874         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8875      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8876      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8877      &   ADtEAderx(1,1,1,1,1,1))
8878         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8879      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8880      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8881      &   ADtEA1derx(1,1,1,1,1,1))
8882         ENDIF
8883 C End 6-th order cumulants
8884         call transpose2(EUgder(1,1,k),auxmat(1,1))
8885         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8886         call transpose2(EUg(1,1,k),auxmat(1,1))
8887         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8888         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8889         do iii=1,2
8890           do kkk=1,5
8891             do lll=1,3
8892               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8893      &          EAEAderx(1,1,lll,kkk,iii,1))
8894             enddo
8895           enddo
8896         enddo
8897 C A2T kernel(i+1)T A1
8898         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8899      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8900      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8901 C Following matrices are needed only for 6-th order cumulants
8902         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8903      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8904         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8905      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8906      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8907         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8908      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8909      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8910      &   ADtEAderx(1,1,1,1,1,2))
8911         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8912      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8913      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8914      &   ADtEA1derx(1,1,1,1,1,2))
8915         ENDIF
8916 C End 6-th order cumulants
8917         call transpose2(EUgder(1,1,j),auxmat(1,1))
8918         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8919         call transpose2(EUg(1,1,j),auxmat(1,1))
8920         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8921         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8922         do iii=1,2
8923           do kkk=1,5
8924             do lll=1,3
8925               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8926      &          EAEAderx(1,1,lll,kkk,iii,2))
8927             enddo
8928           enddo
8929         enddo
8930 C AEAb1 and AEAb2
8931 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8932 C They are needed only when the fifth- or the sixth-order cumulants are
8933 C indluded.
8934         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8935      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8936         call transpose2(AEA(1,1,1),auxmat(1,1))
8937         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8938         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8939         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8940         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8941         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8942         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8943         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8944         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8945         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8946         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8947         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8948         call transpose2(AEA(1,1,2),auxmat(1,1))
8949         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8950         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8951         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8952         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8953         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8954         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8955         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8956         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8957         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8958         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8959         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8960 C Calculate the Cartesian derivatives of the vectors.
8961         do iii=1,2
8962           do kkk=1,5
8963             do lll=1,3
8964               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8965               call matvec2(auxmat(1,1),b1(1,i),
8966      &          AEAb1derx(1,lll,kkk,iii,1,1))
8967               call matvec2(auxmat(1,1),Ub2(1,i),
8968      &          AEAb2derx(1,lll,kkk,iii,1,1))
8969               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8970      &          AEAb1derx(1,lll,kkk,iii,2,1))
8971               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8972      &          AEAb2derx(1,lll,kkk,iii,2,1))
8973               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8974               call matvec2(auxmat(1,1),b1(1,l),
8975      &          AEAb1derx(1,lll,kkk,iii,1,2))
8976               call matvec2(auxmat(1,1),Ub2(1,l),
8977      &          AEAb2derx(1,lll,kkk,iii,1,2))
8978               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8979      &          AEAb1derx(1,lll,kkk,iii,2,2))
8980               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8981      &          AEAb2derx(1,lll,kkk,iii,2,2))
8982             enddo
8983           enddo
8984         enddo
8985         ENDIF
8986 C End vectors
8987       endif
8988       return
8989       end
8990 C---------------------------------------------------------------------------
8991       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8992      &  KK,KKderg,AKA,AKAderg,AKAderx)
8993       implicit none
8994       integer nderg
8995       logical transp
8996       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8997      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8998      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8999       integer iii,kkk,lll
9000       integer jjj,mmm
9001       logical lprn
9002       common /kutas/ lprn
9003       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9004       do iii=1,nderg
9005         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9006      &    AKAderg(1,1,iii))
9007       enddo
9008 cd      if (lprn) write (2,*) 'In kernel'
9009       do kkk=1,5
9010 cd        if (lprn) write (2,*) 'kkk=',kkk
9011         do lll=1,3
9012           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9013      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9014 cd          if (lprn) then
9015 cd            write (2,*) 'lll=',lll
9016 cd            write (2,*) 'iii=1'
9017 cd            do jjj=1,2
9018 cd              write (2,'(3(2f10.5),5x)')
9019 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9020 cd            enddo
9021 cd          endif
9022           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9023      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9024 cd          if (lprn) then
9025 cd            write (2,*) 'lll=',lll
9026 cd            write (2,*) 'iii=2'
9027 cd            do jjj=1,2
9028 cd              write (2,'(3(2f10.5),5x)')
9029 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9030 cd            enddo
9031 cd          endif
9032         enddo
9033       enddo
9034       return
9035       end
9036 C---------------------------------------------------------------------------
9037       double precision function eello4(i,j,k,l,jj,kk)
9038       implicit real*8 (a-h,o-z)
9039       include 'DIMENSIONS'
9040       include 'COMMON.IOUNITS'
9041       include 'COMMON.CHAIN'
9042       include 'COMMON.DERIV'
9043       include 'COMMON.INTERACT'
9044       include 'COMMON.CONTACTS'
9045       include 'COMMON.TORSION'
9046       include 'COMMON.VAR'
9047       include 'COMMON.GEO'
9048       double precision pizda(2,2),ggg1(3),ggg2(3)
9049 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9050 cd        eello4=0.0d0
9051 cd        return
9052 cd      endif
9053 cd      print *,'eello4:',i,j,k,l,jj,kk
9054 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9055 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9056 cold      eij=facont_hb(jj,i)
9057 cold      ekl=facont_hb(kk,k)
9058 cold      ekont=eij*ekl
9059       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9060 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9061       gcorr_loc(k-1)=gcorr_loc(k-1)
9062      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9063       if (l.eq.j+1) then
9064         gcorr_loc(l-1)=gcorr_loc(l-1)
9065      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9066       else
9067         gcorr_loc(j-1)=gcorr_loc(j-1)
9068      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9069       endif
9070       do iii=1,2
9071         do kkk=1,5
9072           do lll=1,3
9073             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9074      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9075 cd            derx(lll,kkk,iii)=0.0d0
9076           enddo
9077         enddo
9078       enddo
9079 cd      gcorr_loc(l-1)=0.0d0
9080 cd      gcorr_loc(j-1)=0.0d0
9081 cd      gcorr_loc(k-1)=0.0d0
9082 cd      eel4=1.0d0
9083 cd      write (iout,*)'Contacts have occurred for peptide groups',
9084 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9085 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9086       if (j.lt.nres-1) then
9087         j1=j+1
9088         j2=j-1
9089       else
9090         j1=j-1
9091         j2=j-2
9092       endif
9093       if (l.lt.nres-1) then
9094         l1=l+1
9095         l2=l-1
9096       else
9097         l1=l-1
9098         l2=l-2
9099       endif
9100       do ll=1,3
9101 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9102 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9103         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9104         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9105 cgrad        ghalf=0.5d0*ggg1(ll)
9106         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9107         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9108         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9109         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9110         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9111         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9112 cgrad        ghalf=0.5d0*ggg2(ll)
9113         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9114         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9115         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9116         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9117         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9118         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9119       enddo
9120 cgrad      do m=i+1,j-1
9121 cgrad        do ll=1,3
9122 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9123 cgrad        enddo
9124 cgrad      enddo
9125 cgrad      do m=k+1,l-1
9126 cgrad        do ll=1,3
9127 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9128 cgrad        enddo
9129 cgrad      enddo
9130 cgrad      do m=i+2,j2
9131 cgrad        do ll=1,3
9132 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9133 cgrad        enddo
9134 cgrad      enddo
9135 cgrad      do m=k+2,l2
9136 cgrad        do ll=1,3
9137 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9138 cgrad        enddo
9139 cgrad      enddo
9140 cd      do iii=1,nres-3
9141 cd        write (2,*) iii,gcorr_loc(iii)
9142 cd      enddo
9143       eello4=ekont*eel4
9144 cd      write (2,*) 'ekont',ekont
9145 cd      write (iout,*) 'eello4',ekont*eel4
9146       return
9147       end
9148 C---------------------------------------------------------------------------
9149       double precision function eello5(i,j,k,l,jj,kk)
9150       implicit real*8 (a-h,o-z)
9151       include 'DIMENSIONS'
9152       include 'COMMON.IOUNITS'
9153       include 'COMMON.CHAIN'
9154       include 'COMMON.DERIV'
9155       include 'COMMON.INTERACT'
9156       include 'COMMON.CONTACTS'
9157       include 'COMMON.TORSION'
9158       include 'COMMON.VAR'
9159       include 'COMMON.GEO'
9160       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9161       double precision ggg1(3),ggg2(3)
9162 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9163 C                                                                              C
9164 C                            Parallel chains                                   C
9165 C                                                                              C
9166 C          o             o                   o             o                   C
9167 C         /l\           / \             \   / \           / \   /              C
9168 C        /   \         /   \             \ /   \         /   \ /               C
9169 C       j| o |l1       | o |              o| o |         | o |o                C
9170 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9171 C      \i/   \         /   \ /             /   \         /   \                 C
9172 C       o    k1             o                                                  C
9173 C         (I)          (II)                (III)          (IV)                 C
9174 C                                                                              C
9175 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9176 C                                                                              C
9177 C                            Antiparallel chains                               C
9178 C                                                                              C
9179 C          o             o                   o             o                   C
9180 C         /j\           / \             \   / \           / \   /              C
9181 C        /   \         /   \             \ /   \         /   \ /               C
9182 C      j1| o |l        | o |              o| o |         | o |o                C
9183 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9184 C      \i/   \         /   \ /             /   \         /   \                 C
9185 C       o     k1            o                                                  C
9186 C         (I)          (II)                (III)          (IV)                 C
9187 C                                                                              C
9188 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9189 C                                                                              C
9190 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9191 C                                                                              C
9192 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9193 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9194 cd        eello5=0.0d0
9195 cd        return
9196 cd      endif
9197 cd      write (iout,*)
9198 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9199 cd     &   ' and',k,l
9200       itk=itortyp(itype(k))
9201       itl=itortyp(itype(l))
9202       itj=itortyp(itype(j))
9203       eello5_1=0.0d0
9204       eello5_2=0.0d0
9205       eello5_3=0.0d0
9206       eello5_4=0.0d0
9207 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9208 cd     &   eel5_3_num,eel5_4_num)
9209       do iii=1,2
9210         do kkk=1,5
9211           do lll=1,3
9212             derx(lll,kkk,iii)=0.0d0
9213           enddo
9214         enddo
9215       enddo
9216 cd      eij=facont_hb(jj,i)
9217 cd      ekl=facont_hb(kk,k)
9218 cd      ekont=eij*ekl
9219 cd      write (iout,*)'Contacts have occurred for peptide groups',
9220 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9221 cd      goto 1111
9222 C Contribution from the graph I.
9223 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9224 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9225       call transpose2(EUg(1,1,k),auxmat(1,1))
9226       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9227       vv(1)=pizda(1,1)-pizda(2,2)
9228       vv(2)=pizda(1,2)+pizda(2,1)
9229       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9230      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9231 C Explicit gradient in virtual-dihedral angles.
9232       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9233      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9234      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9235       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9236       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9237       vv(1)=pizda(1,1)-pizda(2,2)
9238       vv(2)=pizda(1,2)+pizda(2,1)
9239       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9240      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9241      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9242       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9243       vv(1)=pizda(1,1)-pizda(2,2)
9244       vv(2)=pizda(1,2)+pizda(2,1)
9245       if (l.eq.j+1) then
9246         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9247      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9248      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9249       else
9250         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9251      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9252      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9253       endif
9254 C Cartesian gradient
9255       do iii=1,2
9256         do kkk=1,5
9257           do lll=1,3
9258             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9259      &        pizda(1,1))
9260             vv(1)=pizda(1,1)-pizda(2,2)
9261             vv(2)=pizda(1,2)+pizda(2,1)
9262             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9263      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9264      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9265           enddo
9266         enddo
9267       enddo
9268 c      goto 1112
9269 c1111  continue
9270 C Contribution from graph II
9271       call transpose2(EE(1,1,itk),auxmat(1,1))
9272       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9273       vv(1)=pizda(1,1)+pizda(2,2)
9274       vv(2)=pizda(2,1)-pizda(1,2)
9275       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9276      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9277 C Explicit gradient in virtual-dihedral angles.
9278       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9279      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9280       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9281       vv(1)=pizda(1,1)+pizda(2,2)
9282       vv(2)=pizda(2,1)-pizda(1,2)
9283       if (l.eq.j+1) then
9284         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9285      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9286      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9287       else
9288         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9289      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9290      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9291       endif
9292 C Cartesian gradient
9293       do iii=1,2
9294         do kkk=1,5
9295           do lll=1,3
9296             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9297      &        pizda(1,1))
9298             vv(1)=pizda(1,1)+pizda(2,2)
9299             vv(2)=pizda(2,1)-pizda(1,2)
9300             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9301      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9302      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9303           enddo
9304         enddo
9305       enddo
9306 cd      goto 1112
9307 cd1111  continue
9308       if (l.eq.j+1) then
9309 cd        goto 1110
9310 C Parallel orientation
9311 C Contribution from graph III
9312         call transpose2(EUg(1,1,l),auxmat(1,1))
9313         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9314         vv(1)=pizda(1,1)-pizda(2,2)
9315         vv(2)=pizda(1,2)+pizda(2,1)
9316         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9317      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9318 C Explicit gradient in virtual-dihedral angles.
9319         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9320      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9321      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9322         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9323         vv(1)=pizda(1,1)-pizda(2,2)
9324         vv(2)=pizda(1,2)+pizda(2,1)
9325         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9326      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9327      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9328         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9329         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9330         vv(1)=pizda(1,1)-pizda(2,2)
9331         vv(2)=pizda(1,2)+pizda(2,1)
9332         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9333      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9334      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9335 C Cartesian gradient
9336         do iii=1,2
9337           do kkk=1,5
9338             do lll=1,3
9339               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9340      &          pizda(1,1))
9341               vv(1)=pizda(1,1)-pizda(2,2)
9342               vv(2)=pizda(1,2)+pizda(2,1)
9343               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9344      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9345      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9346             enddo
9347           enddo
9348         enddo
9349 cd        goto 1112
9350 C Contribution from graph IV
9351 cd1110    continue
9352         call transpose2(EE(1,1,itl),auxmat(1,1))
9353         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9354         vv(1)=pizda(1,1)+pizda(2,2)
9355         vv(2)=pizda(2,1)-pizda(1,2)
9356         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9357      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9358 C Explicit gradient in virtual-dihedral angles.
9359         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9360      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9361         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9362         vv(1)=pizda(1,1)+pizda(2,2)
9363         vv(2)=pizda(2,1)-pizda(1,2)
9364         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9365      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9366      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9367 C Cartesian gradient
9368         do iii=1,2
9369           do kkk=1,5
9370             do lll=1,3
9371               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9372      &          pizda(1,1))
9373               vv(1)=pizda(1,1)+pizda(2,2)
9374               vv(2)=pizda(2,1)-pizda(1,2)
9375               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9376      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9377      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9378             enddo
9379           enddo
9380         enddo
9381       else
9382 C Antiparallel orientation
9383 C Contribution from graph III
9384 c        goto 1110
9385         call transpose2(EUg(1,1,j),auxmat(1,1))
9386         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9387         vv(1)=pizda(1,1)-pizda(2,2)
9388         vv(2)=pizda(1,2)+pizda(2,1)
9389         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9390      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9391 C Explicit gradient in virtual-dihedral angles.
9392         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9393      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9394      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9395         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9396         vv(1)=pizda(1,1)-pizda(2,2)
9397         vv(2)=pizda(1,2)+pizda(2,1)
9398         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9399      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9400      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9401         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9402         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9403         vv(1)=pizda(1,1)-pizda(2,2)
9404         vv(2)=pizda(1,2)+pizda(2,1)
9405         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9406      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9407      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9408 C Cartesian gradient
9409         do iii=1,2
9410           do kkk=1,5
9411             do lll=1,3
9412               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9413      &          pizda(1,1))
9414               vv(1)=pizda(1,1)-pizda(2,2)
9415               vv(2)=pizda(1,2)+pizda(2,1)
9416               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9417      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9418      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9419             enddo
9420           enddo
9421         enddo
9422 cd        goto 1112
9423 C Contribution from graph IV
9424 1110    continue
9425         call transpose2(EE(1,1,itj),auxmat(1,1))
9426         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9427         vv(1)=pizda(1,1)+pizda(2,2)
9428         vv(2)=pizda(2,1)-pizda(1,2)
9429         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9430      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9431 C Explicit gradient in virtual-dihedral angles.
9432         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9433      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9434         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9435         vv(1)=pizda(1,1)+pizda(2,2)
9436         vv(2)=pizda(2,1)-pizda(1,2)
9437         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9438      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9439      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9440 C Cartesian gradient
9441         do iii=1,2
9442           do kkk=1,5
9443             do lll=1,3
9444               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9445      &          pizda(1,1))
9446               vv(1)=pizda(1,1)+pizda(2,2)
9447               vv(2)=pizda(2,1)-pizda(1,2)
9448               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9449      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9450      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9451             enddo
9452           enddo
9453         enddo
9454       endif
9455 1112  continue
9456       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9457 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9458 cd        write (2,*) 'ijkl',i,j,k,l
9459 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9460 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9461 cd      endif
9462 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9463 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9464 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9465 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9466       if (j.lt.nres-1) then
9467         j1=j+1
9468         j2=j-1
9469       else
9470         j1=j-1
9471         j2=j-2
9472       endif
9473       if (l.lt.nres-1) then
9474         l1=l+1
9475         l2=l-1
9476       else
9477         l1=l-1
9478         l2=l-2
9479       endif
9480 cd      eij=1.0d0
9481 cd      ekl=1.0d0
9482 cd      ekont=1.0d0
9483 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9484 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9485 C        summed up outside the subrouine as for the other subroutines
9486 C        handling long-range interactions. The old code is commented out
9487 C        with "cgrad" to keep track of changes.
9488       do ll=1,3
9489 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9490 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9491         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9492         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9493 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9494 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9495 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9496 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9497 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9498 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9499 c     &   gradcorr5ij,
9500 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9501 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9502 cgrad        ghalf=0.5d0*ggg1(ll)
9503 cd        ghalf=0.0d0
9504         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9505         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9506         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9507         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9508         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9509         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9510 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9511 cgrad        ghalf=0.5d0*ggg2(ll)
9512 cd        ghalf=0.0d0
9513         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9514         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9515         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9516         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9517         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9518         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9519       enddo
9520 cd      goto 1112
9521 cgrad      do m=i+1,j-1
9522 cgrad        do ll=1,3
9523 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9524 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9525 cgrad        enddo
9526 cgrad      enddo
9527 cgrad      do m=k+1,l-1
9528 cgrad        do ll=1,3
9529 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9530 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9531 cgrad        enddo
9532 cgrad      enddo
9533 c1112  continue
9534 cgrad      do m=i+2,j2
9535 cgrad        do ll=1,3
9536 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9537 cgrad        enddo
9538 cgrad      enddo
9539 cgrad      do m=k+2,l2
9540 cgrad        do ll=1,3
9541 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9542 cgrad        enddo
9543 cgrad      enddo
9544 cd      do iii=1,nres-3
9545 cd        write (2,*) iii,g_corr5_loc(iii)
9546 cd      enddo
9547       eello5=ekont*eel5
9548 cd      write (2,*) 'ekont',ekont
9549 cd      write (iout,*) 'eello5',ekont*eel5
9550       return
9551       end
9552 c--------------------------------------------------------------------------
9553       double precision function eello6(i,j,k,l,jj,kk)
9554       implicit real*8 (a-h,o-z)
9555       include 'DIMENSIONS'
9556       include 'COMMON.IOUNITS'
9557       include 'COMMON.CHAIN'
9558       include 'COMMON.DERIV'
9559       include 'COMMON.INTERACT'
9560       include 'COMMON.CONTACTS'
9561       include 'COMMON.TORSION'
9562       include 'COMMON.VAR'
9563       include 'COMMON.GEO'
9564       include 'COMMON.FFIELD'
9565       double precision ggg1(3),ggg2(3)
9566 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9567 cd        eello6=0.0d0
9568 cd        return
9569 cd      endif
9570 cd      write (iout,*)
9571 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9572 cd     &   ' and',k,l
9573       eello6_1=0.0d0
9574       eello6_2=0.0d0
9575       eello6_3=0.0d0
9576       eello6_4=0.0d0
9577       eello6_5=0.0d0
9578       eello6_6=0.0d0
9579 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9580 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9581       do iii=1,2
9582         do kkk=1,5
9583           do lll=1,3
9584             derx(lll,kkk,iii)=0.0d0
9585           enddo
9586         enddo
9587       enddo
9588 cd      eij=facont_hb(jj,i)
9589 cd      ekl=facont_hb(kk,k)
9590 cd      ekont=eij*ekl
9591 cd      eij=1.0d0
9592 cd      ekl=1.0d0
9593 cd      ekont=1.0d0
9594       if (l.eq.j+1) then
9595         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9596         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9597         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9598         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9599         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9600         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9601       else
9602         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9603         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9604         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9605         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9606         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9607           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9608         else
9609           eello6_5=0.0d0
9610         endif
9611         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9612       endif
9613 C If turn contributions are considered, they will be handled separately.
9614       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9615 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9616 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9617 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9618 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9619 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9620 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9621 cd      goto 1112
9622       if (j.lt.nres-1) then
9623         j1=j+1
9624         j2=j-1
9625       else
9626         j1=j-1
9627         j2=j-2
9628       endif
9629       if (l.lt.nres-1) then
9630         l1=l+1
9631         l2=l-1
9632       else
9633         l1=l-1
9634         l2=l-2
9635       endif
9636       do ll=1,3
9637 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9638 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9639 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9640 cgrad        ghalf=0.5d0*ggg1(ll)
9641 cd        ghalf=0.0d0
9642         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9643         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9644         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9645         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9646         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9647         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9648         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9649         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9650 cgrad        ghalf=0.5d0*ggg2(ll)
9651 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9652 cd        ghalf=0.0d0
9653         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9654         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9655         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9656         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9657         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9658         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9659       enddo
9660 cd      goto 1112
9661 cgrad      do m=i+1,j-1
9662 cgrad        do ll=1,3
9663 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9664 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9665 cgrad        enddo
9666 cgrad      enddo
9667 cgrad      do m=k+1,l-1
9668 cgrad        do ll=1,3
9669 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9670 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9671 cgrad        enddo
9672 cgrad      enddo
9673 cgrad1112  continue
9674 cgrad      do m=i+2,j2
9675 cgrad        do ll=1,3
9676 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9677 cgrad        enddo
9678 cgrad      enddo
9679 cgrad      do m=k+2,l2
9680 cgrad        do ll=1,3
9681 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9682 cgrad        enddo
9683 cgrad      enddo
9684 cd      do iii=1,nres-3
9685 cd        write (2,*) iii,g_corr6_loc(iii)
9686 cd      enddo
9687       eello6=ekont*eel6
9688 cd      write (2,*) 'ekont',ekont
9689 cd      write (iout,*) 'eello6',ekont*eel6
9690       return
9691       end
9692 c--------------------------------------------------------------------------
9693       double precision function eello6_graph1(i,j,k,l,imat,swap)
9694       implicit real*8 (a-h,o-z)
9695       include 'DIMENSIONS'
9696       include 'COMMON.IOUNITS'
9697       include 'COMMON.CHAIN'
9698       include 'COMMON.DERIV'
9699       include 'COMMON.INTERACT'
9700       include 'COMMON.CONTACTS'
9701       include 'COMMON.TORSION'
9702       include 'COMMON.VAR'
9703       include 'COMMON.GEO'
9704       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9705       logical swap
9706       logical lprn
9707       common /kutas/ lprn
9708 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9709 C                                                                              C
9710 C      Parallel       Antiparallel                                             C
9711 C                                                                              C
9712 C          o             o                                                     C
9713 C         /l\           /j\                                                    C
9714 C        /   \         /   \                                                   C
9715 C       /| o |         | o |\                                                  C
9716 C     \ j|/k\|  /   \  |/k\|l /                                                C
9717 C      \ /   \ /     \ /   \ /                                                 C
9718 C       o     o       o     o                                                  C
9719 C       i             i                                                        C
9720 C                                                                              C
9721 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9722       itk=itortyp(itype(k))
9723       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9724       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9725       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9726       call transpose2(EUgC(1,1,k),auxmat(1,1))
9727       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9728       vv1(1)=pizda1(1,1)-pizda1(2,2)
9729       vv1(2)=pizda1(1,2)+pizda1(2,1)
9730       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9731       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9732       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9733       s5=scalar2(vv(1),Dtobr2(1,i))
9734 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9735       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9736       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9737      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9738      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9739      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9740      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9741      & +scalar2(vv(1),Dtobr2der(1,i)))
9742       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9743       vv1(1)=pizda1(1,1)-pizda1(2,2)
9744       vv1(2)=pizda1(1,2)+pizda1(2,1)
9745       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9746       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9747       if (l.eq.j+1) then
9748         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9749      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9750      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9751      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9752      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9753       else
9754         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9755      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9756      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9757      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9758      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9759       endif
9760       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9761       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9762       vv1(1)=pizda1(1,1)-pizda1(2,2)
9763       vv1(2)=pizda1(1,2)+pizda1(2,1)
9764       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9765      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9766      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9767      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9768       do iii=1,2
9769         if (swap) then
9770           ind=3-iii
9771         else
9772           ind=iii
9773         endif
9774         do kkk=1,5
9775           do lll=1,3
9776             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9777             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9778             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9779             call transpose2(EUgC(1,1,k),auxmat(1,1))
9780             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9781      &        pizda1(1,1))
9782             vv1(1)=pizda1(1,1)-pizda1(2,2)
9783             vv1(2)=pizda1(1,2)+pizda1(2,1)
9784             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9785             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9786      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9787             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9788      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9789             s5=scalar2(vv(1),Dtobr2(1,i))
9790             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9791           enddo
9792         enddo
9793       enddo
9794       return
9795       end
9796 c----------------------------------------------------------------------------
9797       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9798       implicit real*8 (a-h,o-z)
9799       include 'DIMENSIONS'
9800       include 'COMMON.IOUNITS'
9801       include 'COMMON.CHAIN'
9802       include 'COMMON.DERIV'
9803       include 'COMMON.INTERACT'
9804       include 'COMMON.CONTACTS'
9805       include 'COMMON.TORSION'
9806       include 'COMMON.VAR'
9807       include 'COMMON.GEO'
9808       logical swap
9809       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9810      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9811       logical lprn
9812       common /kutas/ lprn
9813 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9814 C                                                                              C
9815 C      Parallel       Antiparallel                                             C
9816 C                                                                              C
9817 C          o             o                                                     C
9818 C     \   /l\           /j\   /                                                C
9819 C      \ /   \         /   \ /                                                 C
9820 C       o| o |         | o |o                                                  C
9821 C     \ j|/k\|      \  |/k\|l                                                  C
9822 C      \ /   \       \ /   \                                                   C
9823 C       o             o                                                        C
9824 C       i             i                                                        C
9825 C                                                                              C
9826 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9827 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9828 C AL 7/4/01 s1 would occur in the sixth-order moment,
9829 C           but not in a cluster cumulant
9830 #ifdef MOMENT
9831       s1=dip(1,jj,i)*dip(1,kk,k)
9832 #endif
9833       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9834       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9835       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9836       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9837       call transpose2(EUg(1,1,k),auxmat(1,1))
9838       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9839       vv(1)=pizda(1,1)-pizda(2,2)
9840       vv(2)=pizda(1,2)+pizda(2,1)
9841       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9842 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9843 #ifdef MOMENT
9844       eello6_graph2=-(s1+s2+s3+s4)
9845 #else
9846       eello6_graph2=-(s2+s3+s4)
9847 #endif
9848 c      eello6_graph2=-s3
9849 C Derivatives in gamma(i-1)
9850       if (i.gt.1) then
9851 #ifdef MOMENT
9852         s1=dipderg(1,jj,i)*dip(1,kk,k)
9853 #endif
9854         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9855         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9856         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9857         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9858 #ifdef MOMENT
9859         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9860 #else
9861         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9862 #endif
9863 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9864       endif
9865 C Derivatives in gamma(k-1)
9866 #ifdef MOMENT
9867       s1=dip(1,jj,i)*dipderg(1,kk,k)
9868 #endif
9869       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9870       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9871       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9872       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9873       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9874       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9875       vv(1)=pizda(1,1)-pizda(2,2)
9876       vv(2)=pizda(1,2)+pizda(2,1)
9877       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9878 #ifdef MOMENT
9879       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9880 #else
9881       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9882 #endif
9883 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9884 C Derivatives in gamma(j-1) or gamma(l-1)
9885       if (j.gt.1) then
9886 #ifdef MOMENT
9887         s1=dipderg(3,jj,i)*dip(1,kk,k)
9888 #endif
9889         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9890         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9891         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9892         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9893         vv(1)=pizda(1,1)-pizda(2,2)
9894         vv(2)=pizda(1,2)+pizda(2,1)
9895         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9896 #ifdef MOMENT
9897         if (swap) then
9898           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9899         else
9900           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9901         endif
9902 #endif
9903         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9904 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9905       endif
9906 C Derivatives in gamma(l-1) or gamma(j-1)
9907       if (l.gt.1) then
9908 #ifdef MOMENT
9909         s1=dip(1,jj,i)*dipderg(3,kk,k)
9910 #endif
9911         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9912         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9913         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9914         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9915         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9916         vv(1)=pizda(1,1)-pizda(2,2)
9917         vv(2)=pizda(1,2)+pizda(2,1)
9918         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9919 #ifdef MOMENT
9920         if (swap) then
9921           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9922         else
9923           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9924         endif
9925 #endif
9926         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9927 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9928       endif
9929 C Cartesian derivatives.
9930       if (lprn) then
9931         write (2,*) 'In eello6_graph2'
9932         do iii=1,2
9933           write (2,*) 'iii=',iii
9934           do kkk=1,5
9935             write (2,*) 'kkk=',kkk
9936             do jjj=1,2
9937               write (2,'(3(2f10.5),5x)')
9938      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9939             enddo
9940           enddo
9941         enddo
9942       endif
9943       do iii=1,2
9944         do kkk=1,5
9945           do lll=1,3
9946 #ifdef MOMENT
9947             if (iii.eq.1) then
9948               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9949             else
9950               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9951             endif
9952 #endif
9953             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9954      &        auxvec(1))
9955             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9956             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9957      &        auxvec(1))
9958             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9959             call transpose2(EUg(1,1,k),auxmat(1,1))
9960             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9961      &        pizda(1,1))
9962             vv(1)=pizda(1,1)-pizda(2,2)
9963             vv(2)=pizda(1,2)+pizda(2,1)
9964             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9965 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9966 #ifdef MOMENT
9967             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9968 #else
9969             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9970 #endif
9971             if (swap) then
9972               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9973             else
9974               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9975             endif
9976           enddo
9977         enddo
9978       enddo
9979       return
9980       end
9981 c----------------------------------------------------------------------------
9982       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9983       implicit real*8 (a-h,o-z)
9984       include 'DIMENSIONS'
9985       include 'COMMON.IOUNITS'
9986       include 'COMMON.CHAIN'
9987       include 'COMMON.DERIV'
9988       include 'COMMON.INTERACT'
9989       include 'COMMON.CONTACTS'
9990       include 'COMMON.TORSION'
9991       include 'COMMON.VAR'
9992       include 'COMMON.GEO'
9993       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9994       logical swap
9995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9996 C                                                                              C
9997 C      Parallel       Antiparallel                                             C
9998 C                                                                              C
9999 C          o             o                                                     C
10000 C         /l\   /   \   /j\                                                    C
10001 C        /   \ /     \ /   \                                                   C
10002 C       /| o |o       o| o |\                                                  C
10003 C       j|/k\|  /      |/k\|l /                                                C
10004 C        /   \ /       /   \ /                                                 C
10005 C       /     o       /     o                                                  C
10006 C       i             i                                                        C
10007 C                                                                              C
10008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10009 C
10010 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10011 C           energy moment and not to the cluster cumulant.
10012       iti=itortyp(itype(i))
10013       if (j.lt.nres-1) then
10014         itj1=itortyp(itype(j+1))
10015       else
10016         itj1=ntortyp
10017       endif
10018       itk=itortyp(itype(k))
10019       itk1=itortyp(itype(k+1))
10020       if (l.lt.nres-1) then
10021         itl1=itortyp(itype(l+1))
10022       else
10023         itl1=ntortyp
10024       endif
10025 #ifdef MOMENT
10026       s1=dip(4,jj,i)*dip(4,kk,k)
10027 #endif
10028       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10029       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10030       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10031       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10032       call transpose2(EE(1,1,itk),auxmat(1,1))
10033       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10034       vv(1)=pizda(1,1)+pizda(2,2)
10035       vv(2)=pizda(2,1)-pizda(1,2)
10036       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10037 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10038 cd     & "sum",-(s2+s3+s4)
10039 #ifdef MOMENT
10040       eello6_graph3=-(s1+s2+s3+s4)
10041 #else
10042       eello6_graph3=-(s2+s3+s4)
10043 #endif
10044 c      eello6_graph3=-s4
10045 C Derivatives in gamma(k-1)
10046       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10047       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10048       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10049       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10050 C Derivatives in gamma(l-1)
10051       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10052       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10053       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10054       vv(1)=pizda(1,1)+pizda(2,2)
10055       vv(2)=pizda(2,1)-pizda(1,2)
10056       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10057       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10058 C Cartesian derivatives.
10059       do iii=1,2
10060         do kkk=1,5
10061           do lll=1,3
10062 #ifdef MOMENT
10063             if (iii.eq.1) then
10064               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10065             else
10066               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10067             endif
10068 #endif
10069             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10070      &        auxvec(1))
10071             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10072             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10073      &        auxvec(1))
10074             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10075             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10076      &        pizda(1,1))
10077             vv(1)=pizda(1,1)+pizda(2,2)
10078             vv(2)=pizda(2,1)-pizda(1,2)
10079             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10080 #ifdef MOMENT
10081             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10082 #else
10083             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10084 #endif
10085             if (swap) then
10086               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10087             else
10088               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10089             endif
10090 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10091           enddo
10092         enddo
10093       enddo
10094       return
10095       end
10096 c----------------------------------------------------------------------------
10097       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10098       implicit real*8 (a-h,o-z)
10099       include 'DIMENSIONS'
10100       include 'COMMON.IOUNITS'
10101       include 'COMMON.CHAIN'
10102       include 'COMMON.DERIV'
10103       include 'COMMON.INTERACT'
10104       include 'COMMON.CONTACTS'
10105       include 'COMMON.TORSION'
10106       include 'COMMON.VAR'
10107       include 'COMMON.GEO'
10108       include 'COMMON.FFIELD'
10109       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10110      & auxvec1(2),auxmat1(2,2)
10111       logical swap
10112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10113 C                                                                              C
10114 C      Parallel       Antiparallel                                             C
10115 C                                                                              C
10116 C          o             o                                                     C
10117 C         /l\   /   \   /j\                                                    C
10118 C        /   \ /     \ /   \                                                   C
10119 C       /| o |o       o| o |\                                                  C
10120 C     \ j|/k\|      \  |/k\|l                                                  C
10121 C      \ /   \       \ /   \                                                   C
10122 C       o     \       o     \                                                  C
10123 C       i             i                                                        C
10124 C                                                                              C
10125 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10126 C
10127 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10128 C           energy moment and not to the cluster cumulant.
10129 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10130       iti=itortyp(itype(i))
10131       itj=itortyp(itype(j))
10132       if (j.lt.nres-1) then
10133         itj1=itortyp(itype(j+1))
10134       else
10135         itj1=ntortyp
10136       endif
10137       itk=itortyp(itype(k))
10138       if (k.lt.nres-1) then
10139         itk1=itortyp(itype(k+1))
10140       else
10141         itk1=ntortyp
10142       endif
10143       itl=itortyp(itype(l))
10144       if (l.lt.nres-1) then
10145         itl1=itortyp(itype(l+1))
10146       else
10147         itl1=ntortyp
10148       endif
10149 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10150 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10151 cd     & ' itl',itl,' itl1',itl1
10152 #ifdef MOMENT
10153       if (imat.eq.1) then
10154         s1=dip(3,jj,i)*dip(3,kk,k)
10155       else
10156         s1=dip(2,jj,j)*dip(2,kk,l)
10157       endif
10158 #endif
10159       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10160       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10161       if (j.eq.l+1) then
10162         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10163         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10164       else
10165         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10166         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10167       endif
10168       call transpose2(EUg(1,1,k),auxmat(1,1))
10169       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10170       vv(1)=pizda(1,1)-pizda(2,2)
10171       vv(2)=pizda(2,1)+pizda(1,2)
10172       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10173 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10174 #ifdef MOMENT
10175       eello6_graph4=-(s1+s2+s3+s4)
10176 #else
10177       eello6_graph4=-(s2+s3+s4)
10178 #endif
10179 C Derivatives in gamma(i-1)
10180       if (i.gt.1) then
10181 #ifdef MOMENT
10182         if (imat.eq.1) then
10183           s1=dipderg(2,jj,i)*dip(3,kk,k)
10184         else
10185           s1=dipderg(4,jj,j)*dip(2,kk,l)
10186         endif
10187 #endif
10188         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10189         if (j.eq.l+1) then
10190           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10191           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10192         else
10193           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10194           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10195         endif
10196         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10197         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10198 cd          write (2,*) 'turn6 derivatives'
10199 #ifdef MOMENT
10200           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10201 #else
10202           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10203 #endif
10204         else
10205 #ifdef MOMENT
10206           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10207 #else
10208           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10209 #endif
10210         endif
10211       endif
10212 C Derivatives in gamma(k-1)
10213 #ifdef MOMENT
10214       if (imat.eq.1) then
10215         s1=dip(3,jj,i)*dipderg(2,kk,k)
10216       else
10217         s1=dip(2,jj,j)*dipderg(4,kk,l)
10218       endif
10219 #endif
10220       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10221       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10222       if (j.eq.l+1) then
10223         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10224         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10225       else
10226         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10227         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10228       endif
10229       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10230       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10231       vv(1)=pizda(1,1)-pizda(2,2)
10232       vv(2)=pizda(2,1)+pizda(1,2)
10233       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10234       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10235 #ifdef MOMENT
10236         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10237 #else
10238         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10239 #endif
10240       else
10241 #ifdef MOMENT
10242         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10243 #else
10244         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10245 #endif
10246       endif
10247 C Derivatives in gamma(j-1) or gamma(l-1)
10248       if (l.eq.j+1 .and. l.gt.1) then
10249         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10250         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10251         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10252         vv(1)=pizda(1,1)-pizda(2,2)
10253         vv(2)=pizda(2,1)+pizda(1,2)
10254         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10255         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10256       else if (j.gt.1) then
10257         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10258         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10259         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10260         vv(1)=pizda(1,1)-pizda(2,2)
10261         vv(2)=pizda(2,1)+pizda(1,2)
10262         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10263         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10264           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10265         else
10266           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10267         endif
10268       endif
10269 C Cartesian derivatives.
10270       do iii=1,2
10271         do kkk=1,5
10272           do lll=1,3
10273 #ifdef MOMENT
10274             if (iii.eq.1) then
10275               if (imat.eq.1) then
10276                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10277               else
10278                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10279               endif
10280             else
10281               if (imat.eq.1) then
10282                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10283               else
10284                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10285               endif
10286             endif
10287 #endif
10288             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10289      &        auxvec(1))
10290             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10291             if (j.eq.l+1) then
10292               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10293      &          b1(1,j+1),auxvec(1))
10294               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10295             else
10296               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10297      &          b1(1,l+1),auxvec(1))
10298               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10299             endif
10300             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10301      &        pizda(1,1))
10302             vv(1)=pizda(1,1)-pizda(2,2)
10303             vv(2)=pizda(2,1)+pizda(1,2)
10304             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10305             if (swap) then
10306               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10307 #ifdef MOMENT
10308                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10309      &             -(s1+s2+s4)
10310 #else
10311                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10312      &             -(s2+s4)
10313 #endif
10314                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10315               else
10316 #ifdef MOMENT
10317                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10318 #else
10319                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10320 #endif
10321                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10322               endif
10323             else
10324 #ifdef MOMENT
10325               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10326 #else
10327               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10328 #endif
10329               if (l.eq.j+1) then
10330                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10331               else
10332                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10333               endif
10334             endif
10335           enddo
10336         enddo
10337       enddo
10338       return
10339       end
10340 c----------------------------------------------------------------------------
10341       double precision function eello_turn6(i,jj,kk)
10342       implicit real*8 (a-h,o-z)
10343       include 'DIMENSIONS'
10344       include 'COMMON.IOUNITS'
10345       include 'COMMON.CHAIN'
10346       include 'COMMON.DERIV'
10347       include 'COMMON.INTERACT'
10348       include 'COMMON.CONTACTS'
10349       include 'COMMON.TORSION'
10350       include 'COMMON.VAR'
10351       include 'COMMON.GEO'
10352       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10353      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10354      &  ggg1(3),ggg2(3)
10355       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10356      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10357 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10358 C           the respective energy moment and not to the cluster cumulant.
10359       s1=0.0d0
10360       s8=0.0d0
10361       s13=0.0d0
10362 c
10363       eello_turn6=0.0d0
10364       j=i+4
10365       k=i+1
10366       l=i+3
10367       iti=itortyp(itype(i))
10368       itk=itortyp(itype(k))
10369       itk1=itortyp(itype(k+1))
10370       itl=itortyp(itype(l))
10371       itj=itortyp(itype(j))
10372 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10373 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10374 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10375 cd        eello6=0.0d0
10376 cd        return
10377 cd      endif
10378 cd      write (iout,*)
10379 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10380 cd     &   ' and',k,l
10381 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10382       do iii=1,2
10383         do kkk=1,5
10384           do lll=1,3
10385             derx_turn(lll,kkk,iii)=0.0d0
10386           enddo
10387         enddo
10388       enddo
10389 cd      eij=1.0d0
10390 cd      ekl=1.0d0
10391 cd      ekont=1.0d0
10392       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10393 cd      eello6_5=0.0d0
10394 cd      write (2,*) 'eello6_5',eello6_5
10395 #ifdef MOMENT
10396       call transpose2(AEA(1,1,1),auxmat(1,1))
10397       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10398       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10399       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10400 #endif
10401       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10402       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10403       s2 = scalar2(b1(1,k),vtemp1(1))
10404 #ifdef MOMENT
10405       call transpose2(AEA(1,1,2),atemp(1,1))
10406       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10407       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10408       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10409 #endif
10410       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10411       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10412       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10413 #ifdef MOMENT
10414       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10415       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10416       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10417       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10418       ss13 = scalar2(b1(1,k),vtemp4(1))
10419       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10420 #endif
10421 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10422 c      s1=0.0d0
10423 c      s2=0.0d0
10424 c      s8=0.0d0
10425 c      s12=0.0d0
10426 c      s13=0.0d0
10427       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10428 C Derivatives in gamma(i+2)
10429       s1d =0.0d0
10430       s8d =0.0d0
10431 #ifdef MOMENT
10432       call transpose2(AEA(1,1,1),auxmatd(1,1))
10433       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10434       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10435       call transpose2(AEAderg(1,1,2),atempd(1,1))
10436       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10437       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10438 #endif
10439       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10440       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10441       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10442 c      s1d=0.0d0
10443 c      s2d=0.0d0
10444 c      s8d=0.0d0
10445 c      s12d=0.0d0
10446 c      s13d=0.0d0
10447       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10448 C Derivatives in gamma(i+3)
10449 #ifdef MOMENT
10450       call transpose2(AEA(1,1,1),auxmatd(1,1))
10451       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10452       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10453       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10454 #endif
10455       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10456       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10457       s2d = scalar2(b1(1,k),vtemp1d(1))
10458 #ifdef MOMENT
10459       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10460       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10461 #endif
10462       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10463 #ifdef MOMENT
10464       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10465       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10466       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10467 #endif
10468 c      s1d=0.0d0
10469 c      s2d=0.0d0
10470 c      s8d=0.0d0
10471 c      s12d=0.0d0
10472 c      s13d=0.0d0
10473 #ifdef MOMENT
10474       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10475      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10476 #else
10477       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10478      &               -0.5d0*ekont*(s2d+s12d)
10479 #endif
10480 C Derivatives in gamma(i+4)
10481       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10482       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10483       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10484 #ifdef MOMENT
10485       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10486       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10487       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10488 #endif
10489 c      s1d=0.0d0
10490 c      s2d=0.0d0
10491 c      s8d=0.0d0
10492 C      s12d=0.0d0
10493 c      s13d=0.0d0
10494 #ifdef MOMENT
10495       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10496 #else
10497       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10498 #endif
10499 C Derivatives in gamma(i+5)
10500 #ifdef MOMENT
10501       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10502       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10503       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10504 #endif
10505       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10506       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10507       s2d = scalar2(b1(1,k),vtemp1d(1))
10508 #ifdef MOMENT
10509       call transpose2(AEA(1,1,2),atempd(1,1))
10510       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10511       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10512 #endif
10513       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10514       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10515 #ifdef MOMENT
10516       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10517       ss13d = scalar2(b1(1,k),vtemp4d(1))
10518       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10519 #endif
10520 c      s1d=0.0d0
10521 c      s2d=0.0d0
10522 c      s8d=0.0d0
10523 c      s12d=0.0d0
10524 c      s13d=0.0d0
10525 #ifdef MOMENT
10526       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10527      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10528 #else
10529       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10530      &               -0.5d0*ekont*(s2d+s12d)
10531 #endif
10532 C Cartesian derivatives
10533       do iii=1,2
10534         do kkk=1,5
10535           do lll=1,3
10536 #ifdef MOMENT
10537             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10538             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10539             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10540 #endif
10541             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10542             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10543      &          vtemp1d(1))
10544             s2d = scalar2(b1(1,k),vtemp1d(1))
10545 #ifdef MOMENT
10546             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10547             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10548             s8d = -(atempd(1,1)+atempd(2,2))*
10549      &           scalar2(cc(1,1,itl),vtemp2(1))
10550 #endif
10551             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10552      &           auxmatd(1,1))
10553             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10554             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10555 c      s1d=0.0d0
10556 c      s2d=0.0d0
10557 c      s8d=0.0d0
10558 c      s12d=0.0d0
10559 c      s13d=0.0d0
10560 #ifdef MOMENT
10561             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10562      &        - 0.5d0*(s1d+s2d)
10563 #else
10564             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10565      &        - 0.5d0*s2d
10566 #endif
10567 #ifdef MOMENT
10568             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10569      &        - 0.5d0*(s8d+s12d)
10570 #else
10571             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10572      &        - 0.5d0*s12d
10573 #endif
10574           enddo
10575         enddo
10576       enddo
10577 #ifdef MOMENT
10578       do kkk=1,5
10579         do lll=1,3
10580           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10581      &      achuj_tempd(1,1))
10582           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10583           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10584           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10585           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10586           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10587      &      vtemp4d(1))
10588           ss13d = scalar2(b1(1,k),vtemp4d(1))
10589           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10590           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10591         enddo
10592       enddo
10593 #endif
10594 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10595 cd     &  16*eel_turn6_num
10596 cd      goto 1112
10597       if (j.lt.nres-1) then
10598         j1=j+1
10599         j2=j-1
10600       else
10601         j1=j-1
10602         j2=j-2
10603       endif
10604       if (l.lt.nres-1) then
10605         l1=l+1
10606         l2=l-1
10607       else
10608         l1=l-1
10609         l2=l-2
10610       endif
10611       do ll=1,3
10612 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10613 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10614 cgrad        ghalf=0.5d0*ggg1(ll)
10615 cd        ghalf=0.0d0
10616         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10617         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10618         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10619      &    +ekont*derx_turn(ll,2,1)
10620         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10621         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10622      &    +ekont*derx_turn(ll,4,1)
10623         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10624         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10625         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10626 cgrad        ghalf=0.5d0*ggg2(ll)
10627 cd        ghalf=0.0d0
10628         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10629      &    +ekont*derx_turn(ll,2,2)
10630         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10631         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10632      &    +ekont*derx_turn(ll,4,2)
10633         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10634         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10635         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10636       enddo
10637 cd      goto 1112
10638 cgrad      do m=i+1,j-1
10639 cgrad        do ll=1,3
10640 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10641 cgrad        enddo
10642 cgrad      enddo
10643 cgrad      do m=k+1,l-1
10644 cgrad        do ll=1,3
10645 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10646 cgrad        enddo
10647 cgrad      enddo
10648 cgrad1112  continue
10649 cgrad      do m=i+2,j2
10650 cgrad        do ll=1,3
10651 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10652 cgrad        enddo
10653 cgrad      enddo
10654 cgrad      do m=k+2,l2
10655 cgrad        do ll=1,3
10656 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10657 cgrad        enddo
10658 cgrad      enddo
10659 cd      do iii=1,nres-3
10660 cd        write (2,*) iii,g_corr6_loc(iii)
10661 cd      enddo
10662       eello_turn6=ekont*eel_turn6
10663 cd      write (2,*) 'ekont',ekont
10664 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10665       return
10666       end
10667
10668 C-----------------------------------------------------------------------------
10669       double precision function scalar(u,v)
10670 !DIR$ INLINEALWAYS scalar
10671 #ifndef OSF
10672 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10673 #endif
10674       implicit none
10675       double precision u(3),v(3)
10676 cd      double precision sc
10677 cd      integer i
10678 cd      sc=0.0d0
10679 cd      do i=1,3
10680 cd        sc=sc+u(i)*v(i)
10681 cd      enddo
10682 cd      scalar=sc
10683
10684       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10685       return
10686       end
10687 crc-------------------------------------------------
10688       SUBROUTINE MATVEC2(A1,V1,V2)
10689 !DIR$ INLINEALWAYS MATVEC2
10690 #ifndef OSF
10691 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10692 #endif
10693       implicit real*8 (a-h,o-z)
10694       include 'DIMENSIONS'
10695       DIMENSION A1(2,2),V1(2),V2(2)
10696 c      DO 1 I=1,2
10697 c        VI=0.0
10698 c        DO 3 K=1,2
10699 c    3     VI=VI+A1(I,K)*V1(K)
10700 c        Vaux(I)=VI
10701 c    1 CONTINUE
10702
10703       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10704       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10705
10706       v2(1)=vaux1
10707       v2(2)=vaux2
10708       END
10709 C---------------------------------------
10710       SUBROUTINE MATMAT2(A1,A2,A3)
10711 #ifndef OSF
10712 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10713 #endif
10714       implicit real*8 (a-h,o-z)
10715       include 'DIMENSIONS'
10716       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10717 c      DIMENSION AI3(2,2)
10718 c        DO  J=1,2
10719 c          A3IJ=0.0
10720 c          DO K=1,2
10721 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10722 c          enddo
10723 c          A3(I,J)=A3IJ
10724 c       enddo
10725 c      enddo
10726
10727       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10728       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10729       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10730       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10731
10732       A3(1,1)=AI3_11
10733       A3(2,1)=AI3_21
10734       A3(1,2)=AI3_12
10735       A3(2,2)=AI3_22
10736       END
10737
10738 c-------------------------------------------------------------------------
10739       double precision function scalar2(u,v)
10740 !DIR$ INLINEALWAYS scalar2
10741       implicit none
10742       double precision u(2),v(2)
10743       double precision sc
10744       integer i
10745       scalar2=u(1)*v(1)+u(2)*v(2)
10746       return
10747       end
10748
10749 C-----------------------------------------------------------------------------
10750
10751       subroutine transpose2(a,at)
10752 !DIR$ INLINEALWAYS transpose2
10753 #ifndef OSF
10754 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10755 #endif
10756       implicit none
10757       double precision a(2,2),at(2,2)
10758       at(1,1)=a(1,1)
10759       at(1,2)=a(2,1)
10760       at(2,1)=a(1,2)
10761       at(2,2)=a(2,2)
10762       return
10763       end
10764 c--------------------------------------------------------------------------
10765       subroutine transpose(n,a,at)
10766       implicit none
10767       integer n,i,j
10768       double precision a(n,n),at(n,n)
10769       do i=1,n
10770         do j=1,n
10771           at(j,i)=a(i,j)
10772         enddo
10773       enddo
10774       return
10775       end
10776 C---------------------------------------------------------------------------
10777       subroutine prodmat3(a1,a2,kk,transp,prod)
10778 !DIR$ INLINEALWAYS prodmat3
10779 #ifndef OSF
10780 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10781 #endif
10782       implicit none
10783       integer i,j
10784       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10785       logical transp
10786 crc      double precision auxmat(2,2),prod_(2,2)
10787
10788       if (transp) then
10789 crc        call transpose2(kk(1,1),auxmat(1,1))
10790 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10791 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10792
10793            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10794      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10795            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10796      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10797            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10798      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10799            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10800      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10801
10802       else
10803 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10804 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10805
10806            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10807      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10808            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10809      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10810            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10811      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10812            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10813      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10814
10815       endif
10816 c      call transpose2(a2(1,1),a2t(1,1))
10817
10818 crc      print *,transp
10819 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10820 crc      print *,((prod(i,j),i=1,2),j=1,2)
10821
10822       return
10823       end
10824 CCC----------------------------------------------
10825       subroutine Eliptransfer(eliptran)
10826       implicit real*8 (a-h,o-z)
10827       include 'DIMENSIONS'
10828       include 'COMMON.GEO'
10829       include 'COMMON.VAR'
10830       include 'COMMON.LOCAL'
10831       include 'COMMON.CHAIN'
10832       include 'COMMON.DERIV'
10833       include 'COMMON.NAMES'
10834       include 'COMMON.INTERACT'
10835       include 'COMMON.IOUNITS'
10836       include 'COMMON.CALC'
10837       include 'COMMON.CONTROL'
10838       include 'COMMON.SPLITELE'
10839       include 'COMMON.SBRIDGE'
10840 C this is done by Adasko
10841 C      print *,"wchodze"
10842 C structure of box:
10843 C      water
10844 C--bordliptop-- buffore starts
10845 C--bufliptop--- here true lipid starts
10846 C      lipid
10847 C--buflipbot--- lipid ends buffore starts
10848 C--bordlipbot--buffore ends
10849       eliptran=0.0
10850       do i=ilip_start,ilip_end
10851 C       do i=1,1
10852         if (itype(i).eq.ntyp1) cycle
10853
10854         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10855         if (positi.le.0) positi=positi+boxzsize
10856 C        print *,i
10857 C first for peptide groups
10858 c for each residue check if it is in lipid or lipid water border area
10859        if ((positi.gt.bordlipbot)
10860      &.and.(positi.lt.bordliptop)) then
10861 C the energy transfer exist
10862         if (positi.lt.buflipbot) then
10863 C what fraction I am in
10864          fracinbuf=1.0d0-
10865      &        ((positi-bordlipbot)/lipbufthick)
10866 C lipbufthick is thickenes of lipid buffore
10867          sslip=sscalelip(fracinbuf)
10868          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10869          eliptran=eliptran+sslip*pepliptran
10870          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10871          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10872 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10873
10874 C        print *,"doing sccale for lower part"
10875 C         print *,i,sslip,fracinbuf,ssgradlip
10876         elseif (positi.gt.bufliptop) then
10877          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10878          sslip=sscalelip(fracinbuf)
10879          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10880          eliptran=eliptran+sslip*pepliptran
10881          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10882          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10883 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10884 C          print *, "doing sscalefor top part"
10885 C         print *,i,sslip,fracinbuf,ssgradlip
10886         else
10887          eliptran=eliptran+pepliptran
10888 C         print *,"I am in true lipid"
10889         endif
10890 C       else
10891 C       eliptran=elpitran+0.0 ! I am in water
10892        endif
10893        enddo
10894 C       print *, "nic nie bylo w lipidzie?"
10895 C now multiply all by the peptide group transfer factor
10896 C       eliptran=eliptran*pepliptran
10897 C now the same for side chains
10898 CV       do i=1,1
10899        do i=ilip_start,ilip_end
10900         if (itype(i).eq.ntyp1) cycle
10901         positi=(mod(c(3,i+nres),boxzsize))
10902         if (positi.le.0) positi=positi+boxzsize
10903 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10904 c for each residue check if it is in lipid or lipid water border area
10905 C       respos=mod(c(3,i+nres),boxzsize)
10906 C       print *,positi,bordlipbot,buflipbot
10907        if ((positi.gt.bordlipbot)
10908      & .and.(positi.lt.bordliptop)) then
10909 C the energy transfer exist
10910         if (positi.lt.buflipbot) then
10911          fracinbuf=1.0d0-
10912      &     ((positi-bordlipbot)/lipbufthick)
10913 C lipbufthick is thickenes of lipid buffore
10914          sslip=sscalelip(fracinbuf)
10915          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10916          eliptran=eliptran+sslip*liptranene(itype(i))
10917          gliptranx(3,i)=gliptranx(3,i)
10918      &+ssgradlip*liptranene(itype(i))
10919          gliptranc(3,i-1)= gliptranc(3,i-1)
10920      &+ssgradlip*liptranene(itype(i))
10921 C         print *,"doing sccale for lower part"
10922         elseif (positi.gt.bufliptop) then
10923          fracinbuf=1.0d0-
10924      &((bordliptop-positi)/lipbufthick)
10925          sslip=sscalelip(fracinbuf)
10926          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10927          eliptran=eliptran+sslip*liptranene(itype(i))
10928          gliptranx(3,i)=gliptranx(3,i)
10929      &+ssgradlip*liptranene(itype(i))
10930          gliptranc(3,i-1)= gliptranc(3,i-1)
10931      &+ssgradlip*liptranene(itype(i))
10932 C          print *, "doing sscalefor top part",sslip,fracinbuf
10933         else
10934          eliptran=eliptran+liptranene(itype(i))
10935 C         print *,"I am in true lipid"
10936         endif
10937         endif ! if in lipid or buffor
10938 C       else
10939 C       eliptran=elpitran+0.0 ! I am in water
10940        enddo
10941        return
10942        end
10943 C---------------------------------------------------------
10944 C AFM soubroutine for constant force
10945        subroutine AFMforce(Eafmforce)
10946        implicit real*8 (a-h,o-z)
10947       include 'DIMENSIONS'
10948       include 'COMMON.GEO'
10949       include 'COMMON.VAR'
10950       include 'COMMON.LOCAL'
10951       include 'COMMON.CHAIN'
10952       include 'COMMON.DERIV'
10953       include 'COMMON.NAMES'
10954       include 'COMMON.INTERACT'
10955       include 'COMMON.IOUNITS'
10956       include 'COMMON.CALC'
10957       include 'COMMON.CONTROL'
10958       include 'COMMON.SPLITELE'
10959       include 'COMMON.SBRIDGE'
10960       real*8 diffafm(3)
10961       dist=0.0d0
10962       Eafmforce=0.0d0
10963       do i=1,3
10964       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10965       dist=dist+diffafm(i)**2
10966       enddo
10967       dist=dsqrt(dist)
10968       Eafmforce=-forceAFMconst*(dist-distafminit)
10969       do i=1,3
10970       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10971       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10972       enddo
10973 C      print *,'AFM',Eafmforce
10974       return
10975       end
10976 C---------------------------------------------------------
10977 C AFM subroutine with pseudoconstant velocity
10978        subroutine AFMvel(Eafmforce)
10979        implicit real*8 (a-h,o-z)
10980       include 'DIMENSIONS'
10981       include 'COMMON.GEO'
10982       include 'COMMON.VAR'
10983       include 'COMMON.LOCAL'
10984       include 'COMMON.CHAIN'
10985       include 'COMMON.DERIV'
10986       include 'COMMON.NAMES'
10987       include 'COMMON.INTERACT'
10988       include 'COMMON.IOUNITS'
10989       include 'COMMON.CALC'
10990       include 'COMMON.CONTROL'
10991       include 'COMMON.SPLITELE'
10992       include 'COMMON.SBRIDGE'
10993       real*8 diffafm(3)
10994 C Only for check grad COMMENT if not used for checkgrad
10995 C      totT=3.0d0
10996 C--------------------------------------------------------
10997 C      print *,"wchodze"
10998       dist=0.0d0
10999       Eafmforce=0.0d0
11000       do i=1,3
11001       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11002       dist=dist+diffafm(i)**2
11003       enddo
11004       dist=dsqrt(dist)
11005       Eafmforce=0.5d0*forceAFMconst
11006      & *(distafminit+totTafm*velAFMconst-dist)**2
11007 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11008       do i=1,3
11009       gradafm(i,afmend-1)=-forceAFMconst*
11010      &(distafminit+totTafm*velAFMconst-dist)
11011      &*diffafm(i)/dist
11012       gradafm(i,afmbeg-1)=forceAFMconst*
11013      &(distafminit+totTafm*velAFMconst-dist)
11014      &*diffafm(i)/dist
11015       enddo
11016 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11017       return
11018       end
11019