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         do ii=1,nss
 381           if (ihpb(ii).eq.i+nres) then
 382             scheck=.true.
 383             jj=jhpb(ii)-nres
 384             goto 10
 385           endif
 386         enddo
 387    10   continue
 388 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 389         if (scheck) then
 390           if (jj.eq.i+1) then
 391 #ifdef MPI
 392 c            write (iout,*) 'jj=i+1'
 393             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 394      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 395 #else
 396             nint_gr(i)=1
 397             istart(i,1)=i+2
 398             iend(i,1)=nct
 399 #endif
 400           else if (jj.eq.nct) then
 401 #ifdef MPI
 402 c            write (iout,*) 'jj=nct'
 403             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 404      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 405 #else
 406             nint_gr(i)=1
 407             istart(i,1)=i+1
 408             iend(i,1)=nct-1
 409 #endif
 410           else
 411 #ifdef MPI
 412             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 413      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 414             ii=nint_gr(i)+1
 415             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 416      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 417 #else
 418             nint_gr(i)=2
 419             istart(i,1)=i+1
 420             iend(i,1)=jj-1
 421             istart(i,2)=jj+1
 422             iend(i,2)=nct
 423 #endif
 424           endif
 425         else
 426 #ifdef MPI
 427           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 428      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 429 #else
 430           nint_gr(i)=1
 431           istart(i,1)=i+1
 432           iend(i,1)=nct
 433           ind_scint=ind_scint+nct-i
 434 #endif
 435         endif
 436 #ifdef MPI
 437         ind_scint_old=ind_scint
 438 #endif
 439       enddo
 440    12 continue
 441 #ifndef MPI
 442       iatsc_s=nnt
 443       iatsc_e=nct-1
 444 #endif
 445       if (iatsc_s.eq.0) iatsc_s=1
 446 #ifdef MPI
 447       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 448      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 449 #endif
 450       if (lprint) then
 451       write (iout,'(a)') 'Interaction array:'
 452       do i=iatsc_s,iatsc_e
 453         write (iout,'(i3,2(2x,2i3))')
 454      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 455       enddo
 456       endif
 457       ispp=4
 458 #ifdef MPI
 459 C Now partition the electrostatic-interaction array
 460       npept=nct-nnt
 461       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 462       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 463       if (lprint)
 464      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 465      &  ' absolute rank',MyRank,
 466      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 467      &               ' my_ele_inde',my_ele_inde
 468       iatel_s=0
 469       iatel_e=0
 470       ind_eleint=0
 471       ind_eleint_old=0
 472       do i=nnt,nct-3
 473         ijunk=0
 474         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 475      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 476       enddo ! i
 477    13 continue
 478       if (iatel_s.eq.0) iatel_s=1
 479       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 480 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 481       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 482 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 483 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 484       ind_eleint_vdw=0
 485       ind_eleint_vdw_old=0
 486       iatel_s_vdw=0
 487       iatel_e_vdw=0
 488       do i=nnt,nct-3
 489         ijunk=0
 490         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 491      &    my_ele_inde_vdw,i,
 492      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 493      &    ielend_vdw(i),*15)
 494 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 495 c     &   " ielend_vdw",ielend_vdw(i)
 496       enddo ! i
 497       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 498    15 continue
 499 #else
 500       iatel_s=nnt
 501       iatel_e=nct-5
 502       do i=iatel_s,iatel_e
 503         ielstart(i)=i+4
 504         ielend(i)=nct-1
 505       enddo
 506       iatel_s_vdw=nnt
 507       iatel_e_vdw=nct-3
 508       do i=iatel_s_vdw,iatel_e_vdw
 509         ielstart_vdw(i)=i+2
 510         ielend_vdw(i)=nct-1
 511       enddo
 512 #endif
 513       if (lprint) then
 514         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 515      &  ' absolute rank',MyRank
 516         write (iout,*) 'Electrostatic interaction array:'
 517         do i=iatel_s,iatel_e
 518           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 519         enddo
 520       endif ! lprint
 521 c     iscp=3
 522       iscp=2
 523 C Partition the SC-p interaction array
 524 #ifdef MPI
 525       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 526       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 527       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 528      &  ' absolute rank',myrank,
 529      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 530      &               ' my_scp_inde',my_scp_inde
 531       iatscp_s=0
 532       iatscp_e=0
 533       ind_scpint=0
 534       ind_scpint_old=0
 535       do i=nnt,nct-1
 536         if (i.lt.nnt+iscp) then
 537 cd        write (iout,*) 'i.le.nnt+iscp'
 538           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 539      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 540      &      iscpend(i,1),*14)
 541         else if (i.gt.nct-iscp) then
 542 cd        write (iout,*) 'i.gt.nct-iscp'
 543           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 544      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 545      &      iscpend(i,1),*14)
 546         else
 547           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 548      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 549      &      iscpend(i,1),*14)
 550           ii=nscp_gr(i)+1
 551           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 552      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 553      &      iscpend(i,ii),*14)
 554         endif
 555       enddo ! i
 556    14 continue
 557 #else
 558       iatscp_s=nnt
 559       iatscp_e=nct-1
 560       do i=nnt,nct-1
 561         if (i.lt.nnt+iscp) then
 562           nscp_gr(i)=1
 563           iscpstart(i,1)=i+iscp
 564           iscpend(i,1)=nct
 565         elseif (i.gt.nct-iscp) then
 566           nscp_gr(i)=1
 567           iscpstart(i,1)=nnt
 568           iscpend(i,1)=i-iscp
 569         else
 570           nscp_gr(i)=2
 571           iscpstart(i,1)=nnt
 572           iscpend(i,1)=i-iscp
 573           iscpstart(i,2)=i+iscp
 574           iscpend(i,2)=nct
 575         endif
 576       enddo ! i
 577 #endif
 578       if (iatscp_s.eq.0) iatscp_s=1
 579       if (lprint) then
 580         write (iout,'(a)') 'SC-p interaction array:'
 581         do i=iatscp_s,iatscp_e
 582           write (iout,'(i3,2(2x,2i3))')
 583      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 584         enddo
 585       endif ! lprint
 586 C Partition local interactions
 587 #ifdef MPI
 588       call int_bounds(nres-2,loc_start,loc_end)
 589       loc_start=loc_start+1
 590       loc_end=loc_end+1
 591       call int_bounds(nres-2,ithet_start,ithet_end)
 592       ithet_start=ithet_start+2
 593       ithet_end=ithet_end+2
 594       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 595       iturn3_start=iturn3_start+nnt
 596       iphi_start=iturn3_start+2
 597       iturn3_end=iturn3_end+nnt
 598       iphi_end=iturn3_end+2
 599       iturn3_start=iturn3_start-1
 600       iturn3_end=iturn3_end-1
 601       call int_bounds(nres-3,itau_start,itau_end)
 602       itau_start=itau_start+3
 603       itau_end=itau_end+3
 604       call int_bounds(nres-3,iphi1_start,iphi1_end)
 605       iphi1_start=iphi1_start+3
 606       iphi1_end=iphi1_end+3
 607       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 608       iturn4_start=iturn4_start+nnt
 609       iphid_start=iturn4_start+2
 610       iturn4_end=iturn4_end+nnt
 611       iphid_end=iturn4_end+2
 612       iturn4_start=iturn4_start-1
 613       iturn4_end=iturn4_end-1
 614       call int_bounds(nres-2,ibond_start,ibond_end)
 615       ibond_start=ibond_start+1
 616       ibond_end=ibond_end+1
 617       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 618       ibondp_start=ibondp_start+nnt
 619       ibondp_end=ibondp_end+nnt
 620       call int_bounds1(nres-1,ivec_start,ivec_end)
 621 c      print *,"Processor",myrank,fg_rank,fg_rank1,
 622 c     &  " ivec_start",ivec_start," ivec_end",ivec_end
 623       iset_start=loc_start+2
 624       iset_end=loc_end+2
 625       if (ndih_constr.eq.0) then
 626         idihconstr_start=1
 627         idihconstr_end=0
 628       else
 629         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 630       endif
 631 c      nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 632 c      nlen=nres-nnt+1
 633       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 634       nlen=nres-nnt+1
 635       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 636       igrad_start=((2*nlen+1)
 637      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 638       jgrad_start(igrad_start)=
 639      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 640      &    +igrad_start
 641       jgrad_end(igrad_start)=nres
 642       igrad_end=((2*nlen+1)
 643      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 644       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 645       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 646      &    +igrad_end
 647       do i=igrad_start+1,igrad_end-1
 648         jgrad_start(i)=i+1
 649         jgrad_end(i)=nres
 650       enddo
 651       if (lprint) then
 652         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 653      & ' absolute rank',myrank,
 654      & ' loc_start',loc_start,' loc_end',loc_end,
 655      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 656      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 657      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 658      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 659      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 660      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 661      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 662      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 663      & ' iset_start',iset_start,' iset_end',iset_end,
 664      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 665      &   idihconstr_end
 666        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 667      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 668      &   ' ngrad_end',ngrad_end
 669        do i=igrad_start,igrad_end
 670          write(*,*) 'Processor:',fg_rank,myrank,i,
 671      &    jgrad_start(i),jgrad_end(i)
 672        enddo
 673       endif
 674       if (nfgtasks.gt.1) then
 675         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 676      &    MPI_INTEGER,FG_COMM1,IERROR)
 677         iaux=ivec_end-ivec_start+1
 678         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 679      &    MPI_INTEGER,FG_COMM1,IERROR)
 680         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 681      &    MPI_INTEGER,FG_COMM,IERROR)
 682         iaux=iset_end-iset_start+1
 683         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 684      &    MPI_INTEGER,FG_COMM,IERROR)
 685         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 686      &    MPI_INTEGER,FG_COMM,IERROR)
 687         iaux=ibond_end-ibond_start+1
 688         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 689      &    MPI_INTEGER,FG_COMM,IERROR)
 690         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 691      &    MPI_INTEGER,FG_COMM,IERROR)
 692         iaux=ithet_end-ithet_start+1
 693         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 694      &    MPI_INTEGER,FG_COMM,IERROR)
 695         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 696      &    MPI_INTEGER,FG_COMM,IERROR)
 697         iaux=iphi_end-iphi_start+1
 698         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 699      &    MPI_INTEGER,FG_COMM,IERROR)
 700         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 701      &    MPI_INTEGER,FG_COMM,IERROR)
 702         iaux=iphi1_end-iphi1_start+1
 703         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 704      &    MPI_INTEGER,FG_COMM,IERROR)
 705         do i=0,maxprocs-1
 706           do j=1,maxres
 707             ielstart_all(j,i)=0
 708             ielend_all(j,i)=0
 709           enddo
 710         enddo
 711         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 712      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 713         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 714      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 715         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 716      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 717         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 718      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 719         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 720      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 721         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 722      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 723         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 724      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 725         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 726      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 727         if (lprint) then
 728         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 729         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 730         write (iout,*) "iturn3_start_all",
 731      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 732         write (iout,*) "iturn3_end_all",
 733      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 734         write (iout,*) "iturn4_start_all",
 735      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 736         write (iout,*) "iturn4_end_all",
 737      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 738         write (iout,*) "The ielstart_all array"
 739         do i=nnt,nct
 740           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 741         enddo
 742         write (iout,*) "The ielend_all array"
 743         do i=nnt,nct
 744           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 745         enddo
 746         call flush(iout)
 747         endif
 748         ntask_cont_from=0
 749         ntask_cont_to=0
 750         itask_cont_from(0)=fg_rank
 751         itask_cont_to(0)=fg_rank
 752         flag=.false.
 753         do ii=iturn3_start,iturn3_end
 754           call add_int(ii,ii+2,iturn3_sent(1,ii),
 755      &                 ntask_cont_to,itask_cont_to,flag)
 756         enddo
 757         do ii=iturn4_start,iturn4_end
 758           call add_int(ii,ii+3,iturn4_sent(1,ii),
 759      &                 ntask_cont_to,itask_cont_to,flag)
 760         enddo
 761         do ii=iturn3_start,iturn3_end
 762           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 763         enddo
 764         do ii=iturn4_start,iturn4_end
 765           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 766         enddo
 767         if (lprint) then
 768         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 769      &   " ntask_cont_to",ntask_cont_to
 770         write (iout,*) "itask_cont_from",
 771      &    (itask_cont_from(i),i=1,ntask_cont_from)
 772         write (iout,*) "itask_cont_to",
 773      &    (itask_cont_to(i),i=1,ntask_cont_to)
 774         call flush(iout)
 775         endif
 776 c        write (iout,*) "Loop forward"
 777 c        call flush(iout)
 778         do i=iatel_s,iatel_e
 779 c          write (iout,*) "from loop i=",i
 780 c          call flush(iout)
 781           do j=ielstart(i),ielend(i)
 782             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 783           enddo
 784         enddo
 785 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 786 c     &     " iatel_e",iatel_e
 787 c        call flush(iout)
 788         nat_sent=0
 789         do i=iatel_s,iatel_e
 790 c          write (iout,*) "i",i," ielstart",ielstart(i),
 791 c     &      " ielend",ielend(i)
 792 c          call flush(iout)
 793           flag=.false.
 794           do j=ielstart(i),ielend(i)
 795             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 796      &                   itask_cont_to,flag)
 797           enddo
 798           if (flag) then
 799             nat_sent=nat_sent+1
 800             iat_sent(nat_sent)=i
 801           endif
 802         enddo
 803         if (lprint) then
 804         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 805      &   " ntask_cont_to",ntask_cont_to
 806         write (iout,*) "itask_cont_from",
 807      &    (itask_cont_from(i),i=1,ntask_cont_from)
 808         write (iout,*) "itask_cont_to",
 809      &    (itask_cont_to(i),i=1,ntask_cont_to)
 810         call flush(iout)
 811         write (iout,*) "iint_sent"
 812         do i=1,nat_sent
 813           ii=iat_sent(i)
 814           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 815      &      j=ielstart(ii),ielend(ii))
 816         enddo
 817         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 818      &    " iturn3_end",iturn3_end
 819         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 820      &      i=iturn3_start,iturn3_end)
 821         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 822      &    " iturn4_end",iturn4_end
 823         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 824      &      i=iturn4_start,iturn4_end)
 825         call flush(iout)
 826         endif
 827         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 828      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 829 c        write (iout,*) "Gather ntask_cont_from ended"
 830 c        call flush(iout)
 831         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 832      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 833      &   FG_COMM,IERR)
 834 c        write (iout,*) "Gather itask_cont_from ended"
 835 c        call flush(iout)
 836         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 837      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 838 c        write (iout,*) "Gather ntask_cont_to ended"
 839 c        call flush(iout)
 840         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 841      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 842 c        write (iout,*) "Gather itask_cont_to ended"
 843 c        call flush(iout)
 844         if (fg_rank.eq.king) then
 845           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 846           do i=0,nfgtasks-1
 847             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 848      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 849           enddo
 850           write (iout,*)
 851           call flush(iout)
 852           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 853           do i=0,nfgtasks-1
 854             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 855      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 856           enddo
 857           write (iout,*)
 858           call flush(iout)
 859 C Check if every send will have a matching receive
 860           ncheck_to=0
 861           ncheck_from=0
 862           do i=0,nfgtasks-1
 863             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 864             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 865           enddo
 866           write (iout,*) "Control sums",ncheck_from,ncheck_to
 867           if (ncheck_from.ne.ncheck_to) then
 868             write (iout,*) "Error: #receive differs from #send."
 869             write (iout,*) "Terminating program...!"
 870             call flush(iout)
 871             flag=.false.
 872           else
 873             flag=.true.
 874             do i=0,nfgtasks-1
 875               do j=1,ntask_cont_to_all(i)
 876                 ii=itask_cont_to_all(j,i)
 877                 do k=1,ntask_cont_from_all(ii)
 878                   if (itask_cont_from_all(k,ii).eq.i) then
 879                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 880                     exit
 881                   endif
 882                 enddo
 883                 if (k.eq.ntask_cont_from_all(ii)+1) then
 884                   flag=.false.
 885                   write (iout,*) "Error: send by",j," to",ii,
 886      &            " would have no matching receive"
 887                 endif
 888               enddo
 889             enddo
 890           endif
 891           if (.not.flag) then
 892             write (iout,*) "Unmatched sends; terminating program"
 893             call flush(iout)
 894           endif
 895         endif
 896         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 897 c        write (iout,*) "flag broadcast ended flag=",flag
 898 c        call flush(iout)
 899         if (.not.flag) then
 900           call MPI_Finalize(IERROR)
 901           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 902         endif
 903         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 904 c        write (iout,*) "MPI_Comm_group ended"
 905 c        call flush(iout)
 906         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 907      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 908         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 909      &    CONT_TO_GROUP,IERR)
 910         do i=1,nat_sent
 911           ii=iat_sent(i)
 912           iaux=4*(ielend(ii)-ielstart(ii)+1)
 913           call MPI_Group_translate_ranks(fg_group,iaux,
 914      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 915      &      iint_sent_local(1,ielstart(ii),i),IERR )
 916 c          write (iout,*) "Ranks translated i=",i
 917 c          call flush(iout)
 918         enddo
 919         iaux=4*(iturn3_end-iturn3_start+1)
 920         call MPI_Group_translate_ranks(fg_group,iaux,
 921      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 922      &      iturn3_sent_local(1,iturn3_start),IERR)
 923         iaux=4*(iturn4_end-iturn4_start+1)
 924         call MPI_Group_translate_ranks(fg_group,iaux,
 925      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 926      &      iturn4_sent_local(1,iturn4_start),IERR)
 927         if (lprint) then
 928         write (iout,*) "iint_sent_local"
 929         do i=1,nat_sent
 930           ii=iat_sent(i)
 931           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 932      &      j=ielstart(ii),ielend(ii))
 933           call flush(iout)
 934         enddo
 935         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 936      &    " iturn3_end",iturn3_end
 937         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 938      &      i=iturn3_start,iturn3_end)
 939         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 940      &    " iturn4_end",iturn4_end
 941         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 942      &      i=iturn4_start,iturn4_end)
 943         call flush(iout)
 944         endif
 945         call MPI_Group_free(fg_group,ierr)
 946         call MPI_Group_free(cont_from_group,ierr)
 947         call MPI_Group_free(cont_to_group,ierr)
 948         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 949         call MPI_Type_commit(MPI_UYZ,IERROR)
 950         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 951      &    IERROR)
 952         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 953         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 954         call MPI_Type_commit(MPI_MU,IERROR)
 955         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 956         call MPI_Type_commit(MPI_MAT1,IERROR)
 957         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 958         call MPI_Type_commit(MPI_MAT2,IERROR)
 959         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 960         call MPI_Type_commit(MPI_THET,IERROR)
 961         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 962         call MPI_Type_commit(MPI_GAM,IERROR)
 963 #ifndef MATGATHER
 964 c 9/22/08 Derived types to send matrices which appear in correlation terms
 965         do i=0,nfgtasks-1
 966           if (ivec_count(i).eq.ivec_count(0)) then
 967             lentyp(i)=0
 968           else
 969             lentyp(i)=1
 970           endif
 971         enddo
 972         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 973         if (ind_typ.eq.0) then
 974           ichunk=ivec_count(0)
 975         else
 976           ichunk=ivec_count(1)
 977         endif
 978 c        do i=1,4
 979 c          blocklengths(i)=4
 980 c        enddo
 981 c        displs(1)=0
 982 c        do i=2,4
 983 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 984 c        enddo
 985 c        do i=1,4
 986 c          blocklengths(i)=blocklengths(i)*ichunk
 987 c        enddo
 988 c        write (iout,*) "blocklengths and displs"
 989 c        do i=1,4
 990 c          write (iout,*) i,blocklengths(i),displs(i)
 991 c        enddo
 992 c        call flush(iout)
 993 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 994 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
 995 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
 996 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
 997 c        do i=1,4
 998 c          blocklengths(i)=2
 999 c        enddo
1000 c        displs(1)=0
1001 c        do i=2,4
1002 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1003 c        enddo
1004 c        do i=1,4
1005 c          blocklengths(i)=blocklengths(i)*ichunk
1006 c        enddo
1007 c        write (iout,*) "blocklengths and displs"
1008 c        do i=1,4
1009 c          write (iout,*) i,blocklengths(i),displs(i)
1010 c        enddo
1011 c        call flush(iout)
1012 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
1013 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
1014 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
1015 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
1016         do i=1,8
1017           blocklengths(i)=2
1018         enddo
1019         displs(1)=0
1020         do i=2,8
1021           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1022         enddo
1023         do i=1,15
1024           blocklengths(i)=blocklengths(i)*ichunk
1025         enddo
1026         call MPI_Type_indexed(8,blocklengths,displs,
1027      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
1028         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1029         do i=1,8
1030           blocklengths(i)=4
1031         enddo
1032         displs(1)=0
1033         do i=2,8
1034           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1035         enddo
1036         do i=1,15
1037           blocklengths(i)=blocklengths(i)*ichunk
1038         enddo
1039         call MPI_Type_indexed(8,blocklengths,displs,
1040      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1041         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1042         do i=1,6
1043           blocklengths(i)=4
1044         enddo
1045         displs(1)=0
1046         do i=2,6
1047           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1048         enddo
1049         do i=1,6
1050           blocklengths(i)=blocklengths(i)*ichunk
1051         enddo
1052         call MPI_Type_indexed(6,blocklengths,displs,
1053      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1054         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1055         do i=1,2
1056           blocklengths(i)=8
1057         enddo
1058         displs(1)=0
1059         do i=2,2
1060           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1061         enddo
1062         do i=1,2
1063           blocklengths(i)=blocklengths(i)*ichunk
1064         enddo
1065         call MPI_Type_indexed(2,blocklengths,displs,
1066      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1067         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1068         do i=1,4
1069           blocklengths(i)=1
1070         enddo
1071         displs(1)=0
1072         do i=2,4
1073           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1074         enddo
1075         do i=1,4
1076           blocklengths(i)=blocklengths(i)*ichunk
1077         enddo
1078         call MPI_Type_indexed(4,blocklengths,displs,
1079      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1080         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1081         enddo
1082 #endif
1083       endif
1084       iint_start=ivec_start+1
1085       iint_end=ivec_end+1
1086       do i=0,nfgtasks-1
1087           iint_count(i)=ivec_count(i)
1088           iint_displ(i)=ivec_displ(i)
1089           ivec_displ(i)=ivec_displ(i)-1
1090           iset_displ(i)=iset_displ(i)-1
1091           ithet_displ(i)=ithet_displ(i)-1
1092           iphi_displ(i)=iphi_displ(i)-1
1093           iphi1_displ(i)=iphi1_displ(i)-1
1094           ibond_displ(i)=ibond_displ(i)-1
1095       enddo
1096       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1097      &     .and. (me.eq.0 .or. .not. out1file)) then
1098         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1099         do i=0,nfgtasks-1
1100           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1101      &      iset_count(i)
1102         enddo
1103         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1104      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1105         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1106         do i=0,nfgtasks-1
1107           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1108      &      iphi1_displ(i)
1109         enddo
1110         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1111      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1112      & ' SC-p interactions','were distributed among',nfgtasks,
1113      & ' fine-grain processors.'
1114       endif
1115 #else
1116       loc_start=2
1117       loc_end=nres-1
1118       ithet_start=3
1119       ithet_end=nres
1120       iturn3_start=nnt
1121       iturn3_end=nct-3
1122       iturn4_start=nnt
1123       iturn4_end=nct-4
1124       iphi_start=nnt+3
1125       iphi_end=nct
1126       iphi1_start=4
1127       iphi1_end=nres
1128       idihconstr_start=1
1129       idihconstr_end=ndih_constr
1130       iphid_start=iphi_start
1131       iphid_end=iphi_end-1
1132       itau_start=4
1133       itau_end=nres
1134       ibond_start=2
1135       ibond_end=nres-1
1136       ibondp_start=nnt
1137       ibondp_end=nct-1
1138       ivec_start=1
1139       ivec_end=nres-1
1140       iset_start=3
1141       iset_end=nres+1
1142       iint_start=2
1143       iint_end=nres-1
1144 #endif
1145       return
1146       end
1147 #ifdef MPI
1148 c---------------------------------------------------------------------------
1149       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1150       implicit none
1151       include "DIMENSIONS"
1152       include "COMMON.INTERACT"
1153       include "COMMON.SETUP"
1154       include "COMMON.IOUNITS"
1155       integer ii,jj,itask(4),ntask_cont_to,
1156      &itask_cont_to(0:max_fg_procs-1)
1157       logical flag
1158       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1159      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1160       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1161      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1162      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1163      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1164      & ielend_all(maxres,0:max_fg_procs-1)
1165       integer iproc,isent,k,l
1166 c Determines whether to send interaction ii,jj to other processors; a given
1167 c interaction can be sent to at most 2 processors.
1168 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1169 c one processor, otherwise flag is unchanged from the input value.
1170       isent=0
1171       itask(1)=fg_rank
1172       itask(2)=fg_rank
1173       itask(3)=fg_rank
1174       itask(4)=fg_rank
1175 c      write (iout,*) "ii",ii," jj",jj
1176 c Loop over processors to check if anybody could need interaction ii,jj
1177       do iproc=0,fg_rank-1
1178 c Check if the interaction matches any turn3 at iproc
1179         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1180           l=k+2
1181           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1182      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1183      &    then
1184 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1185 c            call flush(iout)
1186             flag=.true.
1187             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1188      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1189               isent=isent+1
1190               itask(isent)=iproc
1191               call add_task(iproc,ntask_cont_to,itask_cont_to)
1192             endif
1193           endif
1194         enddo
1195 C Check if the interaction matches any turn4 at iproc
1196         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1197           l=k+3
1198           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1199      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1200      &    then
1201 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1202 c            call flush(iout)
1203             flag=.true.
1204             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1205      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1206               isent=isent+1
1207               itask(isent)=iproc
1208               call add_task(iproc,ntask_cont_to,itask_cont_to)
1209             endif
1210           endif
1211         enddo
1212         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1213      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1214           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1215      &        ielend_all(ii-1,iproc).ge.jj-1) then
1216             flag=.true.
1217             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1218      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1219               isent=isent+1
1220               itask(isent)=iproc
1221               call add_task(iproc,ntask_cont_to,itask_cont_to)
1222             endif
1223           endif
1224           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1225      &        ielend_all(ii-1,iproc).ge.jj+1) then
1226             flag=.true.
1227             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1228      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1229               isent=isent+1
1230               itask(isent)=iproc
1231               call add_task(iproc,ntask_cont_to,itask_cont_to)
1232             endif
1233           endif
1234         endif
1235       enddo
1236       return
1237       end
1238 c---------------------------------------------------------------------------
1239       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1240       implicit none
1241       include "DIMENSIONS"
1242       include "COMMON.INTERACT"
1243       include "COMMON.SETUP"
1244       include "COMMON.IOUNITS"
1245       integer ii,jj,itask(2),ntask_cont_from,
1246      & itask_cont_from(0:max_fg_procs-1)
1247       logical flag
1248       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1249      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1250       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1251      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1252      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1253      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1254      & ielend_all(maxres,0:max_fg_procs-1)
1255       integer iproc,k,l
1256       do iproc=fg_rank+1,nfgtasks-1
1257         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1258           l=k+2
1259           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1260      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1261      &    then
1262 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1263             call add_task(iproc,ntask_cont_from,itask_cont_from)
1264           endif
1265         enddo
1266         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1267           l=k+3
1268           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1269      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1270      &    then
1271 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1272             call add_task(iproc,ntask_cont_from,itask_cont_from)
1273           endif
1274         enddo
1275         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1276           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1277      &    then
1278             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1279      &          jj+1.le.ielend_all(ii+1,iproc)) then
1280               call add_task(iproc,ntask_cont_from,itask_cont_from)
1281             endif
1282             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1283      &          jj-1.le.ielend_all(ii+1,iproc)) then
1284               call add_task(iproc,ntask_cont_from,itask_cont_from)
1285             endif
1286           endif
1287           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1288      &    then
1289             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1290      &          jj-1.le.ielend_all(ii-1,iproc)) then
1291               call add_task(iproc,ntask_cont_from,itask_cont_from)
1292             endif
1293             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1294      &          jj+1.le.ielend_all(ii-1,iproc)) then
1295                call add_task(iproc,ntask_cont_from,itask_cont_from)
1296             endif
1297           endif
1298         endif
1299       enddo
1300       return
1301       end
1302 c---------------------------------------------------------------------------
1303       subroutine add_task(iproc,ntask_cont,itask_cont)
1304       implicit none
1305       include "DIMENSIONS"
1306       integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1307       integer ii
1308       do ii=1,ntask_cont
1309         if (itask_cont(ii).eq.iproc) return
1310       enddo
1311       ntask_cont=ntask_cont+1
1312       itask_cont(ntask_cont)=iproc
1313       return
1314       end
1315 c---------------------------------------------------------------------------
1316       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1317       implicit real*8 (a-h,o-z)
1318       include 'DIMENSIONS'
1319       include 'mpif.h'
1320       include 'COMMON.SETUP'
1321       integer total_ints,lower_bound,upper_bound
1322       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1323       nint=total_ints/nfgtasks
1324       do i=1,nfgtasks
1325         int4proc(i-1)=nint
1326       enddo
1327       nexcess=total_ints-nint*nfgtasks
1328       do i=1,nexcess
1329         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1330       enddo
1331       lower_bound=0
1332       do i=0,fg_rank-1
1333         lower_bound=lower_bound+int4proc(i)
1334       enddo
1335       upper_bound=lower_bound+int4proc(fg_rank)
1336       lower_bound=lower_bound+1
1337       return
1338       end
1339 c---------------------------------------------------------------------------
1340       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1341       implicit real*8 (a-h,o-z)
1342       include 'DIMENSIONS'
1343       include 'mpif.h'
1344       include 'COMMON.SETUP'
1345       integer total_ints,lower_bound,upper_bound
1346       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1347       nint=total_ints/nfgtasks1
1348       do i=1,nfgtasks1
1349         int4proc(i-1)=nint
1350       enddo
1351       nexcess=total_ints-nint*nfgtasks1
1352       do i=1,nexcess
1353         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1354       enddo
1355       lower_bound=0
1356       do i=0,fg_rank1-1
1357         lower_bound=lower_bound+int4proc(i)
1358       enddo
1359       upper_bound=lower_bound+int4proc(fg_rank1)
1360       lower_bound=lower_bound+1
1361       return
1362       end
1363 c---------------------------------------------------------------------------
1364       subroutine int_partition(int_index,lower_index,upper_index,atom,
1365      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1366       implicit real*8 (a-h,o-z)
1367       include 'DIMENSIONS'
1368       include 'COMMON.IOUNITS'
1369       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1370      & first_atom,last_atom,int_gr,jat_start,jat_end
1371       logical lprn
1372       lprn=.false.
1373       if (lprn) write (iout,*) 'int_index=',int_index
1374       int_index_old=int_index
1375       int_index=int_index+last_atom-first_atom+1
1376       if (lprn)
1377      &   write (iout,*) 'int_index=',int_index,
1378      &               ' int_index_old',int_index_old,
1379      &               ' lower_index=',lower_index,
1380      &               ' upper_index=',upper_index,
1381      &               ' atom=',atom,' first_atom=',first_atom,
1382      &               ' last_atom=',last_atom
1383       if (int_index.ge.lower_index) then
1384         int_gr=int_gr+1
1385         if (at_start.eq.0) then
1386           at_start=atom
1387           jat_start=first_atom-1+lower_index-int_index_old
1388         else
1389           jat_start=first_atom
1390         endif
1391         if (lprn) write (iout,*) 'jat_start',jat_start
1392         if (int_index.ge.upper_index) then
1393           at_end=atom
1394           jat_end=first_atom-1+upper_index-int_index_old
1395           return1
1396         else
1397           jat_end=last_atom
1398         endif
1399         if (lprn) write (iout,*) 'jat_end',jat_end
1400       endif
1401       return
1402       end
1403 #endif
1404 c------------------------------------------------------------------------------
1405       subroutine hpb_partition
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408 #ifdef MPI
1409       include 'mpif.h'
1410 #endif
1411       include 'COMMON.SBRIDGE'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.SETUP'
1414 #ifdef MPI
1415       call int_bounds(nhpb,link_start,link_end)
1416       write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1417      &  ' absolute rank',MyRank,
1418      &  ' nhpb',nhpb,' link_start=',link_start,
1419      &  ' link_end',link_end
1420 #else
1421       link_start=1
1422       link_end=nhpb
1423 #endif
1424       return
1425       end