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       if (ntheta_constr.eq.0) then
 633         ithetaconstr_start=1
 634         ithetaconstr_end=0
 635       else
 636         call int_bounds
 637      &  (ntheta_constr,ithetaconstr_start,ithetaconstr_end)
 638       endif
 639 C        print *,ntheta_constr,ithetaconstr_start,ithetaconstr_end
 640 c      nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 641 c      nlen=nres-nnt+1
 642       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 643       nlen=nres-nnt+1
 644       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 645       igrad_start=((2*nlen+1)
 646      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 647       jgrad_start(igrad_start)=
 648      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 649      &    +igrad_start
 650       jgrad_end(igrad_start)=nres
 651       igrad_end=((2*nlen+1)
 652      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 653       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 654       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 655      &    +igrad_end
 656       do i=igrad_start+1,igrad_end-1
 657         jgrad_start(i)=i+1
 658         jgrad_end(i)=nres
 659       enddo
 660       if (lprint) then
 661         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 662      & ' absolute rank',myrank,
 663      & ' loc_start',loc_start,' loc_end',loc_end,
 664      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 665      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 666      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 667      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 668      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 669      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 670      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 671      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 672      & ' iset_start',iset_start,' iset_end',iset_end,
 673      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 674      &   idihconstr_end,
 675      & ' ithetaconstr_start',ithetaconstr_start,' ithetaconstr_end',
 676      &   ithetaconstr_end
 677
 678        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 679      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 680      &   ' ngrad_end',ngrad_end
 681        do i=igrad_start,igrad_end
 682          write(*,*) 'Processor:',fg_rank,myrank,i,
 683      &    jgrad_start(i),jgrad_end(i)
 684        enddo
 685       endif
 686       if (nfgtasks.gt.1) then
 687         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 688      &    MPI_INTEGER,FG_COMM1,IERROR)
 689         iaux=ivec_end-ivec_start+1
 690         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 691      &    MPI_INTEGER,FG_COMM1,IERROR)
 692         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 693      &    MPI_INTEGER,FG_COMM,IERROR)
 694         iaux=iset_end-iset_start+1
 695         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 696      &    MPI_INTEGER,FG_COMM,IERROR)
 697         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 698      &    MPI_INTEGER,FG_COMM,IERROR)
 699         iaux=ibond_end-ibond_start+1
 700         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 701      &    MPI_INTEGER,FG_COMM,IERROR)
 702         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 703      &    MPI_INTEGER,FG_COMM,IERROR)
 704         iaux=ithet_end-ithet_start+1
 705         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 706      &    MPI_INTEGER,FG_COMM,IERROR)
 707         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 708      &    MPI_INTEGER,FG_COMM,IERROR)
 709         iaux=iphi_end-iphi_start+1
 710         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 711      &    MPI_INTEGER,FG_COMM,IERROR)
 712         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 713      &    MPI_INTEGER,FG_COMM,IERROR)
 714         iaux=iphi1_end-iphi1_start+1
 715         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 716      &    MPI_INTEGER,FG_COMM,IERROR)
 717         do i=0,maxprocs-1
 718           do j=1,maxres
 719             ielstart_all(j,i)=0
 720             ielend_all(j,i)=0
 721           enddo
 722         enddo
 723         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 724      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 725         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 726      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 727         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 728      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 729         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 730      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 731         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 732      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 733         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 734      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 735         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 736      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 737         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 738      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 739         if (lprint) then
 740         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 741         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 742         write (iout,*) "iturn3_start_all",
 743      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 744         write (iout,*) "iturn3_end_all",
 745      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 746         write (iout,*) "iturn4_start_all",
 747      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 748         write (iout,*) "iturn4_end_all",
 749      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 750         write (iout,*) "The ielstart_all array"
 751         do i=nnt,nct
 752           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 753         enddo
 754         write (iout,*) "The ielend_all array"
 755         do i=nnt,nct
 756           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 757         enddo
 758         call flush(iout)
 759         endif
 760         ntask_cont_from=0
 761         ntask_cont_to=0
 762         itask_cont_from(0)=fg_rank
 763         itask_cont_to(0)=fg_rank
 764         flag=.false.
 765         do ii=iturn3_start,iturn3_end
 766           call add_int(ii,ii+2,iturn3_sent(1,ii),
 767      &                 ntask_cont_to,itask_cont_to,flag)
 768         enddo
 769         do ii=iturn4_start,iturn4_end
 770           call add_int(ii,ii+3,iturn4_sent(1,ii),
 771      &                 ntask_cont_to,itask_cont_to,flag)
 772         enddo
 773         do ii=iturn3_start,iturn3_end
 774           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 775         enddo
 776         do ii=iturn4_start,iturn4_end
 777           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 778         enddo
 779         if (lprint) then
 780         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 781      &   " ntask_cont_to",ntask_cont_to
 782         write (iout,*) "itask_cont_from",
 783      &    (itask_cont_from(i),i=1,ntask_cont_from)
 784         write (iout,*) "itask_cont_to",
 785      &    (itask_cont_to(i),i=1,ntask_cont_to)
 786         call flush(iout)
 787         endif
 788 c        write (iout,*) "Loop forward"
 789 c        call flush(iout)
 790         do i=iatel_s,iatel_e
 791 c          write (iout,*) "from loop i=",i
 792 c          call flush(iout)
 793           do j=ielstart(i),ielend(i)
 794             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 795           enddo
 796         enddo
 797 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 798 c     &     " iatel_e",iatel_e
 799 c        call flush(iout)
 800         nat_sent=0
 801         do i=iatel_s,iatel_e
 802 c          write (iout,*) "i",i," ielstart",ielstart(i),
 803 c     &      " ielend",ielend(i)
 804 c          call flush(iout)
 805           flag=.false.
 806           do j=ielstart(i),ielend(i)
 807             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 808      &                   itask_cont_to,flag)
 809           enddo
 810           if (flag) then
 811             nat_sent=nat_sent+1
 812             iat_sent(nat_sent)=i
 813           endif
 814         enddo
 815         if (lprint) then
 816         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 817      &   " ntask_cont_to",ntask_cont_to
 818         write (iout,*) "itask_cont_from",
 819      &    (itask_cont_from(i),i=1,ntask_cont_from)
 820         write (iout,*) "itask_cont_to",
 821      &    (itask_cont_to(i),i=1,ntask_cont_to)
 822         call flush(iout)
 823         write (iout,*) "iint_sent"
 824         do i=1,nat_sent
 825           ii=iat_sent(i)
 826           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 827      &      j=ielstart(ii),ielend(ii))
 828         enddo
 829         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 830      &    " iturn3_end",iturn3_end
 831         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 832      &      i=iturn3_start,iturn3_end)
 833         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 834      &    " iturn4_end",iturn4_end
 835         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 836      &      i=iturn4_start,iturn4_end)
 837         call flush(iout)
 838         endif
 839         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 840      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 841 c        write (iout,*) "Gather ntask_cont_from ended"
 842 c        call flush(iout)
 843         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 844      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 845      &   FG_COMM,IERR)
 846 c        write (iout,*) "Gather itask_cont_from ended"
 847 c        call flush(iout)
 848         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 849      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 850 c        write (iout,*) "Gather ntask_cont_to ended"
 851 c        call flush(iout)
 852         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 853      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 854 c        write (iout,*) "Gather itask_cont_to ended"
 855 c        call flush(iout)
 856         if (fg_rank.eq.king) then
 857           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 858           do i=0,nfgtasks-1
 859             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 860      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 861           enddo
 862           write (iout,*)
 863           call flush(iout)
 864           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 865           do i=0,nfgtasks-1
 866             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 867      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 868           enddo
 869           write (iout,*)
 870           call flush(iout)
 871 C Check if every send will have a matching receive
 872           ncheck_to=0
 873           ncheck_from=0
 874           do i=0,nfgtasks-1
 875             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 876             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 877           enddo
 878           write (iout,*) "Control sums",ncheck_from,ncheck_to
 879           if (ncheck_from.ne.ncheck_to) then
 880             write (iout,*) "Error: #receive differs from #send."
 881             write (iout,*) "Terminating program...!"
 882             call flush(iout)
 883             flag=.false.
 884           else
 885             flag=.true.
 886             do i=0,nfgtasks-1
 887               do j=1,ntask_cont_to_all(i)
 888                 ii=itask_cont_to_all(j,i)
 889                 do k=1,ntask_cont_from_all(ii)
 890                   if (itask_cont_from_all(k,ii).eq.i) then
 891                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 892                     exit
 893                   endif
 894                 enddo
 895                 if (k.eq.ntask_cont_from_all(ii)+1) then
 896                   flag=.false.
 897                   write (iout,*) "Error: send by",j," to",ii,
 898      &            " would have no matching receive"
 899                 endif
 900               enddo
 901             enddo
 902           endif
 903           if (.not.flag) then
 904             write (iout,*) "Unmatched sends; terminating program"
 905             call flush(iout)
 906           endif
 907         endif
 908         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 909 c        write (iout,*) "flag broadcast ended flag=",flag
 910 c        call flush(iout)
 911         if (.not.flag) then
 912           call MPI_Finalize(IERROR)
 913           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 914         endif
 915         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 916 c        write (iout,*) "MPI_Comm_group ended"
 917 c        call flush(iout)
 918         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 919      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 920         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 921      &    CONT_TO_GROUP,IERR)
 922         do i=1,nat_sent
 923           ii=iat_sent(i)
 924           iaux=4*(ielend(ii)-ielstart(ii)+1)
 925           call MPI_Group_translate_ranks(fg_group,iaux,
 926      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 927      &      iint_sent_local(1,ielstart(ii),i),IERR )
 928 c          write (iout,*) "Ranks translated i=",i
 929 c          call flush(iout)
 930         enddo
 931         iaux=4*(iturn3_end-iturn3_start+1)
 932         call MPI_Group_translate_ranks(fg_group,iaux,
 933      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 934      &      iturn3_sent_local(1,iturn3_start),IERR)
 935         iaux=4*(iturn4_end-iturn4_start+1)
 936         call MPI_Group_translate_ranks(fg_group,iaux,
 937      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 938      &      iturn4_sent_local(1,iturn4_start),IERR)
 939         if (lprint) then
 940         write (iout,*) "iint_sent_local"
 941         do i=1,nat_sent
 942           ii=iat_sent(i)
 943           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 944      &      j=ielstart(ii),ielend(ii))
 945           call flush(iout)
 946         enddo
 947         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 948      &    " iturn3_end",iturn3_end
 949         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 950      &      i=iturn3_start,iturn3_end)
 951         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 952      &    " iturn4_end",iturn4_end
 953         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 954      &      i=iturn4_start,iturn4_end)
 955         call flush(iout)
 956         endif
 957         call MPI_Group_free(fg_group,ierr)
 958         call MPI_Group_free(cont_from_group,ierr)
 959         call MPI_Group_free(cont_to_group,ierr)
 960         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 961         call MPI_Type_commit(MPI_UYZ,IERROR)
 962         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 963      &    IERROR)
 964         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 965         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 966         call MPI_Type_commit(MPI_MU,IERROR)
 967         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 968         call MPI_Type_commit(MPI_MAT1,IERROR)
 969         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 970         call MPI_Type_commit(MPI_MAT2,IERROR)
 971         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 972         call MPI_Type_commit(MPI_THET,IERROR)
 973         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 974         call MPI_Type_commit(MPI_GAM,IERROR)
 975 #ifndef MATGATHER
 976 c 9/22/08 Derived types to send matrices which appear in correlation terms
 977         do i=0,nfgtasks-1
 978           if (ivec_count(i).eq.ivec_count(0)) then
 979             lentyp(i)=0
 980           else
 981             lentyp(i)=1
 982           endif
 983         enddo
 984         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 985         if (ind_typ.eq.0) then
 986           ichunk=ivec_count(0)
 987         else
 988           ichunk=ivec_count(1)
 989         endif
 990 c        do i=1,4
 991 c          blocklengths(i)=4
 992 c        enddo
 993 c        displs(1)=0
 994 c        do i=2,4
 995 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 996 c        enddo
 997 c        do i=1,4
 998 c          blocklengths(i)=blocklengths(i)*ichunk
 999 c        enddo
1000 c        write (iout,*) "blocklengths and displs"
1001 c        do i=1,4
1002 c          write (iout,*) i,blocklengths(i),displs(i)
1003 c        enddo
1004 c        call flush(iout)
1005 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
1006 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
1007 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
1008 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
1009 c        do i=1,4
1010 c          blocklengths(i)=2
1011 c        enddo
1012 c        displs(1)=0
1013 c        do i=2,4
1014 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1015 c        enddo
1016 c        do i=1,4
1017 c          blocklengths(i)=blocklengths(i)*ichunk
1018 c        enddo
1019 c        write (iout,*) "blocklengths and displs"
1020 c        do i=1,4
1021 c          write (iout,*) i,blocklengths(i),displs(i)
1022 c        enddo
1023 c        call flush(iout)
1024 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
1025 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
1026 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
1027 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
1028         do i=1,8
1029           blocklengths(i)=2
1030         enddo
1031         displs(1)=0
1032         do i=2,8
1033           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1034         enddo
1035         do i=1,15
1036           blocklengths(i)=blocklengths(i)*ichunk
1037         enddo
1038         call MPI_Type_indexed(8,blocklengths,displs,
1039      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
1040         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1041         do i=1,8
1042           blocklengths(i)=4
1043         enddo
1044         displs(1)=0
1045         do i=2,8
1046           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1047         enddo
1048         do i=1,15
1049           blocklengths(i)=blocklengths(i)*ichunk
1050         enddo
1051         call MPI_Type_indexed(8,blocklengths,displs,
1052      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1053         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1054         do i=1,6
1055           blocklengths(i)=4
1056         enddo
1057         displs(1)=0
1058         do i=2,6
1059           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1060         enddo
1061         do i=1,6
1062           blocklengths(i)=blocklengths(i)*ichunk
1063         enddo
1064         call MPI_Type_indexed(6,blocklengths,displs,
1065      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1066         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1067         do i=1,2
1068           blocklengths(i)=8
1069         enddo
1070         displs(1)=0
1071         do i=2,2
1072           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1073         enddo
1074         do i=1,2
1075           blocklengths(i)=blocklengths(i)*ichunk
1076         enddo
1077         call MPI_Type_indexed(2,blocklengths,displs,
1078      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1079         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1080         do i=1,4
1081           blocklengths(i)=1
1082         enddo
1083         displs(1)=0
1084         do i=2,4
1085           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1086         enddo
1087         do i=1,4
1088           blocklengths(i)=blocklengths(i)*ichunk
1089         enddo
1090         call MPI_Type_indexed(4,blocklengths,displs,
1091      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1092         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1093         enddo
1094 #endif
1095       endif
1096       iint_start=ivec_start+1
1097       iint_end=ivec_end+1
1098       do i=0,nfgtasks-1
1099           iint_count(i)=ivec_count(i)
1100           iint_displ(i)=ivec_displ(i)
1101           ivec_displ(i)=ivec_displ(i)-1
1102           iset_displ(i)=iset_displ(i)-1
1103           ithet_displ(i)=ithet_displ(i)-1
1104           iphi_displ(i)=iphi_displ(i)-1
1105           iphi1_displ(i)=iphi1_displ(i)-1
1106           ibond_displ(i)=ibond_displ(i)-1
1107       enddo
1108       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1109      &     .and. (me.eq.0 .or. .not. out1file)) then
1110         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1111         do i=0,nfgtasks-1
1112           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1113      &      iset_count(i)
1114         enddo
1115         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1116      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1117         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1118         do i=0,nfgtasks-1
1119           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1120      &      iphi1_displ(i)
1121         enddo
1122         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1123      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1124      & ' SC-p interactions','were distributed among',nfgtasks,
1125      & ' fine-grain processors.'
1126       endif
1127 #else
1128       loc_start=2
1129       loc_end=nres-1
1130       ithet_start=3
1131       ithet_end=nres
1132       iturn3_start=nnt
1133       iturn3_end=nct-3
1134       iturn4_start=nnt
1135       iturn4_end=nct-4
1136       iphi_start=nnt+3
1137       iphi_end=nct
1138       iphi1_start=4
1139       iphi1_end=nres
1140       idihconstr_start=1
1141       idihconstr_end=ndih_constr
1142       ithetaconstr_start=1
1143       ithetaconstr_end=ntheta_constr
1144       iphid_start=iphi_start
1145       iphid_end=iphi_end-1
1146       itau_start=4
1147       itau_end=nres
1148       ibond_start=2
1149       ibond_end=nres-1
1150       ibondp_start=nnt
1151       ibondp_end=nct-1
1152       ivec_start=1
1153       ivec_end=nres-1
1154       iset_start=3
1155       iset_end=nres+1
1156       iint_start=2
1157       iint_end=nres-1
1158 #endif
1159       return
1160       end
1161 #ifdef MPI
1162 c---------------------------------------------------------------------------
1163       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1164       implicit none
1165       include "DIMENSIONS"
1166       include "COMMON.INTERACT"
1167       include "COMMON.SETUP"
1168       include "COMMON.IOUNITS"
1169       integer ii,jj,itask(4),ntask_cont_to,
1170      &itask_cont_to(0:max_fg_procs-1)
1171       logical flag
1172       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1173      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1174       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1175      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1176      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1177      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1178      & ielend_all(maxres,0:max_fg_procs-1)
1179       integer iproc,isent,k,l
1180 c Determines whether to send interaction ii,jj to other processors; a given
1181 c interaction can be sent to at most 2 processors.
1182 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1183 c one processor, otherwise flag is unchanged from the input value.
1184       isent=0
1185       itask(1)=fg_rank
1186       itask(2)=fg_rank
1187       itask(3)=fg_rank
1188       itask(4)=fg_rank
1189 c      write (iout,*) "ii",ii," jj",jj
1190 c Loop over processors to check if anybody could need interaction ii,jj
1191       do iproc=0,fg_rank-1
1192 c Check if the interaction matches any turn3 at iproc
1193         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1194           l=k+2
1195           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1196      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1197      &    then
1198 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1199 c            call flush(iout)
1200             flag=.true.
1201             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1202      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1203               isent=isent+1
1204               itask(isent)=iproc
1205               call add_task(iproc,ntask_cont_to,itask_cont_to)
1206             endif
1207           endif
1208         enddo
1209 C Check if the interaction matches any turn4 at iproc
1210         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1211           l=k+3
1212           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1213      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1214      &    then
1215 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1216 c            call flush(iout)
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         enddo
1226         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1227      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1228           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1229      &        ielend_all(ii-1,iproc).ge.jj-1) then
1230             flag=.true.
1231             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1232      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1233               isent=isent+1
1234               itask(isent)=iproc
1235               call add_task(iproc,ntask_cont_to,itask_cont_to)
1236             endif
1237           endif
1238           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1239      &        ielend_all(ii-1,iproc).ge.jj+1) then
1240             flag=.true.
1241             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1242      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1243               isent=isent+1
1244               itask(isent)=iproc
1245               call add_task(iproc,ntask_cont_to,itask_cont_to)
1246             endif
1247           endif
1248         endif
1249       enddo
1250       return
1251       end
1252 c---------------------------------------------------------------------------
1253       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1254       implicit none
1255       include "DIMENSIONS"
1256       include "COMMON.INTERACT"
1257       include "COMMON.SETUP"
1258       include "COMMON.IOUNITS"
1259       integer ii,jj,itask(2),ntask_cont_from,
1260      & itask_cont_from(0:max_fg_procs-1)
1261       logical flag
1262       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1263      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1264       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1265      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1266      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1267      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1268      & ielend_all(maxres,0:max_fg_procs-1)
1269       integer iproc,k,l
1270       do iproc=fg_rank+1,nfgtasks-1
1271         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1272           l=k+2
1273           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1274      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1275      &    then
1276 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1277             call add_task(iproc,ntask_cont_from,itask_cont_from)
1278           endif
1279         enddo
1280         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1281           l=k+3
1282           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1283      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1284      &    then
1285 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1286             call add_task(iproc,ntask_cont_from,itask_cont_from)
1287           endif
1288         enddo
1289         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1290           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1291      &    then
1292             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1293      &          jj+1.le.ielend_all(ii+1,iproc)) then
1294               call add_task(iproc,ntask_cont_from,itask_cont_from)
1295             endif
1296             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1297      &          jj-1.le.ielend_all(ii+1,iproc)) then
1298               call add_task(iproc,ntask_cont_from,itask_cont_from)
1299             endif
1300           endif
1301           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1302      &    then
1303             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1304      &          jj-1.le.ielend_all(ii-1,iproc)) then
1305               call add_task(iproc,ntask_cont_from,itask_cont_from)
1306             endif
1307             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1308      &          jj+1.le.ielend_all(ii-1,iproc)) then
1309                call add_task(iproc,ntask_cont_from,itask_cont_from)
1310             endif
1311           endif
1312         endif
1313       enddo
1314       return
1315       end
1316 c---------------------------------------------------------------------------
1317       subroutine add_task(iproc,ntask_cont,itask_cont)
1318       implicit none
1319       include "DIMENSIONS"
1320       integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1321       integer ii
1322       do ii=1,ntask_cont
1323         if (itask_cont(ii).eq.iproc) return
1324       enddo
1325       ntask_cont=ntask_cont+1
1326       itask_cont(ntask_cont)=iproc
1327       return
1328       end
1329 c---------------------------------------------------------------------------
1330       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1331       implicit real*8 (a-h,o-z)
1332       include 'DIMENSIONS'
1333       include 'mpif.h'
1334       include 'COMMON.SETUP'
1335       integer total_ints,lower_bound,upper_bound
1336       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1337       nint=total_ints/nfgtasks
1338       do i=1,nfgtasks
1339         int4proc(i-1)=nint
1340       enddo
1341       nexcess=total_ints-nint*nfgtasks
1342       do i=1,nexcess
1343         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1344       enddo
1345       lower_bound=0
1346       do i=0,fg_rank-1
1347         lower_bound=lower_bound+int4proc(i)
1348       enddo
1349       upper_bound=lower_bound+int4proc(fg_rank)
1350       lower_bound=lower_bound+1
1351       return
1352       end
1353 c---------------------------------------------------------------------------
1354       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1355       implicit real*8 (a-h,o-z)
1356       include 'DIMENSIONS'
1357       include 'mpif.h'
1358       include 'COMMON.SETUP'
1359       integer total_ints,lower_bound,upper_bound
1360       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1361       nint=total_ints/nfgtasks1
1362       do i=1,nfgtasks1
1363         int4proc(i-1)=nint
1364       enddo
1365       nexcess=total_ints-nint*nfgtasks1
1366       do i=1,nexcess
1367         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1368       enddo
1369       lower_bound=0
1370       do i=0,fg_rank1-1
1371         lower_bound=lower_bound+int4proc(i)
1372       enddo
1373       upper_bound=lower_bound+int4proc(fg_rank1)
1374       lower_bound=lower_bound+1
1375       return
1376       end
1377 c---------------------------------------------------------------------------
1378       subroutine int_partition(int_index,lower_index,upper_index,atom,
1379      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1380       implicit real*8 (a-h,o-z)
1381       include 'DIMENSIONS'
1382       include 'COMMON.IOUNITS'
1383       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1384      & first_atom,last_atom,int_gr,jat_start,jat_end
1385       logical lprn
1386       lprn=.false.
1387       if (lprn) write (iout,*) 'int_index=',int_index
1388       int_index_old=int_index
1389       int_index=int_index+last_atom-first_atom+1
1390       if (lprn)
1391      &   write (iout,*) 'int_index=',int_index,
1392      &               ' int_index_old',int_index_old,
1393      &               ' lower_index=',lower_index,
1394      &               ' upper_index=',upper_index,
1395      &               ' atom=',atom,' first_atom=',first_atom,
1396      &               ' last_atom=',last_atom
1397       if (int_index.ge.lower_index) then
1398         int_gr=int_gr+1
1399         if (at_start.eq.0) then
1400           at_start=atom
1401           jat_start=first_atom-1+lower_index-int_index_old
1402         else
1403           jat_start=first_atom
1404         endif
1405         if (lprn) write (iout,*) 'jat_start',jat_start
1406         if (int_index.ge.upper_index) then
1407           at_end=atom
1408           jat_end=first_atom-1+upper_index-int_index_old
1409           return1
1410         else
1411           jat_end=last_atom
1412         endif
1413         if (lprn) write (iout,*) 'jat_end',jat_end
1414       endif
1415       return
1416       end
1417 #endif
1418 c------------------------------------------------------------------------------
1419       subroutine hpb_partition
1420       implicit real*8 (a-h,o-z)
1421       include 'DIMENSIONS'
1422 #ifdef MPI
1423       include 'mpif.h'
1424 #endif
1425       include 'COMMON.SBRIDGE'
1426       include 'COMMON.IOUNITS'
1427       include 'COMMON.SETUP'
1428 #ifdef MPI
1429       call int_bounds(nhpb,link_start,link_end)
1430       write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1431      &  ' absolute rank',MyRank,
1432      &  ' nhpb',nhpb,' link_start=',link_start,
1433      &  ' link_end',link_end
1434 #else
1435       link_start=1
1436       link_end=nhpb
1437 #endif
1438       return
1439       end