2 implicit real*8 (a-h,o-z)
7 & /'pool','chain regrow','multi-bond','phi','theta','side chain',
9 c Conversion from poises to molecular unit and the gas constant
10 data cPoise /2.9361d0/, Rb /0.001986d0/
12 c--------------------------------------------------------------------------
15 C Define constants and zero out tables.
17 implicit real*8 (a-h,o-z)
25 cMS$ATTRIBUTES C :: proc_proc
28 include 'COMMON.IOUNITS'
29 include 'COMMON.CHAIN'
30 include 'COMMON.INTERACT'
32 include 'COMMON.LOCAL'
33 include 'COMMON.TORSION'
34 include 'COMMON.FFIELD'
35 include 'COMMON.SBRIDGE'
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
44 c real*8 text1 /'initial_i'/
63 C The following is just to define auxiliary variables used in angle conversion
102 crc for write_rmsbank1
104 cdr include secondary structure prediction bias
107 C CSA I/O units (separated from others especially for Jooyoung)
118 icsa_bank_reminimized=38
121 crc for ifc error 118
124 C Set default weights of the energy terms.
135 print '(a,$)','Inside initialize'
136 c call memmon_print_usage()
169 athet(j,i,k,kk)=0.0D0
170 bthet(j,i,k,kk)=0.0D0
190 gaussc(l,k,j,i)=0.0D0
211 C Initialize the bridge arrays
230 C Initialize variables used in minimization.
239 C Initialize the variables responsible for the mode of gradient storage.
244 C Initialize constants used to split the energy into long- and short-range
250 nprint_ene=nprint_ene-1
254 c-------------------------------------------------------------------------
256 implicit real*8 (a-h,o-z)
258 include 'COMMON.NAMES'
259 include 'COMMON.FFIELD'
261 &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
262 &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
264 &'C','M','F','I','L','V','W','Y','A','G','T',
265 &'S','Q','N','E','D','H','R','K','P','X'/
266 data potname /'LJ','LJK','BP','GB','GBV'/
268 & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
269 & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
270 & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
271 & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," "/
273 & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
274 & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
275 & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR",
278 data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
281 c---------------------------------------------------------------------------
282 subroutine init_int_table
283 implicit real*8 (a-h,o-z)
287 integer blocklengths(15),displs(15)
289 include 'COMMON.CONTROL'
290 include 'COMMON.SETUP'
291 include 'COMMON.CHAIN'
292 include 'COMMON.INTERACT'
293 include 'COMMON.LOCAL'
294 include 'COMMON.SBRIDGE'
295 include 'COMMON.TORCNSTR'
296 include 'COMMON.IOUNITS'
297 include 'COMMON.DERIV'
298 include 'COMMON.CONTACTS'
299 common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
300 & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
301 & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
302 &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
303 & ielend_all(maxres,0:max_fg_procs-1),
304 & ntask_cont_from_all(0:max_fg_procs-1),
305 & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
306 & ntask_cont_to_all(0:max_fg_procs-1),
307 & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
308 integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
309 logical scheck,lprint,flag
311 integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
312 & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
313 C... Determine the numbers of start and end SC-SC interaction
314 C... to deal with by current processor.
316 itask_cont_from(i)=fg_rank
317 itask_cont_to(i)=fg_rank
321 &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
322 n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
323 call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
325 & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
326 & ' absolute rank',MyRank,
327 & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
328 & ' my_sc_inde',my_sc_inde
348 cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
349 cd & (ihpb(i),jhpb(i),i=1,nss)
354 if (ihpb(ii).eq.i+nres) then
361 cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
365 c write (iout,*) 'jj=i+1'
366 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
367 & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
373 else if (jj.eq.nct) then
375 c write (iout,*) 'jj=nct'
376 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
377 & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
385 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
386 & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
388 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
389 & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
400 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
401 & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
406 ind_scint=ind_scint+nct-i
410 ind_scint_old=ind_scint
419 if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
420 & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
423 write (iout,'(a)') 'Interaction array:'
425 write (iout,'(i3,2(2x,2i3))')
426 & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
431 C Now partition the electrostatic-interaction array
433 nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
434 call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
436 & write (*,*) 'Processor',fg_rank,' CG group',kolor,
437 & ' absolute rank',MyRank,
438 & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
439 & ' my_ele_inde',my_ele_inde
446 call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
447 & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
450 if (iatel_s.eq.0) iatel_s=1
451 nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
452 c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
453 call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
454 c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
455 c & " my_ele_inde_vdw",my_ele_inde_vdw
462 call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
464 & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
466 c write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
467 c & " ielend_vdw",ielend_vdw(i)
469 if (iatel_s_vdw.eq.0) iatel_s_vdw=1
480 do i=iatel_s_vdw,iatel_e_vdw
486 write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
487 & ' absolute rank',MyRank
488 write (iout,*) 'Electrostatic interaction array:'
490 write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
495 C Partition the SC-p interaction array
497 nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
498 call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
499 if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
500 & ' absolute rank',myrank,
501 & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
502 & ' my_scp_inde',my_scp_inde
508 if (i.lt.nnt+iscp) then
509 cd write (iout,*) 'i.le.nnt+iscp'
510 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
511 & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
513 else if (i.gt.nct-iscp) then
514 cd write (iout,*) 'i.gt.nct-iscp'
515 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
516 & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
519 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
520 & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
523 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
524 & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
533 if (i.lt.nnt+iscp) then
535 iscpstart(i,1)=i+iscp
537 elseif (i.gt.nct-iscp) then
545 iscpstart(i,2)=i+iscp
551 write (iout,'(a)') 'SC-p interaction array:'
552 do i=iatscp_s,iatscp_e
553 write (iout,'(i3,2(2x,2i3))')
554 & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
557 C Partition local interactions
559 call int_bounds(nres-2,loc_start,loc_end)
560 loc_start=loc_start+1
562 call int_bounds(nres-2,ithet_start,ithet_end)
563 ithet_start=ithet_start+2
564 ithet_end=ithet_end+2
565 call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
566 iturn3_start=iturn3_start+nnt
567 iphi_start=iturn3_start+2
568 iturn3_end=iturn3_end+nnt
569 iphi_end=iturn3_end+2
570 iturn3_start=iturn3_start-1
571 iturn3_end=iturn3_end-1
572 call int_bounds(nres-3,itau_start,itau_end)
573 itau_start=itau_start+3
575 call int_bounds(nres-3,iphi1_start,iphi1_end)
576 iphi1_start=iphi1_start+3
577 iphi1_end=iphi1_end+3
578 call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
579 iturn4_start=iturn4_start+nnt
580 iphid_start=iturn4_start+2
581 iturn4_end=iturn4_end+nnt
582 iphid_end=iturn4_end+2
583 iturn4_start=iturn4_start-1
584 iturn4_end=iturn4_end-1
585 call int_bounds(nres-2,ibond_start,ibond_end)
586 ibond_start=ibond_start+1
587 ibond_end=ibond_end+1
588 call int_bounds(nct-nnt,ibondp_start,ibondp_end)
589 ibondp_start=ibondp_start+nnt
590 ibondp_end=ibondp_end+nnt
591 call int_bounds1(nres-1,ivec_start,ivec_end)
592 print *,"Processor",myrank,fg_rank,fg_rank1,
593 & " ivec_start",ivec_start," ivec_end",ivec_end
594 iset_start=loc_start+2
596 if (ndih_constr.eq.0) then
600 call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
602 nsumgrad=(nres-nnt)*(nres-nnt+1)/2
604 call int_bounds(nsumgrad,ngrad_start,ngrad_end)
605 igrad_start=((2*nlen+1)
606 & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
607 jgrad_start(igrad_start)=
608 & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
610 jgrad_end(igrad_start)=nres
611 igrad_end=((2*nlen+1)
612 & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
613 if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
614 jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
616 do i=igrad_start+1,igrad_end-1
621 write (*,*) 'Processor:',fg_rank,' CG group',kolor,
622 & ' absolute rank',myrank,
623 & ' loc_start',loc_start,' loc_end',loc_end,
624 & ' ithet_start',ithet_start,' ithet_end',ithet_end,
625 & ' iphi_start',iphi_start,' iphi_end',iphi_end,
626 & ' iphid_start',iphid_start,' iphid_end',iphid_end,
627 & ' ibond_start',ibond_start,' ibond_end',ibond_end,
628 & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
629 & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
630 & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
631 & ' ivec_start',ivec_start,' ivec_end',ivec_end,
632 & ' iset_start',iset_start,' iset_end',iset_end,
633 & ' idihconstr_start',idihconstr_start,' idihconstr_end',
635 write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
636 & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
637 & ' ngrad_end',ngrad_end
638 do i=igrad_start,igrad_end
639 write(*,*) 'Processor:',fg_rank,myrank,i,
640 & jgrad_start(i),jgrad_end(i)
643 if (nfgtasks.gt.1) then
644 call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
645 & MPI_INTEGER,FG_COMM1,IERROR)
646 iaux=ivec_end-ivec_start+1
647 call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
648 & MPI_INTEGER,FG_COMM1,IERROR)
649 call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
650 & MPI_INTEGER,FG_COMM,IERROR)
651 iaux=iset_end-iset_start+1
652 call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
653 & MPI_INTEGER,FG_COMM,IERROR)
654 call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
655 & MPI_INTEGER,FG_COMM,IERROR)
656 iaux=ibond_end-ibond_start+1
657 call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
658 & MPI_INTEGER,FG_COMM,IERROR)
659 call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
660 & MPI_INTEGER,FG_COMM,IERROR)
661 iaux=ithet_end-ithet_start+1
662 call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
663 & MPI_INTEGER,FG_COMM,IERROR)
664 call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
665 & MPI_INTEGER,FG_COMM,IERROR)
666 iaux=iphi_end-iphi_start+1
667 call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
668 & MPI_INTEGER,FG_COMM,IERROR)
669 call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
670 & MPI_INTEGER,FG_COMM,IERROR)
671 iaux=iphi1_end-iphi1_start+1
672 call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
673 & MPI_INTEGER,FG_COMM,IERROR)
680 call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
681 & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
682 call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
683 & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
684 call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
685 & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
686 call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
687 & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
688 call MPI_Allgather(iatel_s,1,MPI_INTEGER,
689 & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
690 call MPI_Allgather(iatel_e,1,MPI_INTEGER,
691 & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
692 call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
693 & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
694 call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
695 & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
697 write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
698 write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
699 write (iout,*) "iturn3_start_all",
700 & (iturn3_start_all(i),i=0,nfgtasks-1)
701 write (iout,*) "iturn3_end_all",
702 & (iturn3_end_all(i),i=0,nfgtasks-1)
703 write (iout,*) "iturn4_start_all",
704 & (iturn4_start_all(i),i=0,nfgtasks-1)
705 write (iout,*) "iturn4_end_all",
706 & (iturn4_end_all(i),i=0,nfgtasks-1)
707 write (iout,*) "The ielstart_all array"
709 write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
711 write (iout,*) "The ielend_all array"
713 write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
719 itask_cont_from(0)=fg_rank
720 itask_cont_to(0)=fg_rank
722 do ii=iturn3_start,iturn3_end
723 call add_int(ii,ii+2,iturn3_sent(1,ii),
724 & ntask_cont_to,itask_cont_to,flag)
726 do ii=iturn4_start,iturn4_end
727 call add_int(ii,ii+3,iturn4_sent(1,ii),
728 & ntask_cont_to,itask_cont_to,flag)
730 do ii=iturn3_start,iturn3_end
731 call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
733 do ii=iturn4_start,iturn4_end
734 call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
737 write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
738 & " ntask_cont_to",ntask_cont_to
739 write (iout,*) "itask_cont_from",
740 & (itask_cont_from(i),i=1,ntask_cont_from)
741 write (iout,*) "itask_cont_to",
742 & (itask_cont_to(i),i=1,ntask_cont_to)
745 c write (iout,*) "Loop forward"
748 c write (iout,*) "from loop i=",i
750 do j=ielstart(i),ielend(i)
751 call add_int_from(i,j,ntask_cont_from,itask_cont_from)
754 c write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
755 c & " iatel_e",iatel_e
759 c write (iout,*) "i",i," ielstart",ielstart(i),
760 c & " ielend",ielend(i)
763 do j=ielstart(i),ielend(i)
764 call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
765 & itask_cont_to,flag)
773 write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
774 & " ntask_cont_to",ntask_cont_to
775 write (iout,*) "itask_cont_from",
776 & (itask_cont_from(i),i=1,ntask_cont_from)
777 write (iout,*) "itask_cont_to",
778 & (itask_cont_to(i),i=1,ntask_cont_to)
780 write (iout,*) "iint_sent"
783 write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
784 & j=ielstart(ii),ielend(ii))
786 write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
787 & " iturn3_end",iturn3_end
788 write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
789 & i=iturn3_start,iturn3_end)
790 write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
791 & " iturn4_end",iturn4_end
792 write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
793 & i=iturn4_start,iturn4_end)
796 call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
797 & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
798 c write (iout,*) "Gather ntask_cont_from ended"
800 call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
801 & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
803 c write (iout,*) "Gather itask_cont_from ended"
805 call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
806 & 1,MPI_INTEGER,king,FG_COMM,IERR)
807 c write (iout,*) "Gather ntask_cont_to ended"
809 call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
810 & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
811 c write (iout,*) "Gather itask_cont_to ended"
813 if (fg_rank.eq.king) then
814 write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
816 write (iout,'(20i4)') i,ntask_cont_from_all(i),
817 & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
821 write (iout,*) "Contact send task map (proc, #tasks, tasks)"
823 write (iout,'(20i4)') i,ntask_cont_to_all(i),
824 & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
828 C Check if every send will have a matching receive
832 ncheck_to=ncheck_to+ntask_cont_to_all(i)
833 ncheck_from=ncheck_from+ntask_cont_from_all(i)
835 write (iout,*) "Control sums",ncheck_from,ncheck_to
836 if (ncheck_from.ne.ncheck_to) then
837 write (iout,*) "Error: #receive differs from #send."
838 write (iout,*) "Terminating program...!"
844 do j=1,ntask_cont_to_all(i)
845 ii=itask_cont_to_all(j,i)
846 do k=1,ntask_cont_from_all(ii)
847 if (itask_cont_from_all(k,ii).eq.i) then
848 if(lprint)write(iout,*)"Matching send/receive",i,ii
852 if (k.eq.ntask_cont_from_all(ii)+1) then
854 write (iout,*) "Error: send by",j," to",ii,
855 & " would have no matching receive"
861 write (iout,*) "Unmatched sends; terminating program"
865 call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
866 c write (iout,*) "flag broadcast ended flag=",flag
869 call MPI_Finalize(IERROR)
870 stop "Error in INIT_INT_TABLE: unmatched send/receive."
872 call MPI_Comm_group(FG_COMM,fg_group,IERR)
873 c write (iout,*) "MPI_Comm_group ended"
875 call MPI_Group_incl(fg_group,ntask_cont_from+1,
876 & itask_cont_from(0),CONT_FROM_GROUP,IERR)
877 call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
878 & CONT_TO_GROUP,IERR)
881 iaux=4*(ielend(ii)-ielstart(ii)+1)
882 call MPI_Group_translate_ranks(fg_group,iaux,
883 & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
884 & iint_sent_local(1,ielstart(ii),i),IERR )
885 c write (iout,*) "Ranks translated i=",i
888 iaux=4*(iturn3_end-iturn3_start+1)
889 call MPI_Group_translate_ranks(fg_group,iaux,
890 & iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
891 & iturn3_sent_local(1,iturn3_start),IERR)
892 iaux=4*(iturn4_end-iturn4_start+1)
893 call MPI_Group_translate_ranks(fg_group,iaux,
894 & iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
895 & iturn4_sent_local(1,iturn4_start),IERR)
897 write (iout,*) "iint_sent_local"
900 write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
901 & j=ielstart(ii),ielend(ii))
904 write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
905 & " iturn3_end",iturn3_end
906 write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
907 & i=iturn3_start,iturn3_end)
908 write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
909 & " iturn4_end",iturn4_end
910 write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
911 & i=iturn4_start,iturn4_end)
914 call MPI_Group_free(fg_group,ierr)
915 call MPI_Group_free(cont_from_group,ierr)
916 call MPI_Group_free(cont_to_group,ierr)
917 call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
918 call MPI_Type_commit(MPI_UYZ,IERROR)
919 call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
921 call MPI_Type_commit(MPI_UYZGRAD,IERROR)
922 call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
923 call MPI_Type_commit(MPI_MU,IERROR)
924 call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
925 call MPI_Type_commit(MPI_MAT1,IERROR)
926 call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
927 call MPI_Type_commit(MPI_MAT2,IERROR)
928 call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
929 call MPI_Type_commit(MPI_THET,IERROR)
930 call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
931 call MPI_Type_commit(MPI_GAM,IERROR)
933 c 9/22/08 Derived types to send matrices which appear in correlation terms
935 if (ivec_count(i).eq.ivec_count(0)) then
941 do ind_typ=lentyp(0),lentyp(nfgtasks-1)
942 if (ind_typ.eq.0) then
952 c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
955 c blocklengths(i)=blocklengths(i)*ichunk
957 c write (iout,*) "blocklengths and displs"
959 c write (iout,*) i,blocklengths(i),displs(i)
962 c call MPI_Type_indexed(4,blocklengths(1),displs(1),
963 c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
964 c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
965 c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
971 c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
974 c blocklengths(i)=blocklengths(i)*ichunk
976 c write (iout,*) "blocklengths and displs"
978 c write (iout,*) i,blocklengths(i),displs(i)
981 c call MPI_Type_indexed(4,blocklengths(1),displs(1),
982 c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
983 c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
984 c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
990 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
993 blocklengths(i)=blocklengths(i)*ichunk
995 call MPI_Type_indexed(8,blocklengths,displs,
996 & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
997 call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1003 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1006 blocklengths(i)=blocklengths(i)*ichunk
1008 call MPI_Type_indexed(8,blocklengths,displs,
1009 & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1010 call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1016 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1019 blocklengths(i)=blocklengths(i)*ichunk
1021 call MPI_Type_indexed(6,blocklengths,displs,
1022 & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1023 call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1029 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1032 blocklengths(i)=blocklengths(i)*ichunk
1034 call MPI_Type_indexed(2,blocklengths,displs,
1035 & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1036 call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1042 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1045 blocklengths(i)=blocklengths(i)*ichunk
1047 call MPI_Type_indexed(4,blocklengths,displs,
1048 & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1049 call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1053 iint_start=ivec_start+1
1056 iint_count(i)=ivec_count(i)
1057 iint_displ(i)=ivec_displ(i)
1058 ivec_displ(i)=ivec_displ(i)-1
1059 iset_displ(i)=iset_displ(i)-1
1060 ithet_displ(i)=ithet_displ(i)-1
1061 iphi_displ(i)=iphi_displ(i)-1
1062 iphi1_displ(i)=iphi1_displ(i)-1
1063 ibond_displ(i)=ibond_displ(i)-1
1065 if (nfgtasks.gt.1 .and. fg_rank.eq.king
1066 & .and. (me.eq.0 .or. out1file)) then
1067 write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1069 write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1072 write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1073 & " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1074 write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1076 write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1079 write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1080 & nele_int_tot,' electrostatic and ',nscp_int_tot,
1081 & ' SC-p interactions','were distributed among',nfgtasks,
1082 & ' fine-grain processors.'
1098 idihconstr_end=ndih_constr
1099 iphid_start=iphi_start
1100 iphid_end=iphi_end-1
1117 c---------------------------------------------------------------------------
1118 subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1120 include "DIMENSIONS"
1121 include "COMMON.INTERACT"
1122 include "COMMON.SETUP"
1123 include "COMMON.IOUNITS"
1124 integer ii,jj,itask(4),
1125 & ntask_cont_to,itask_cont_to(0:max_fg_procs-1)
1127 integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1128 & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1129 common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1130 & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1131 & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1132 &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1133 & ielend_all(maxres,0:max_fg_procs-1)
1134 integer iproc,isent,k,l
1135 c Determines whether to send interaction ii,jj to other processors; a given
1136 c interaction can be sent to at most 2 processors.
1137 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1138 c one processor, otherwise flag is unchanged from the input value.
1144 c write (iout,*) "ii",ii," jj",jj
1145 c Loop over processors to check if anybody could need interaction ii,jj
1146 do iproc=0,fg_rank-1
1147 c Check if the interaction matches any turn3 at iproc
1148 do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1150 if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1151 & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1153 c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1156 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1157 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1160 call add_task(iproc,ntask_cont_to,itask_cont_to)
1164 C Check if the interaction matches any turn4 at iproc
1165 do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1167 if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1168 & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1170 c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1173 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1174 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1177 call add_task(iproc,ntask_cont_to,itask_cont_to)
1181 if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1182 & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1183 if (ielstart_all(ii-1,iproc).le.jj-1.and.
1184 & ielend_all(ii-1,iproc).ge.jj-1) then
1186 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1187 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1190 call add_task(iproc,ntask_cont_to,itask_cont_to)
1193 if (ielstart_all(ii-1,iproc).le.jj+1.and.
1194 & ielend_all(ii-1,iproc).ge.jj+1) then
1196 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1197 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1200 call add_task(iproc,ntask_cont_to,itask_cont_to)
1207 c---------------------------------------------------------------------------
1208 subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1210 include "DIMENSIONS"
1211 include "COMMON.INTERACT"
1212 include "COMMON.SETUP"
1213 include "COMMON.IOUNITS"
1214 integer ii,jj,itask(2),ntask_cont_from,
1215 & itask_cont_from(0:max_fg_procs-1)
1217 integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1218 & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1219 common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1220 & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1221 & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1222 &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1223 & ielend_all(maxres,0:max_fg_procs-1)
1225 do iproc=fg_rank+1,nfgtasks-1
1226 do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1228 if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1229 & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1231 c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1232 call add_task(iproc,ntask_cont_from,itask_cont_from)
1235 do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1237 if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1238 & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1240 c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1241 call add_task(iproc,ntask_cont_from,itask_cont_from)
1244 if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1245 if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1247 if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1248 & jj+1.le.ielend_all(ii+1,iproc)) then
1249 call add_task(iproc,ntask_cont_from,itask_cont_from)
1251 if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1252 & jj-1.le.ielend_all(ii+1,iproc)) then
1253 call add_task(iproc,ntask_cont_from,itask_cont_from)
1256 if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1258 if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1259 & jj-1.le.ielend_all(ii-1,iproc)) then
1260 call add_task(iproc,ntask_cont_from,itask_cont_from)
1262 if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1263 & jj+1.le.ielend_all(ii-1,iproc)) then
1264 call add_task(iproc,ntask_cont_from,itask_cont_from)
1271 c---------------------------------------------------------------------------
1272 subroutine add_task(iproc,ntask_cont,itask_cont)
1274 include "DIMENSIONS"
1275 integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1278 if (itask_cont(ii).eq.iproc) return
1280 ntask_cont=ntask_cont+1
1281 itask_cont(ntask_cont)=iproc
1284 c---------------------------------------------------------------------------
1285 subroutine int_bounds(total_ints,lower_bound,upper_bound)
1286 implicit real*8 (a-h,o-z)
1287 include 'DIMENSIONS'
1289 include 'COMMON.SETUP'
1290 integer total_ints,lower_bound,upper_bound
1291 integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1292 nint=total_ints/nfgtasks
1296 nexcess=total_ints-nint*nfgtasks
1298 int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1302 lower_bound=lower_bound+int4proc(i)
1304 upper_bound=lower_bound+int4proc(fg_rank)
1305 lower_bound=lower_bound+1
1308 c---------------------------------------------------------------------------
1309 subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1310 implicit real*8 (a-h,o-z)
1311 include 'DIMENSIONS'
1313 include 'COMMON.SETUP'
1314 integer total_ints,lower_bound,upper_bound
1315 integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1316 nint=total_ints/nfgtasks1
1320 nexcess=total_ints-nint*nfgtasks1
1322 int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1326 lower_bound=lower_bound+int4proc(i)
1328 upper_bound=lower_bound+int4proc(fg_rank1)
1329 lower_bound=lower_bound+1
1332 c---------------------------------------------------------------------------
1333 subroutine int_partition(int_index,lower_index,upper_index,atom,
1334 & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1335 implicit real*8 (a-h,o-z)
1336 include 'DIMENSIONS'
1337 include 'COMMON.IOUNITS'
1338 integer int_index,lower_index,upper_index,atom,at_start,at_end,
1339 & first_atom,last_atom,int_gr,jat_start,jat_end
1342 if (lprn) write (iout,*) 'int_index=',int_index
1343 int_index_old=int_index
1344 int_index=int_index+last_atom-first_atom+1
1346 & write (iout,*) 'int_index=',int_index,
1347 & ' int_index_old',int_index_old,
1348 & ' lower_index=',lower_index,
1349 & ' upper_index=',upper_index,
1350 & ' atom=',atom,' first_atom=',first_atom,
1351 & ' last_atom=',last_atom
1352 if (int_index.ge.lower_index) then
1354 if (at_start.eq.0) then
1356 jat_start=first_atom-1+lower_index-int_index_old
1358 jat_start=first_atom
1360 if (lprn) write (iout,*) 'jat_start',jat_start
1361 if (int_index.ge.upper_index) then
1363 jat_end=first_atom-1+upper_index-int_index_old
1368 if (lprn) write (iout,*) 'jat_end',jat_end
1373 c------------------------------------------------------------------------------
1374 subroutine hpb_partition
1375 implicit real*8 (a-h,o-z)
1376 include 'DIMENSIONS'
1380 include 'COMMON.SBRIDGE'
1381 include 'COMMON.IOUNITS'
1382 include 'COMMON.SETUP'
1383 include 'COMMON.CONTROL'
1384 c write(2,*)"hpb_partition: nhpb=",nhpb
1386 call int_bounds(nhpb,link_start,link_end)
1388 & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1389 & ' absolute rank',MyRank,
1390 & ' nhpb',nhpb,' link_start=',link_start,
1391 & ' link_end',link_end
1396 c write(2,*)"hpb_partition: link_start=",nhpb," link_end=",link_end