source/unres/src_MD-M/initialize_p.F

   1       block data
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'COMMON.MCM'
   5       include 'COMMON.MD'
   6       data MovTypID
   7      &  /'pool','chain regrow','multi-bond','phi','theta','side chain',
   8      &   'total'/
   9 c Conversion from poises to molecular unit and the gas constant
  10       data cPoise /2.9361d0/, Rb /0.001986d0/
  11       end
  12 c--------------------------------------------------------------------------
  13       subroutine initialize
  14 C
  15 C Define constants and zero out tables.
  16 C
  17       implicit real*8 (a-h,o-z)
  18       include 'DIMENSIONS'
  19 #ifdef MPI
  20       include 'mpif.h'
  21 #endif
  22 #ifndef ISNAN
  23       external proc_proc
  24 #ifdef WINPGI
  25 cMS$ATTRIBUTES C ::  proc_proc
  26 #endif
  27 #endif
  28       include 'COMMON.IOUNITS'
  29       include 'COMMON.CHAIN'
  30       include 'COMMON.INTERACT'
  31       include 'COMMON.GEO'
  32       include 'COMMON.LOCAL'
  33       include 'COMMON.TORSION'
  34       include 'COMMON.FFIELD'
  35       include 'COMMON.SBRIDGE'
  36       include 'COMMON.MCM'
  37       include 'COMMON.MINIM'
  38       include 'COMMON.DERIV'
  39       include 'COMMON.SPLITELE'
  40 c Common blocks from the diagonalization routines
  41       COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
  42       COMMON /MACHSW/ KDIAG,ICORFL,IXDR
  43       logical mask_r
  44 c      real*8 text1 /'initial_i'/
  45
  46       mask_r=.false.
  47 #ifndef ISNAN
  48 c NaNQ initialization
  49       i=-1
  50       rr=dacos(100.0d0)
  51 #ifdef WINPGI
  52       idumm=proc_proc(rr,i)
  53 #else
  54       call proc_proc(rr,i)
  55 #endif
  56 #endif
  57
  58       kdiag=0
  59       icorfl=0
  60       iw=2
  61 C
  62 C The following is just to define auxiliary variables used in angle conversion
  63 C
  64       pi=4.0D0*datan(1.0D0)
  65       dwapi=2.0D0*pi
  66       dwapi3=dwapi/3.0D0
  67       pipol=0.5D0*pi
  68       deg2rad=pi/180.0D0
  69       rad2deg=1.0D0/deg2rad
  70       angmin=10.0D0*deg2rad
  71 C
  72 C Define I/O units.
  73 C
  74       inp=    1
  75       iout=   2
  76       ipdbin= 3
  77       ipdb=   7
  78       icart = 30
  79       imol2=  4
  80       igeom=  8
  81       intin=  9
  82       ithep= 11
  83       ithep_pdb=51
  84       irotam=12
  85       irotam_pdb=52
  86       itorp= 13
  87       itordp= 23
  88       ielep= 14
  89       isidep=15
  90       iscpp=25
  91       icbase=16
  92       ifourier=20
  93       istat= 17
  94       irest1=55
  95       irest2=56
  96       iifrag=57
  97       ientin=18
  98       ientout=19
  99       ibond = 28
 100       isccor = 29
 101 crc for write_rmsbank1
 102       izs1=21
 103 cdr  include secondary structure prediction bias
 104       isecpred=27
 105 C
 106 C CSA I/O units (separated from others especially for Jooyoung)
 107 C
 108       icsa_rbank=30
 109       icsa_seed=31
 110       icsa_history=32
 111       icsa_bank=33
 112       icsa_bank1=34
 113       icsa_alpha=35
 114       icsa_alpha1=36
 115       icsa_bankt=37
 116       icsa_int=39
 117       icsa_bank_reminimized=38
 118       icsa_native_int=41
 119       icsa_in=40
 120 crc for ifc error 118
 121       icsa_pdb=42
 122 C
 123 C Set default weights of the energy terms.
 124 C
 125       wlong=1.0D0
 126       welec=1.0D0
 127       wtor =1.0D0
 128       wang =1.0D0
 129       wscloc=1.0D0
 130       wstrain=1.0D0
 131 C
 132 C Zero out tables.
 133 C
 134 c      print '(a,$)','Inside initialize'
 135 c      call memmon_print_usage()
 136       do i=1,maxres2
 137         do j=1,3
 138           c(j,i)=0.0D0
 139           dc(j,i)=0.0D0
 140         enddo
 141       enddo
 142       do i=1,maxres
 143         do j=1,3
 144           xloc(j,i)=0.0D0
 145         enddo
 146       enddo
 147       do i=1,ntyp
 148         do j=1,ntyp
 149           aa(i,j)=0.0D0
 150           bb(i,j)=0.0D0
 151           augm(i,j)=0.0D0
 152           sigma(i,j)=0.0D0
 153           r0(i,j)=0.0D0
 154           chi(i,j)=0.0D0
 155         enddo
 156         do j=1,2
 157           bad(i,j)=0.0D0
 158         enddo
 159         chip(i)=0.0D0
 160         alp(i)=0.0D0
 161         sigma0(i)=0.0D0
 162         sigii(i)=0.0D0
 163         rr0(i)=0.0D0
 164         a0thet(i)=0.0D0
 165         do j=1,2
 166          do ichir1=-1,1
 167           do ichir2=-1,1
 168           athet(j,i,ichir1,ichir2)=0.0D0
 169           bthet(j,i,ichir1,ichir2)=0.0D0
 170           enddo
 171          enddo
 172         enddo
 173         do j=0,3
 174           polthet(j,i)=0.0D0
 175         enddo
 176         do j=1,3
 177           gthet(j,i)=0.0D0
 178         enddo
 179         theta0(i)=0.0D0
 180         sig0(i)=0.0D0
 181         sigc0(i)=0.0D0
 182         do j=1,maxlob
 183           bsc(j,i)=0.0D0
 184           do k=1,3
 185             censc(k,j,i)=0.0D0
 186           enddo
 187           do k=1,3
 188             do l=1,3
 189               gaussc(l,k,j,i)=0.0D0
 190             enddo
 191           enddo
 192           nlob(i)=0
 193         enddo
 194       enddo
 195       nlob(ntyp1)=0
 196       dsc(ntyp1)=0.0D0
 197       do i=-maxtor,maxtor
 198         itortyp(i)=0
 199 cc      write (iout,*) "TU DOCHODZE",i,itortyp(i)
 200        do iblock=1,2
 201         do j=-maxtor,maxtor
 202           do k=1,maxterm
 203             v1(k,j,i,iblock)=0.0D0
 204             v2(k,j,i,iblock)=0.0D0
 205           enddo
 206         enddo
 207         enddo
 208       enddo
 209       do iblock=1,2
 210        do i=-maxtor,maxtor
 211         do j=-maxtor,maxtor
 212          do k=-maxtor,maxtor
 213           do l=1,maxtermd_1
 214             v1c(1,l,i,j,k,iblock)=0.0D0
 215             v1s(1,l,i,j,k,iblock)=0.0D0
 216             v1c(2,l,i,j,k,iblock)=0.0D0
 217             v1s(2,l,i,j,k,iblock)=0.0D0
 218           enddo !l
 219           do l=1,maxtermd_2
 220            do m=1,maxtermd_2
 221             v2c(m,l,i,j,k,iblock)=0.0D0
 222             v2s(m,l,i,j,k,iblock)=0.0D0
 223            enddo !m
 224           enddo !l
 225         enddo !k
 226        enddo !j
 227       enddo !i
 228       enddo !iblock
 229
 230       do i=1,maxres
 231         itype(i)=0
 232         itel(i)=0
 233       enddo
 234 C Initialize the bridge arrays
 235       ns=0
 236       nss=0
 237       nhpb=0
 238       do i=1,maxss
 239         iss(i)=0
 240       enddo
 241       do i=1,maxdim
 242         dhpb(i)=0.0D0
 243       enddo
 244       do i=1,maxres
 245         ihpb(i)=0
 246         jhpb(i)=0
 247       enddo
 248 C
 249 C Initialize timing.
 250 C
 251       call set_timers
 252 C
 253 C Initialize variables used in minimization.
 254 C
 255 c     maxfun=5000
 256 c     maxit=2000
 257       maxfun=500
 258       maxit=200
 259       tolf=1.0D-2
 260       rtolf=5.0D-4
 261 C
 262 C Initialize the variables responsible for the mode of gradient storage.
 263 C
 264       nfl=0
 265       icg=1
 266 C
 267 C Initialize constants used to split the energy into long- and short-range
 268 C components
 269 C
 270       r_cut=2.0d0
 271       rlamb=0.3d0
 272 #ifndef SPLITELE
 273       nprint_ene=nprint_ene-1
 274 #endif
 275       return
 276       end
 277 c-------------------------------------------------------------------------
 278       block data nazwy
 279       implicit real*8 (a-h,o-z)
 280       include 'DIMENSIONS'
 281       include 'COMMON.NAMES'
 282       include 'COMMON.FFIELD'
 283       data restyp /
 284      &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL',
 285      & 'DSG','DGN','DSN','DTH',
 286      &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',
 287      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 288      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ',
 289      &'AIB','ABU','D'/
 290       data onelet /
 291      &'z','z','z','z','z','p','k','r','h','d','e','n','q','s','t','g',
 292      &'a','y','w','v','l','i','f','m','c','x',
 293      &'C','M','F','I','L','V','W','Y','A','G','T',
 294      &'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/
 295       data potname /'LJ','LJK','BP','GB','GBV'/
 296       data ename /
 297      &   "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
 298      &   "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
 299      &   "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
 300      &   "ESTR ","EVDW2_14 ","UCONST ", "      ","ESCCOR"/
 301       data wname /
 302      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 303      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 304      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR"/
 305       data nprint_ene /20/
 306       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 307      & 21,0/
 308       end
 309 c---------------------------------------------------------------------------
 310       subroutine init_int_table
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifdef MPI
 314       include 'mpif.h'
 315       integer blocklengths(15),displs(15)
 316 #endif
 317       include 'COMMON.CONTROL'
 318       include 'COMMON.SETUP'
 319       include 'COMMON.CHAIN'
 320       include 'COMMON.INTERACT'
 321       include 'COMMON.LOCAL'
 322       include 'COMMON.SBRIDGE'
 323       include 'COMMON.TORCNSTR'
 324       include 'COMMON.IOUNITS'
 325       include 'COMMON.DERIV'
 326       include 'COMMON.CONTACTS'
 327       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
 328      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
 329      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
 330      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
 331      & ielend_all(maxres,0:max_fg_procs-1),
 332      & ntask_cont_from_all(0:max_fg_procs-1),
 333      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 334      & ntask_cont_to_all(0:max_fg_procs-1),
 335      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 336       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 337       logical scheck,lprint,flag
 338 #ifdef MPI
 339       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 340      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 341 C... Determine the numbers of start and end SC-SC interaction
 342 C... to deal with by current processor.
 343       do i=0,nfgtasks-1
 344         itask_cont_from(i)=fg_rank
 345         itask_cont_to(i)=fg_rank
 346       enddo
 347       lprint=energy_dec
 348       if (lprint)
 349      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 350       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 351       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 352       if (lprint)
 353      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 354      &  ' absolute rank',MyRank,
 355      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 356      &  ' my_sc_inde',my_sc_inde
 357       ind_sctint=0
 358       iatsc_s=0
 359       iatsc_e=0
 360 #endif
 361 c      lprint=.false.
 362       do i=1,maxres
 363         nint_gr(i)=0
 364         nscp_gr(i)=0
 365         do j=1,maxint_gr
 366           istart(i,1)=0
 367           iend(i,1)=0
 368           ielstart(i)=0
 369           ielend(i)=0
 370           iscpstart(i,1)=0
 371           iscpend(i,1)=0
 372         enddo
 373       enddo
 374       ind_scint=0
 375       ind_scint_old=0
 376 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 377 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 378       do i=nnt,nct-1
 379         scheck=.false.
 380         if (dyn_ss) goto 10
 381         do ii=1,nss
 382           if (ihpb(ii).eq.i+nres) then
 383             scheck=.true.
 384             jj=jhpb(ii)-nres
 385             goto 10
 386           endif
 387         enddo
 388    10   continue
 389 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 390         if (scheck) then
 391           if (jj.eq.i+1) then
 392 #ifdef MPI
 393 c            write (iout,*) 'jj=i+1'
 394             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 395      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 396 #else
 397             nint_gr(i)=1
 398             istart(i,1)=i+2
 399             iend(i,1)=nct
 400 #endif
 401           else if (jj.eq.nct) then
 402 #ifdef MPI
 403 c            write (iout,*) 'jj=nct'
 404             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 405      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 406 #else
 407             nint_gr(i)=1
 408             istart(i,1)=i+1
 409             iend(i,1)=nct-1
 410 #endif
 411           else
 412 #ifdef MPI
 413             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 414      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 415             ii=nint_gr(i)+1
 416             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 417      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 418 #else
 419             nint_gr(i)=2
 420             istart(i,1)=i+1
 421             iend(i,1)=jj-1
 422             istart(i,2)=jj+1
 423             iend(i,2)=nct
 424 #endif
 425           endif
 426         else
 427 #ifdef MPI
 428           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 429      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 430 #else
 431           nint_gr(i)=1
 432           istart(i,1)=i+1
 433           iend(i,1)=nct
 434           ind_scint=ind_scint+nct-i
 435 #endif
 436         endif
 437 #ifdef MPI
 438         ind_scint_old=ind_scint
 439 #endif
 440       enddo
 441    12 continue
 442 #ifndef MPI
 443       iatsc_s=nnt
 444       iatsc_e=nct-1
 445 #endif
 446       if (iatsc_s.eq.0) iatsc_s=1
 447 #ifdef MPI
 448       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 449      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 450 #endif
 451       if (lprint) then
 452       write (iout,'(a)') 'Interaction array:'
 453       do i=iatsc_s,iatsc_e
 454         write (iout,'(i3,2(2x,2i3))')
 455      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 456       enddo
 457       endif
 458       ispp=4
 459 #ifdef MPI
 460 C Now partition the electrostatic-interaction array
 461       npept=nct-nnt
 462       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 463       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 464       if (lprint)
 465      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 466      &  ' absolute rank',MyRank,
 467      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 468      &               ' my_ele_inde',my_ele_inde
 469       iatel_s=0
 470       iatel_e=0
 471       ind_eleint=0
 472       ind_eleint_old=0
 473       do i=nnt,nct-3
 474         ijunk=0
 475         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 476      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 477       enddo ! i
 478    13 continue
 479       if (iatel_s.eq.0) iatel_s=1
 480       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 481 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 482       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 483 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 484 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 485       ind_eleint_vdw=0
 486       ind_eleint_vdw_old=0
 487       iatel_s_vdw=0
 488       iatel_e_vdw=0
 489       do i=nnt,nct-3
 490         ijunk=0
 491         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 492      &    my_ele_inde_vdw,i,
 493      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 494      &    ielend_vdw(i),*15)
 495 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 496 c     &   " ielend_vdw",ielend_vdw(i)
 497       enddo ! i
 498       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 499    15 continue
 500 #else
 501       iatel_s=nnt
 502       iatel_e=nct-5
 503       do i=iatel_s,iatel_e
 504         ielstart(i)=i+4
 505         ielend(i)=nct-1
 506       enddo
 507       iatel_s_vdw=nnt
 508       iatel_e_vdw=nct-3
 509       do i=iatel_s_vdw,iatel_e_vdw
 510         ielstart_vdw(i)=i+2
 511         ielend_vdw(i)=nct-1
 512       enddo
 513 #endif
 514       if (lprint) then
 515         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 516      &  ' absolute rank',MyRank
 517         write (iout,*) 'Electrostatic interaction array:'
 518         do i=iatel_s,iatel_e
 519           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 520         enddo
 521       endif ! lprint
 522 c     iscp=3
 523       iscp=2
 524 C Partition the SC-p interaction array
 525 #ifdef MPI
 526       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 527       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 528       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 529      &  ' absolute rank',myrank,
 530      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 531      &               ' my_scp_inde',my_scp_inde
 532       iatscp_s=0
 533       iatscp_e=0
 534       ind_scpint=0
 535       ind_scpint_old=0
 536       do i=nnt,nct-1
 537         if (i.lt.nnt+iscp) then
 538 cd        write (iout,*) 'i.le.nnt+iscp'
 539           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 540      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 541      &      iscpend(i,1),*14)
 542         else if (i.gt.nct-iscp) then
 543 cd        write (iout,*) 'i.gt.nct-iscp'
 544           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 545      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 546      &      iscpend(i,1),*14)
 547         else
 548           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 549      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 550      &      iscpend(i,1),*14)
 551           ii=nscp_gr(i)+1
 552           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 553      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 554      &      iscpend(i,ii),*14)
 555         endif
 556       enddo ! i
 557    14 continue
 558 #else
 559       iatscp_s=nnt
 560       iatscp_e=nct-1
 561       do i=nnt,nct-1
 562         if (i.lt.nnt+iscp) then
 563           nscp_gr(i)=1
 564           iscpstart(i,1)=i+iscp
 565           iscpend(i,1)=nct
 566         elseif (i.gt.nct-iscp) then
 567           nscp_gr(i)=1
 568           iscpstart(i,1)=nnt
 569           iscpend(i,1)=i-iscp
 570         else
 571           nscp_gr(i)=2
 572           iscpstart(i,1)=nnt
 573           iscpend(i,1)=i-iscp
 574           iscpstart(i,2)=i+iscp
 575           iscpend(i,2)=nct
 576         endif
 577       enddo ! i
 578 #endif
 579       if (iatscp_s.eq.0) iatscp_s=1
 580       if (lprint) then
 581         write (iout,'(a)') 'SC-p interaction array:'
 582         do i=iatscp_s,iatscp_e
 583           write (iout,'(i3,2(2x,2i3))')
 584      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 585         enddo
 586       endif ! lprint
 587 C Partition local interactions
 588 #ifdef MPI
 589       call int_bounds(nres-2,loc_start,loc_end)
 590       loc_start=loc_start+1
 591       loc_end=loc_end+1
 592       call int_bounds(nres-2,ithet_start,ithet_end)
 593       ithet_start=ithet_start+2
 594       ithet_end=ithet_end+2
 595       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 596       iturn3_start=iturn3_start+nnt
 597       iphi_start=iturn3_start+2
 598       iturn3_end=iturn3_end+nnt
 599       iphi_end=iturn3_end+2
 600       iturn3_start=iturn3_start-1
 601       iturn3_end=iturn3_end-1
 602       call int_bounds(nres-3,itau_start,itau_end)
 603       itau_start=itau_start+3
 604       itau_end=itau_end+3
 605       call int_bounds(nres-3,iphi1_start,iphi1_end)
 606       iphi1_start=iphi1_start+3
 607       iphi1_end=iphi1_end+3
 608       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 609       iturn4_start=iturn4_start+nnt
 610       iphid_start=iturn4_start+2
 611       iturn4_end=iturn4_end+nnt
 612       iphid_end=iturn4_end+2
 613       iturn4_start=iturn4_start-1
 614       iturn4_end=iturn4_end-1
 615       call int_bounds(nres-2,ibond_start,ibond_end)
 616       ibond_start=ibond_start+1
 617       ibond_end=ibond_end+1
 618       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 619       ibondp_start=ibondp_start+nnt
 620       ibondp_end=ibondp_end+nnt
 621       call int_bounds1(nres-1,ivec_start,ivec_end)
 622 c      print *,"Processor",myrank,fg_rank,fg_rank1,
 623 c     &  " ivec_start",ivec_start," ivec_end",ivec_end
 624       iset_start=loc_start+2
 625       iset_end=loc_end+2
 626       if (ndih_constr.eq.0) then
 627         idihconstr_start=1
 628         idihconstr_end=0
 629       else
 630         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 631       endif
 632 c      nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 633 c      nlen=nres-nnt+1
 634       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 635       nlen=nres-nnt+1
 636       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 637       igrad_start=((2*nlen+1)
 638      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 639       jgrad_start(igrad_start)=
 640      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 641      &    +igrad_start
 642       jgrad_end(igrad_start)=nres
 643       igrad_end=((2*nlen+1)
 644      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 645       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 646       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 647      &    +igrad_end
 648       do i=igrad_start+1,igrad_end-1
 649         jgrad_start(i)=i+1
 650         jgrad_end(i)=nres
 651       enddo
 652       if (lprint) then
 653         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 654      & ' absolute rank',myrank,
 655      & ' loc_start',loc_start,' loc_end',loc_end,
 656      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 657      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 658      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 659      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 660      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 661      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 662      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 663      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 664      & ' iset_start',iset_start,' iset_end',iset_end,
 665      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 666      &   idihconstr_end
 667        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 668      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 669      &   ' ngrad_end',ngrad_end
 670        do i=igrad_start,igrad_end
 671          write(*,*) 'Processor:',fg_rank,myrank,i,
 672      &    jgrad_start(i),jgrad_end(i)
 673        enddo
 674       endif
 675       if (nfgtasks.gt.1) then
 676         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 677      &    MPI_INTEGER,FG_COMM1,IERROR)
 678         iaux=ivec_end-ivec_start+1
 679         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 680      &    MPI_INTEGER,FG_COMM1,IERROR)
 681         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 682      &    MPI_INTEGER,FG_COMM,IERROR)
 683         iaux=iset_end-iset_start+1
 684         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 685      &    MPI_INTEGER,FG_COMM,IERROR)
 686         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 687      &    MPI_INTEGER,FG_COMM,IERROR)
 688         iaux=ibond_end-ibond_start+1
 689         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 690      &    MPI_INTEGER,FG_COMM,IERROR)
 691         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 692      &    MPI_INTEGER,FG_COMM,IERROR)
 693         iaux=ithet_end-ithet_start+1
 694         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 695      &    MPI_INTEGER,FG_COMM,IERROR)
 696         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 697      &    MPI_INTEGER,FG_COMM,IERROR)
 698         iaux=iphi_end-iphi_start+1
 699         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 700      &    MPI_INTEGER,FG_COMM,IERROR)
 701         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 702      &    MPI_INTEGER,FG_COMM,IERROR)
 703         iaux=iphi1_end-iphi1_start+1
 704         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 705      &    MPI_INTEGER,FG_COMM,IERROR)
 706         do i=0,maxprocs-1
 707           do j=1,maxres
 708             ielstart_all(j,i)=0
 709             ielend_all(j,i)=0
 710           enddo
 711         enddo
 712         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 713      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 714         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 715      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 716         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 717      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 718         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 719      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 720         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 721      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 722         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 723      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 724         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 725      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 726         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 727      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 728         if (lprint) then
 729         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 730         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 731         write (iout,*) "iturn3_start_all",
 732      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 733         write (iout,*) "iturn3_end_all",
 734      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 735         write (iout,*) "iturn4_start_all",
 736      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 737         write (iout,*) "iturn4_end_all",
 738      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 739         write (iout,*) "The ielstart_all array"
 740         do i=nnt,nct
 741           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 742         enddo
 743         write (iout,*) "The ielend_all array"
 744         do i=nnt,nct
 745           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 746         enddo
 747         call flush(iout)
 748         endif
 749         ntask_cont_from=0
 750         ntask_cont_to=0
 751         itask_cont_from(0)=fg_rank
 752         itask_cont_to(0)=fg_rank
 753         flag=.false.
 754         do ii=iturn3_start,iturn3_end
 755           call add_int(ii,ii+2,iturn3_sent(1,ii),
 756      &                 ntask_cont_to,itask_cont_to,flag)
 757         enddo
 758         do ii=iturn4_start,iturn4_end
 759           call add_int(ii,ii+3,iturn4_sent(1,ii),
 760      &                 ntask_cont_to,itask_cont_to,flag)
 761         enddo
 762         do ii=iturn3_start,iturn3_end
 763           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 764         enddo
 765         do ii=iturn4_start,iturn4_end
 766           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 767         enddo
 768         if (lprint) then
 769         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 770      &   " ntask_cont_to",ntask_cont_to
 771         write (iout,*) "itask_cont_from",
 772      &    (itask_cont_from(i),i=1,ntask_cont_from)
 773         write (iout,*) "itask_cont_to",
 774      &    (itask_cont_to(i),i=1,ntask_cont_to)
 775         call flush(iout)
 776         endif
 777 c        write (iout,*) "Loop forward"
 778 c        call flush(iout)
 779         do i=iatel_s,iatel_e
 780 c          write (iout,*) "from loop i=",i
 781 c          call flush(iout)
 782           do j=ielstart(i),ielend(i)
 783             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 784           enddo
 785         enddo
 786 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 787 c     &     " iatel_e",iatel_e
 788 c        call flush(iout)
 789         nat_sent=0
 790         do i=iatel_s,iatel_e
 791 c          write (iout,*) "i",i," ielstart",ielstart(i),
 792 c     &      " ielend",ielend(i)
 793 c          call flush(iout)
 794           flag=.false.
 795           do j=ielstart(i),ielend(i)
 796             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 797      &                   itask_cont_to,flag)
 798           enddo
 799           if (flag) then
 800             nat_sent=nat_sent+1
 801             iat_sent(nat_sent)=i
 802           endif
 803         enddo
 804         if (lprint) then
 805         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 806      &   " ntask_cont_to",ntask_cont_to
 807         write (iout,*) "itask_cont_from",
 808      &    (itask_cont_from(i),i=1,ntask_cont_from)
 809         write (iout,*) "itask_cont_to",
 810      &    (itask_cont_to(i),i=1,ntask_cont_to)
 811         call flush(iout)
 812         write (iout,*) "iint_sent"
 813         do i=1,nat_sent
 814           ii=iat_sent(i)
 815           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 816      &      j=ielstart(ii),ielend(ii))
 817         enddo
 818         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 819      &    " iturn3_end",iturn3_end
 820         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 821      &      i=iturn3_start,iturn3_end)
 822         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 823      &    " iturn4_end",iturn4_end
 824         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 825      &      i=iturn4_start,iturn4_end)
 826         call flush(iout)
 827         endif
 828         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 829      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 830 c        write (iout,*) "Gather ntask_cont_from ended"
 831 c        call flush(iout)
 832         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 833      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 834      &   FG_COMM,IERR)
 835 c        write (iout,*) "Gather itask_cont_from ended"
 836 c        call flush(iout)
 837         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 838      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 839 c        write (iout,*) "Gather ntask_cont_to ended"
 840 c        call flush(iout)
 841         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 842      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 843 c        write (iout,*) "Gather itask_cont_to ended"
 844 c        call flush(iout)
 845         if (fg_rank.eq.king) then
 846           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 847           do i=0,nfgtasks-1
 848             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 849      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 850           enddo
 851           write (iout,*)
 852           call flush(iout)
 853           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 854           do i=0,nfgtasks-1
 855             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 856      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 857           enddo
 858           write (iout,*)
 859           call flush(iout)
 860 C Check if every send will have a matching receive
 861           ncheck_to=0
 862           ncheck_from=0
 863           do i=0,nfgtasks-1
 864             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 865             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 866           enddo
 867           write (iout,*) "Control sums",ncheck_from,ncheck_to
 868           if (ncheck_from.ne.ncheck_to) then
 869             write (iout,*) "Error: #receive differs from #send."
 870             write (iout,*) "Terminating program...!"
 871             call flush(iout)
 872             flag=.false.
 873           else
 874             flag=.true.
 875             do i=0,nfgtasks-1
 876               do j=1,ntask_cont_to_all(i)
 877                 ii=itask_cont_to_all(j,i)
 878                 do k=1,ntask_cont_from_all(ii)
 879                   if (itask_cont_from_all(k,ii).eq.i) then
 880                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 881                     exit
 882                   endif
 883                 enddo
 884                 if (k.eq.ntask_cont_from_all(ii)+1) then
 885                   flag=.false.
 886                   write (iout,*) "Error: send by",j," to",ii,
 887      &            " would have no matching receive"
 888                 endif
 889               enddo
 890             enddo
 891           endif
 892           if (.not.flag) then
 893             write (iout,*) "Unmatched sends; terminating program"
 894             call flush(iout)
 895           endif
 896         endif
 897         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 898 c        write (iout,*) "flag broadcast ended flag=",flag
 899 c        call flush(iout)
 900         if (.not.flag) then
 901           call MPI_Finalize(IERROR)
 902           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 903         endif
 904         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 905 c        write (iout,*) "MPI_Comm_group ended"
 906 c        call flush(iout)
 907         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 908      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 909         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 910      &    CONT_TO_GROUP,IERR)
 911         do i=1,nat_sent
 912           ii=iat_sent(i)
 913           iaux=4*(ielend(ii)-ielstart(ii)+1)
 914           call MPI_Group_translate_ranks(fg_group,iaux,
 915      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 916      &      iint_sent_local(1,ielstart(ii),i),IERR )
 917 c          write (iout,*) "Ranks translated i=",i
 918 c          call flush(iout)
 919         enddo
 920         iaux=4*(iturn3_end-iturn3_start+1)
 921         call MPI_Group_translate_ranks(fg_group,iaux,
 922      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 923      &      iturn3_sent_local(1,iturn3_start),IERR)
 924         iaux=4*(iturn4_end-iturn4_start+1)
 925         call MPI_Group_translate_ranks(fg_group,iaux,
 926      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 927      &      iturn4_sent_local(1,iturn4_start),IERR)
 928         if (lprint) then
 929         write (iout,*) "iint_sent_local"
 930         do i=1,nat_sent
 931           ii=iat_sent(i)
 932           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 933      &      j=ielstart(ii),ielend(ii))
 934           call flush(iout)
 935         enddo
 936         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 937      &    " iturn3_end",iturn3_end
 938         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 939      &      i=iturn3_start,iturn3_end)
 940         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 941      &    " iturn4_end",iturn4_end
 942         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 943      &      i=iturn4_start,iturn4_end)
 944         call flush(iout)
 945         endif
 946         call MPI_Group_free(fg_group,ierr)
 947         call MPI_Group_free(cont_from_group,ierr)
 948         call MPI_Group_free(cont_to_group,ierr)
 949         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 950         call MPI_Type_commit(MPI_UYZ,IERROR)
 951         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 952      &    IERROR)
 953         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 954         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 955         call MPI_Type_commit(MPI_MU,IERROR)
 956         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 957         call MPI_Type_commit(MPI_MAT1,IERROR)
 958         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 959         call MPI_Type_commit(MPI_MAT2,IERROR)
 960         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 961         call MPI_Type_commit(MPI_THET,IERROR)
 962         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 963         call MPI_Type_commit(MPI_GAM,IERROR)
 964 #ifndef MATGATHER
 965 c 9/22/08 Derived types to send matrices which appear in correlation terms
 966         do i=0,nfgtasks-1
 967           if (ivec_count(i).eq.ivec_count(0)) then
 968             lentyp(i)=0
 969           else
 970             lentyp(i)=1
 971           endif
 972         enddo
 973         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 974         if (ind_typ.eq.0) then
 975           ichunk=ivec_count(0)
 976         else
 977           ichunk=ivec_count(1)
 978         endif
 979 c        do i=1,4
 980 c          blocklengths(i)=4
 981 c        enddo
 982 c        displs(1)=0
 983 c        do i=2,4
 984 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 985 c        enddo
 986 c        do i=1,4
 987 c          blocklengths(i)=blocklengths(i)*ichunk
 988 c        enddo
 989 c        write (iout,*) "blocklengths and displs"
 990 c        do i=1,4
 991 c          write (iout,*) i,blocklengths(i),displs(i)
 992 c        enddo
 993 c        call flush(iout)
 994 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 995 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
 996 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
 997 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
 998 c        do i=1,4
 999 c          blocklengths(i)=2
1000 c        enddo
1001 c        displs(1)=0
1002 c        do i=2,4
1003 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1004 c        enddo
1005 c        do i=1,4
1006 c          blocklengths(i)=blocklengths(i)*ichunk
1007 c        enddo
1008 c        write (iout,*) "blocklengths and displs"
1009 c        do i=1,4
1010 c          write (iout,*) i,blocklengths(i),displs(i)
1011 c        enddo
1012 c        call flush(iout)
1013 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
1014 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
1015 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
1016 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
1017         do i=1,8
1018           blocklengths(i)=2
1019         enddo
1020         displs(1)=0
1021         do i=2,8
1022           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1023         enddo
1024         do i=1,15
1025           blocklengths(i)=blocklengths(i)*ichunk
1026         enddo
1027         call MPI_Type_indexed(8,blocklengths,displs,
1028      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
1029         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1030         do i=1,8
1031           blocklengths(i)=4
1032         enddo
1033         displs(1)=0
1034         do i=2,8
1035           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1036         enddo
1037         do i=1,15
1038           blocklengths(i)=blocklengths(i)*ichunk
1039         enddo
1040         call MPI_Type_indexed(8,blocklengths,displs,
1041      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1042         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1043         do i=1,6
1044           blocklengths(i)=4
1045         enddo
1046         displs(1)=0
1047         do i=2,6
1048           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1049         enddo
1050         do i=1,6
1051           blocklengths(i)=blocklengths(i)*ichunk
1052         enddo
1053         call MPI_Type_indexed(6,blocklengths,displs,
1054      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1055         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1056         do i=1,2
1057           blocklengths(i)=8
1058         enddo
1059         displs(1)=0
1060         do i=2,2
1061           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1062         enddo
1063         do i=1,2
1064           blocklengths(i)=blocklengths(i)*ichunk
1065         enddo
1066         call MPI_Type_indexed(2,blocklengths,displs,
1067      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1068         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1069         do i=1,4
1070           blocklengths(i)=1
1071         enddo
1072         displs(1)=0
1073         do i=2,4
1074           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1075         enddo
1076         do i=1,4
1077           blocklengths(i)=blocklengths(i)*ichunk
1078         enddo
1079         call MPI_Type_indexed(4,blocklengths,displs,
1080      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1081         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1082         enddo
1083 #endif
1084       endif
1085       iint_start=ivec_start+1
1086       iint_end=ivec_end+1
1087       do i=0,nfgtasks-1
1088           iint_count(i)=ivec_count(i)
1089           iint_displ(i)=ivec_displ(i)
1090           ivec_displ(i)=ivec_displ(i)-1
1091           iset_displ(i)=iset_displ(i)-1
1092           ithet_displ(i)=ithet_displ(i)-1
1093           iphi_displ(i)=iphi_displ(i)-1
1094           iphi1_displ(i)=iphi1_displ(i)-1
1095           ibond_displ(i)=ibond_displ(i)-1
1096       enddo
1097       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1098      &     .and. (me.eq.0 .or. .not. out1file)) then
1099         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1100         do i=0,nfgtasks-1
1101           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1102      &      iset_count(i)
1103         enddo
1104         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1105      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1106         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1107         do i=0,nfgtasks-1
1108           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1109      &      iphi1_displ(i)
1110         enddo
1111         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1112      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1113      & ' SC-p interactions','were distributed among',nfgtasks,
1114      & ' fine-grain processors.'
1115       endif
1116 #else
1117       loc_start=2
1118       loc_end=nres-1
1119       ithet_start=3
1120       ithet_end=nres
1121       iturn3_start=nnt
1122       iturn3_end=nct-3
1123       iturn4_start=nnt
1124       iturn4_end=nct-4
1125       iphi_start=nnt+3
1126       iphi_end=nct
1127       iphi1_start=4
1128       iphi1_end=nres
1129       idihconstr_start=1
1130       idihconstr_end=ndih_constr
1131       iphid_start=iphi_start
1132       iphid_end=iphi_end-1
1133       itau_start=4
1134       itau_end=nres
1135       ibond_start=2
1136       ibond_end=nres-1
1137       ibondp_start=nnt
1138       ibondp_end=nct-1
1139       ivec_start=1
1140       ivec_end=nres-1
1141       iset_start=3
1142       iset_end=nres+1
1143       iint_start=2
1144       iint_end=nres-1
1145 #endif
1146       return
1147       end
1148 #ifdef MPI
1149 c---------------------------------------------------------------------------
1150       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1151       implicit none
1152       include "DIMENSIONS"
1153       include "COMMON.INTERACT"
1154       include "COMMON.SETUP"
1155       include "COMMON.IOUNITS"
1156       integer ii,jj,itask(4),ntask_cont_to,
1157      &itask_cont_to(0:max_fg_procs-1)
1158       logical flag
1159       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1160      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1161       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1162      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1163      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1164      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1165      & ielend_all(maxres,0:max_fg_procs-1)
1166       integer iproc,isent,k,l
1167 c Determines whether to send interaction ii,jj to other processors; a given
1168 c interaction can be sent to at most 2 processors.
1169 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1170 c one processor, otherwise flag is unchanged from the input value.
1171       isent=0
1172       itask(1)=fg_rank
1173       itask(2)=fg_rank
1174       itask(3)=fg_rank
1175       itask(4)=fg_rank
1176 c      write (iout,*) "ii",ii," jj",jj
1177 c Loop over processors to check if anybody could need interaction ii,jj
1178       do iproc=0,fg_rank-1
1179 c Check if the interaction matches any turn3 at iproc
1180         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1181           l=k+2
1182           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1183      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1184      &    then
1185 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1186 c            call flush(iout)
1187             flag=.true.
1188             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1189      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1190               isent=isent+1
1191               itask(isent)=iproc
1192               call add_task(iproc,ntask_cont_to,itask_cont_to)
1193             endif
1194           endif
1195         enddo
1196 C Check if the interaction matches any turn4 at iproc
1197         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1198           l=k+3
1199           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1200      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1201      &    then
1202 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1203 c            call flush(iout)
1204             flag=.true.
1205             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1206      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1207               isent=isent+1
1208               itask(isent)=iproc
1209               call add_task(iproc,ntask_cont_to,itask_cont_to)
1210             endif
1211           endif
1212         enddo
1213         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1214      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1215           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1216      &        ielend_all(ii-1,iproc).ge.jj-1) then
1217             flag=.true.
1218             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1219      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1220               isent=isent+1
1221               itask(isent)=iproc
1222               call add_task(iproc,ntask_cont_to,itask_cont_to)
1223             endif
1224           endif
1225           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1226      &        ielend_all(ii-1,iproc).ge.jj+1) then
1227             flag=.true.
1228             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1229      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1230               isent=isent+1
1231               itask(isent)=iproc
1232               call add_task(iproc,ntask_cont_to,itask_cont_to)
1233             endif
1234           endif
1235         endif
1236       enddo
1237       return
1238       end
1239 c---------------------------------------------------------------------------
1240       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1241       implicit none
1242       include "DIMENSIONS"
1243       include "COMMON.INTERACT"
1244       include "COMMON.SETUP"
1245       include "COMMON.IOUNITS"
1246       integer ii,jj,itask(2),ntask_cont_from,
1247      & itask_cont_from(0:max_fg_procs-1)
1248       logical flag
1249       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1250      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1251       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1252      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1253      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1254      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1255      & ielend_all(maxres,0:max_fg_procs-1)
1256       integer iproc,k,l
1257       do iproc=fg_rank+1,nfgtasks-1
1258         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1259           l=k+2
1260           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1261      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1262      &    then
1263 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1264             call add_task(iproc,ntask_cont_from,itask_cont_from)
1265           endif
1266         enddo
1267         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1268           l=k+3
1269           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1270      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1271      &    then
1272 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1273             call add_task(iproc,ntask_cont_from,itask_cont_from)
1274           endif
1275         enddo
1276         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1277           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1278      &    then
1279             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1280      &          jj+1.le.ielend_all(ii+1,iproc)) then
1281               call add_task(iproc,ntask_cont_from,itask_cont_from)
1282             endif
1283             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1284      &          jj-1.le.ielend_all(ii+1,iproc)) then
1285               call add_task(iproc,ntask_cont_from,itask_cont_from)
1286             endif
1287           endif
1288           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1289      &    then
1290             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1291      &          jj-1.le.ielend_all(ii-1,iproc)) then
1292               call add_task(iproc,ntask_cont_from,itask_cont_from)
1293             endif
1294             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1295      &          jj+1.le.ielend_all(ii-1,iproc)) then
1296                call add_task(iproc,ntask_cont_from,itask_cont_from)
1297             endif
1298           endif
1299         endif
1300       enddo
1301       return
1302       end
1303 c---------------------------------------------------------------------------
1304       subroutine add_task(iproc,ntask_cont,itask_cont)
1305       implicit none
1306       include "DIMENSIONS"
1307       integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1308       integer ii
1309       do ii=1,ntask_cont
1310         if (itask_cont(ii).eq.iproc) return
1311       enddo
1312       ntask_cont=ntask_cont+1
1313       itask_cont(ntask_cont)=iproc
1314       return
1315       end
1316 c---------------------------------------------------------------------------
1317       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1318       implicit real*8 (a-h,o-z)
1319       include 'DIMENSIONS'
1320       include 'mpif.h'
1321       include 'COMMON.SETUP'
1322       integer total_ints,lower_bound,upper_bound
1323       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1324       nint=total_ints/nfgtasks
1325       do i=1,nfgtasks
1326         int4proc(i-1)=nint
1327       enddo
1328       nexcess=total_ints-nint*nfgtasks
1329       do i=1,nexcess
1330         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1331       enddo
1332       lower_bound=0
1333       do i=0,fg_rank-1
1334         lower_bound=lower_bound+int4proc(i)
1335       enddo
1336       upper_bound=lower_bound+int4proc(fg_rank)
1337       lower_bound=lower_bound+1
1338       return
1339       end
1340 c---------------------------------------------------------------------------
1341       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1342       implicit real*8 (a-h,o-z)
1343       include 'DIMENSIONS'
1344       include 'mpif.h'
1345       include 'COMMON.SETUP'
1346       integer total_ints,lower_bound,upper_bound
1347       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1348       nint=total_ints/nfgtasks1
1349       do i=1,nfgtasks1
1350         int4proc(i-1)=nint
1351       enddo
1352       nexcess=total_ints-nint*nfgtasks1
1353       do i=1,nexcess
1354         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1355       enddo
1356       lower_bound=0
1357       do i=0,fg_rank1-1
1358         lower_bound=lower_bound+int4proc(i)
1359       enddo
1360       upper_bound=lower_bound+int4proc(fg_rank1)
1361       lower_bound=lower_bound+1
1362       return
1363       end
1364 c---------------------------------------------------------------------------
1365       subroutine int_partition(int_index,lower_index,upper_index,atom,
1366      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1367       implicit real*8 (a-h,o-z)
1368       include 'DIMENSIONS'
1369       include 'COMMON.IOUNITS'
1370       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1371      & first_atom,last_atom,int_gr,jat_start,jat_end
1372       logical lprn
1373       lprn=.false.
1374       if (lprn) write (iout,*) 'int_index=',int_index
1375       int_index_old=int_index
1376       int_index=int_index+last_atom-first_atom+1
1377       if (lprn)
1378      &   write (iout,*) 'int_index=',int_index,
1379      &               ' int_index_old',int_index_old,
1380      &               ' lower_index=',lower_index,
1381      &               ' upper_index=',upper_index,
1382      &               ' atom=',atom,' first_atom=',first_atom,
1383      &               ' last_atom=',last_atom
1384       if (int_index.ge.lower_index) then
1385         int_gr=int_gr+1
1386         if (at_start.eq.0) then
1387           at_start=atom
1388           jat_start=first_atom-1+lower_index-int_index_old
1389         else
1390           jat_start=first_atom
1391         endif
1392         if (lprn) write (iout,*) 'jat_start',jat_start
1393         if (int_index.ge.upper_index) then
1394           at_end=atom
1395           jat_end=first_atom-1+upper_index-int_index_old
1396           return1
1397         else
1398           jat_end=last_atom
1399         endif
1400         if (lprn) write (iout,*) 'jat_end',jat_end
1401       endif
1402       return
1403       end
1404 #endif
1405 c------------------------------------------------------------------------------
1406       subroutine hpb_partition
1407       implicit real*8 (a-h,o-z)
1408       include 'DIMENSIONS'
1409 #ifdef MPI
1410       include 'mpif.h'
1411 #endif
1412       include 'COMMON.SBRIDGE'
1413       include 'COMMON.IOUNITS'
1414       include 'COMMON.SETUP'
1415 #ifdef MPI
1416       call int_bounds(nhpb,link_start,link_end)
1417       write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1418      &  ' absolute rank',MyRank,
1419      &  ' nhpb',nhpb,' link_start=',link_start,
1420      &  ' link_end',link_end
1421 #else
1422       link_start=1
1423       link_end=nhpb
1424 #endif
1425       return
1426       end