1 subroutine argos_space_lbbl_ind(lbbl,ipl,jpl) 2c 3 implicit none 4c 5#include "argos_space_common.fh" 6#include "global.fh" 7c 8 integer lbbl(mbbl,mbb2),ipl(mbox,mip2),jpl(mbox,mip2) 9c 10 integer ibbl,jproc,jcell,icell,jcproc,jccell,iccell 11 integer i,j,indx,jndx,il,ih,jl,jh,indexw,indexs,nndexw,nndexs 12 character*80 string 13c 14 jcproc=-1 15 jccell=-1 16 iccell=-1 17 indexw=nwmloc+1 18 indexs=nsaloc+1 19 nndexw=indexw 20 nndexs=indexs 21c 22c if(iand(idebug,16).eq.16) then 23c write(lfndbg,3000) ((lbbl(ibbl,i),i=1,3),ibbl=1,nbbl) 24c 3000 format(3i5) 25c endif 26 do 1 ibbl=1,nbbl 27c 28 jproc=lbbl(ibbl,1) 29 jcell=lbbl(ibbl,2) 30 icell=lbbl(ibbl,3) 31 lbbl(ibbl, 5)=0 32 lbbl(ibbl, 6)=0 33 if(iand(idebug,16).eq.16) then 34 write(lfndbg,222) ibbl,nbbl,jproc,jcell,icell,jccell,iccell 35 222 format(7i5) 36 endif 37 do 234 j=1,3 38 234 continue 39c 40c get indices for icell on the local node 41c 42 if(iccell.ne.icell) then 43 indx=0 44 do 2 i=1,ipl(1,1) 45 if(ipl(30+i,1).eq.icell) indx=30+i 46 2 continue 47 if(indx.eq.0) then 48 do 232 j=1,3 49 232 continue 50 write(*,1000) me,(ipl(30+i,1),i=1,ipl(1,1)) 51 1000 format(/,'Cells on proc',i5,' :',t20,20i5,/,(t20,20i5)) 52 write(string,1001) icell,me 53 1001 format('SP0001: Could not find icell',i5,' on proc',i5) 54 call md_abort(string,0) 55 endif 56 iccell=icell 57 endif 58 lbbl(ibbl, 7)=ipl(indx,2) 59 lbbl(ibbl, 8)=ipl(indx,3) 60 lbbl(ibbl, 9)=ipl(indx,4) 61 lbbl(ibbl,10)=ipl(indx,5) 62c 63c get indices for jcell if on the local node 64c 65 if(jproc.eq.me) then 66c 67 if(jccell.ne.jcell) then 68 jndx=0 69 do 3 i=1,ipl(1,1) 70 if(ipl(30+i,1).eq.jcell) jndx=30+i 71 3 continue 72 if(jndx.eq.0) then 73 write(*,1000) me,(ipl(30+i,1),i=1,ipl(1,1)) 74 write(string,1002) jcell,me 75 1002 format('SP0001: Could not find jcell',i5,' on proc',i5) 76 call md_abort(string,0) 77 endif 78 jccell=jcell 79 endif 80 lbbl(ibbl,11)=ipl(jndx,2) 81 lbbl(ibbl,12)=ipl(jndx,3) 82 lbbl(ibbl,13)=ipl(jndx,4) 83 lbbl(ibbl,14)=ipl(jndx,5) 84c 85c get indices for jcell if on the remote node 86c 87 else 88c 89 if(jproc.ne.jcproc) then 90 call ga_distribution(ga_ip,jproc,il,ih,jl,jh) 91 call ga_get(ga_ip,il,ih,jl,jh,jpl,mbox) 92 jcproc=jproc 93 endif 94c 95 if(jcell.ne.jccell) then 96 jndx=0 97 do 4 i=1,jpl(1,1) 98 if(jpl(30+i,1).eq.jcell) jndx=30+i 99 4 continue 100 if(jndx.eq.0) then 101 if(iand(idebug,16).eq.16) then 102 write(lfndbg,1003) jcell,jproc 103 1003 format('Could not find cell',i5,' on proc',i5, 104 + ' in argos_space_lbbl') 105 write(lfndbg,1004) jproc,(jpl(30+i,1),i=1,jpl(1,1)) 106 1004 format('Cell list obtained from proc',i5,' is',/,(20i5)) 107 call util_flush(lfndbg) 108 endif 109c 110 write(*,1005) jproc,(jpl(30+i,1),i=1,jpl(1,1)) 111 1005 format(/,'Cells on proc',i5,':',t20,20i5,/,(t20,20i5)) 112 write(string,1006) jcell,jproc 113 1006 format('SP0002: Could not find remote jcell',i5,' on proc',i5) 114 call md_abort(string,me) 115 endif 116 jccell=jcell 117c 118 if(nbget.ne.0) then 119 indexw=nndexw 120 indexs=nndexs 121 if(jpl(jndx,2).gt.0) nndexw=indexw+jpl(jndx,3)-jpl(jndx,2)+1 122 if(jpl(jndx,4).gt.0) nndexs=indexs+jpl(jndx,5)-jpl(jndx,4)+1 123 endif 124c 125 endif 126c 127 lbbl(ibbl, 5)=indexw 128 lbbl(ibbl, 6)=indexs 129 lbbl(ibbl,11)=jpl(jndx,2) 130 lbbl(ibbl,12)=jpl(jndx,3) 131 lbbl(ibbl,13)=jpl(jndx,4) 132 lbbl(ibbl,14)=jpl(jndx,5) 133c 134 endif 135c 136 1 continue 137c 138 if(nndexw.gt.mwm) then 139 write(string,1007) mwm,nndexw 140 1007 format('Increase dimension mwm from ',i7,' to ',i7) 141 call md_abort(string,me) 142 endif 143 if(nndexs.gt.msa) then 144 write(string,1008) msa,nndexs 145 1008 format('Increase dimension msa from ',i7,' to ',i7) 146 call md_abort(string,me) 147 endif 148c 149 return 150 end 151c $Id$ 152