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