1 subroutine argos_space_acfbl(ibbl,lhandl,fw,fs,lbbl,jpl, 2 + lpair,iwz,isz) 3c 4 implicit none 5c 6#include "argos_space_common.fh" 7#include "global.fh" 8c 9 integer ibbl,lhandl 10 real*8 fw(mwm,3,mwa,2),fs(msa,3,2) 11 integer lbbl(mbbl,mbb2) 12 integer jpl(mbox,mip2) 13 logical lpair 14 integer iwz(mwm),isz(msa) 15c 16 integer i,j,k,l,m,ibox,jbox,jnode,il,ih,jl,jh,ndx,nwnon,nsnon 17 integer jwfr,jwto,jsfr,jsto 18c 19 if(ibbl.le.0.or.ibbl.gt.nbbl) 20 + call md_abort('Index to lbbl out of range',ibbl) 21c 22 jnode=lbbl(ibbl,1) 23 jbox=lbbl(ibbl,2) 24 ibox=lbbl(ibbl,3) 25 lbbl(ibbl,4)=lhandl 26c 27 if(jnode.eq.me) return 28 if(ibbl.lt.nbbl) then 29 if(lbbl(ibbl+1,1).eq.jnode.and.lbbl(ibbl+1,2).eq.jbox) return 30 endif 31c 32 ndx=0 33 do 3 i=1,jpl(1,1) 34 if(jpl(30+i,1).eq.jbox) ndx=30+i 35 3 continue 36 if(ndx.eq.0) 37 + call md_abort('Remote processor cell not found (2) ',0) 38 jwfr=jpl(ndx,2) 39 jwto=jpl(ndx,3) 40 jsfr=jpl(ndx,4) 41 jsto=jpl(ndx,5) 42 if(jwfr.gt.0) then 43 nwnon=jwto-jwfr+1 44 if(nwmloc+nwnon.gt.mwm) 45 + call md_abort('Dimension mwm too small',nwmloc+nwnon) 46 call ga_distribution(ga_w,jnode,il,ih,jl,jh) 47 call ga_acc(ga_w,il+jwfr-1,il+jwto-1,jl+6*mwa+3,jl+9*mwa+2, 48 + fw(nwmloc+1,1,1,1),mwm,one) 49 if(llong) call ga_acc(ga_w,il+jwfr-1,il+jwto-1,jl+9*mwa+3, 50 + jl+12*mwa+2,fw(nwmloc+1,1,1,2),mwm,one) 51 if(lpair) then 52 call ga_distribution(ga_iwz,jnode,il,ih,jl,jh) 53 call ga_acc(ga_iwz,il+jwfr-1,il+jwto-1,jl,jl,iwz(nwmloc+1),mwm,1) 54 endif 55 endif 56 if(jsfr.gt.0) then 57 nsnon=jsto-jsfr+1 58 if(nsaloc+nsnon.gt.msa) 59 + call md_abort('Dimension msa too small (5)',nsaloc+nsnon) 60 call ga_distribution(ga_s,jnode,il,ih,jl,jh) 61 call ga_acc(ga_s,il+jsfr-1,il+jsto-1,jl+6,jl+8, 62 + fs(nsaloc+1,1,1),msa,one) 63 if(llong) call ga_acc(ga_s,il+jsfr-1,il+jsto-1,jl+9,jl+11, 64 + fs(nsaloc+1,1,2),msa,one) 65 if(lpair) then 66 call ga_distribution(ga_isz,jnode,il,ih,jl,jh) 67 call ga_acc(ga_isz,il+jsfr-1,il+jsto-1,jl,jl,isz(nsaloc+1),msa,1) 68 endif 69 endif 70c 71 m=1 72 if(llong) m=2 73c 74 do 9 l=1,m 75 do 4 k=1,mwa 76 do 5 j=1,3 77 do 6 i=nwmloc+1,mwm 78 fw(i,j,k,l)=zero 79 6 continue 80 5 continue 81 4 continue 82c 83 do 7 j=1,3 84 do 8 i=nsaloc+1,msa 85 fs(i,j,l)=zero 86 8 continue 87 7 continue 88 9 continue 89c 90 do 10 i=nwmloc+1,mwm 91 iwz(i)=0 92 10 continue 93 do 11 i=nsaloc+1,msa 94 isz(i)=0 95 11 continue 96c 97 return 98 end 99c $Id$ 100