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