c***************************** file: mg1.f ***************************** c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltmg(vx,vy,xm,ym,itnode,ibndry,ja,a,ip,rp,sp,w, + a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),ja(*) double precision + vx(*),vy(*),xm(*),ym(*),w(*),rp(100),a(*) character*80 + sp(100) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy data ibit/0/ c c user specified ip variables c if(ip(6).lt.-5.or.ip(6).gt.5) ip(6)=1 if(ip(7).lt.0.or.ip(7).gt.ip(2)) ip(7)=0 if(ip(8).ne.1) ip(8)=0 ip(10)=max0(1,ip(10)) ip(11)=max0(1,ip(11)) rp(3)=dmax1(rp(3),ceps(ibit)) ip(25)=0 c c storage allocation c if(ip(5).ne.0) then call stor(ip) if(ip(25).ne.0) go to 20 endif c c error flags c if(itnode(3,1).eq.0) then ip(25)=25 go to 20 endif c c array pointers...in the order that they c occur in the w array c iuu=ip(83) iux=ip(84) iuy=ip(85) iu0=ip(86) iudot=ip(87) iu0dot=ip(88) iudl=ip(89) ievr=ip(90) ievl=ip(91) jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) c ivx0=iudot ivy0=iu0dot ium=iudot iuc=iu0 c ntf=ip(1) nvf=ip(2) nbf=ip(4) ispd=ip(8) iprob=ip(6) lenw=ip(20) maxv=ip(22) nproc=ip(49) ibegin=iz iend=lenw c c initialization c if(ip(5).ne.0) then call timer(w(jtime),-2) call hist2(w(jhist),rp,0,0) call updpth(w(jpath),1,1,rp) call pstat1(ntf,nproc,w(jstat),itnode,w(iee),0) call dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) if(ip(25).ne.0) return call gfinit(ip,maxv,w(iuu),w(iee)) rp(21)=rp(1) rp(31)=rp(1) rp(33)=1.0d0 rp(45)=0.0d0 if(ip(6).eq.3.and.ip(9).lt.3) ip(9)=3 if(ip(6).eq.4) ip(9)=8 ip(5)=0 ip(70)=0 else call timer(w(jtime),-1) endif c c call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) call memptr(iequv,nvf,'head',ibegin,iend,iflag) call memptr(ibb,nvf,'head',ibegin,iend,iflag) c if(iabs(iprob).eq.3) then call memptr(idd,nvf,'head',ibegin,iend,iflag) call memptr(ipp,nvf,'head',ibegin,iend,iflag) idl=ibb ihh=ibb igg=ibb ibdupr=ibb ibdlwr=ibb else if(iabs(iprob).eq.2) then call memptr(ibdlwr,nvf,'head',ibegin,iend,iflag) call memptr(ibdupr,nvf,'head',ibegin,iend,iflag) idd=ibb ipp=ibb idl=ibb ihh=ibb igg=ibb isu=ibb ism=ibb else if(iabs(iprob).eq.4) then if(iprob.eq.4) then ii=nvf else nvv=ip(34) ii=nvf+nvv endif call memptr(ipp,nvf,'head',ibegin,iend,iflag) call memptr(idd,ii,'head',ibegin,iend,iflag) call memptr(idl,ii,'head',ibegin,iend,iflag) call memptr(ihh,4*nvf,'head',ibegin,iend,iflag) igg=ibb isu=ibb ism=ibb ibdupr=ibb ibdlwr=ibb else if(iabs(iprob).eq.5) then call memptr(ipp,nvf,'head',ibegin,iend,iflag) call memptr(idl,nvf,'head',ibegin,iend,iflag) call memptr(ihh,4*nvf,'head',ibegin,iend,iflag) call memptr(igg,4*nvf,'head',ibegin,iend,iflag) call memptr(isu,7*nvf,'head',ibegin,iend,iflag) call memptr(ism,7*nvf,'head',ibegin,iend,iflag) idd=ibb call memptr(ibdlwr,nvf,'head',ibegin,iend,iflag) call memptr(ibdupr,nvf,'head',ibegin,iend,iflag) else idd=ibb ipp=ibb idl=ibb ihh=ibb igg=ibb isu=ibb ism=ibb ibdupr=ibb ibdlwr=ibb endif if(iprob.lt.0) then nvdd=ip(71) nvv=ip(34) maxja0=9*nvdd/2 call memptr(iudd,11*nvdd,'head',ibegin,iend,iflag) call memptr(jeq,2*nvdd,'head',ibegin,iend,iflag) call memptr(ja0,maxja0,'head',ibegin,iend,iflag) maxa0s=maxja0 maxa0n=2*maxja0-nvdd if(ispd.eq.1) then call memptr(ia0,maxa0s,'head',ibegin,iend,iflag) else call memptr(ia0,maxa0n,'head',ibegin,iend,iflag) endif if(iprob.eq.-4) then call memptr(ih0,maxa0s,'head',ibegin,iend,iflag) ig0=ia0 isu0=ia0 ism0=ia0 else if(iprob.eq.-5) then call memptr(ih0,maxa0s,'head',ibegin,iend,iflag) call memptr(ig0,maxa0s,'head',ibegin,iend,iflag) call memptr(isu0,maxa0n,'head',ibegin,iend,iflag) call memptr(ism0,maxa0n,'head',ibegin,iend,iflag) else ih0=ia0 ig0=ia0 isu0=ia0 ism0=ia0 endif endif c maxn=2*nvf nvdd=0 if(iprob.lt.0) nvdd=ip(71) if(ispd.eq.1) then if(iabs(iprob).eq.3) then ii=max0(14*nvf,9*nvf+2*maxn+4*nvdd) else if(iabs(iprob).eq.4) then ii=max0(14*nvf,9*nvf+2*maxn+10*nvdd) else if(iabs(iprob).eq.5) then ii=max0(14*nvf,11*nvf+2*maxn+22*nvdd) else ii=max0(14*nvf,8*nvf+2*maxn+4*nvdd) endif else if(iabs(iprob).eq.3) then ii=max0(17*nvf,16*nvf+2*maxn+4*nvdd) else if(iabs(iprob).eq.4) then ii=max0(17*nvf,16*nvf+2*maxn+10*nvdd) else if(iabs(iprob).eq.5) then ii=max0(17*nvf,18*nvf+2*maxn+22*nvdd) else ii=max0(17*nvf,15*nvf+2*maxn+4*nvdd) endif endif call memptr(izz,ii,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 20 endif maxja=ip(18) maxa=ip(19) if(maxja.lt.10*nvf) then ip(25)=20 go to 20 endif if(ispd.eq.1) then if(maxa.lt.8*nvf) then ip(25)=20 go to 20 endif else if(maxa.lt.14*nvf) then ip(25)=20 go to 20 endif endif c c call cedge3(nvf,ntf,nbf,itnode,ibndry,w(ibedge), + w(izz),iflag) if(iflag.ne.0) then ip(25)=iflag go to 20 endif call cequv1(nvf,nbf,ibndry,w(iequv),1) c c continuation options c if(iprob.eq.3) then c call pltmgc(ip,rp,w(iuu),w(iux),w(iuy),w(iudot),w(iu0), + w(iu0dot),w(ium),w(iuc),w(ievr),w(ievl),vx,vy,xm,ym, 1 w(ivx0),w(ivy0),itnode,ibndry,w(ibedge),w(iequv),w(ka), 2 ja,a,w(ihh),w(igg),w(isu),w(ism),w(ibb),w(idd),w(ipp), 3 w(idl),w(izz),w(jtime),w(jhist),w(jpath), 4 w(ibdlwr),w(ibdupr),a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c c time dependent options c else if(iprob.eq.6) then call pltmgp(ip,rp,w(iuu),w(iux),w(iuy),w(iudot),w(iu0), + w(iu0dot),w(ium),w(iuc),w(ievr),w(ievl),vx,vy,xm,ym, 1 w(ivx0),w(ivy0),itnode,ibndry,w(ibedge),w(iequv),w(ka), 2 ja,a,w(ihh),w(igg),w(isu),w(ism),w(ibb),w(idd),w(ipp), 3 w(idl),w(izz),w(jtime),w(jhist),w(jpath), 4 w(ibdlwr),w(ibdupr),a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c c obstacle problem c else if(iprob.eq.1.or.iprob.eq.2) then call pltmgo(ip,rp,w(iuu),w(iux),w(iuy),w(iudot),w(iu0), + w(iu0dot),w(ium),w(iuc),w(ievr),w(ievl),vx,vy,xm,ym, 1 w(ivx0),w(ivy0),itnode,ibndry,w(ibedge),w(iequv),w(ka), 2 ja,a,w(ihh),w(igg),w(isu),w(ism),w(ibb),w(idd),w(ipp), 3 w(idl),w(izz),w(jtime),w(jhist),w(jpath), 4 w(ibdlwr),w(ibdupr),a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c c parameter identification problem c else if(iprob.eq.4.or.iprob.eq.5) then call pltmgi(ip,rp,w(iuu),w(iux),w(iuy),w(iudot),w(iu0), + w(iu0dot),w(ium),w(iuc),w(ievr),w(ievl),vx,vy,xm,ym, 1 w(ivx0),w(ivy0),itnode,ibndry,w(ibedge),w(iequv),w(ka), 2 ja,a,w(ihh),w(igg),w(isu),w(ism),w(ibb),w(idd),w(ipp), 3 w(idl),w(izz),w(jtime),w(jhist),w(jpath), 4 w(ibdlwr),w(ibdupr),a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c c domain decomposition solve c else if(iprob.lt.0) then if(ip(48).ne.1) then ip(25)=48 go to 20 endif call pltmgd(ip,rp,w(iuu),w(iux),w(iuy),w(iudot),w(iu0), + w(iu0dot),w(ium),w(iuc),w(ievr),w(ievl),vx,vy,xm,ym, 1 w(ivx0),w(ivy0),itnode,ibndry,w(ibedge),w(iequv),w(ka), 2 ja,a,w(ihh),w(igg),w(isu),w(ism),w(ibb),w(idd),w(ipp), 3 w(idl),w(izz),w(jtime),w(jhist),w(jpath),w(ibdlwr), 4 w(ibdupr),w(ipath),w(jeq),w(ja0),w(ia0),w(ih0),w(ig0), 5 w(isu0),w(ism0),nvdd,w(iudd),a1xy,a2xy,fxy,gnxy,gdxy, 6 p1xy,p2xy) c*********************************** c do i=1,nvf c w(ievr+i-1)=w(ibb+i-1) c enddo c*********************************** else ip(25)=6 endif c call timer(w(jtime),34) c 20 iflag=ip(25) c c successful return c if(iflag.eq.0) then if(ip(6).lt.0) then write(unit=sp(11),fmt='(a17,i2,a8,i2,a6,i7,a1)') + 'pltmg: ok (iprob=',ip(6),', itask=',ip(9), 1 ', nvg=',ip(39),')' else write(unit=sp(11),fmt='(a17,i2,a8,i2,a6,i6,a1)') + 'pltmg: ok (iprob=',ip(6),', itask=',ip(9), 1 ', nvf=',ip(2),')' endif c c insufficient storage errors, wrong input data structure c else if(iflag.ge.18.and.iflag.le.24) then sp(11)='pltmg: insufficient storage' else if(iflag.eq.25) then sp(11)='pltmg: wrong input data structure' c c convergence errors c else if(iflag.eq.1) then sp(11)='pltmg: zero pivot in matrix factorization' else if(iflag.eq.2) then sp(11)='pltmg: newton method line search failed' else if(iflag.eq.6) then sp(11)='pltmg: illegal problem type' else if(iflag.eq.9) then sp(11)='pltmg: continuation procedure failed' else if(iflag.eq.10) then sp(11)='pltmg: multigraph iteration failed to converge' else if(iflag.eq.11) then if(ip(6).lt.0) then sp(11)='pltmg: newton/dd iteration failed to converge' else sp(11)='pltmg: newton iteration failed to converge' endif else if(iflag.eq.48) then sp(11)='pltmg: mpi is off' else if(iflag.eq.71) then sp(11)='pltmg: no interface unknowns in dd solver' else if(iflag.eq.72) then sp(11)='pltmg: interface arrays not defined' else sp(11)='pltmg: unknown error' endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltmgd(ip,rp,u,ux,uy,udot,u0,u0dot,um,uc,evr,evl, + vx,vy,xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,h,g, 1 su,sm,b,d,p,dl,z,time,hist,path,bdlwr,bdupr,ipath,jequv, 2 ja0,a0,h0,g0,su0,sm0,nn,gf,a1xy,a2xy,fxy,gnxy,gdxy, 3 p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*),ib(10), 1 iequv(*),ka(10,*),ja(*),ipath(4,*),jequv(*),ja0(*) double precision + rp(100),u(*),udot(*),u0(*),u0dot(*),vx(*),vy(*),xm(*), 1 ym(*),vx0(*),vy0(*),a(*),b(*),p(*),z(*),time(3,*),su(*), 2 hist(22,*),path(101,*),ux(*),uy(*),bdlwr(*),bdupr(*), 3 a0(*),gf(nn,*),d(*),t(10),h(*),dl(*),h0(*),um(*),sm(*), 4 uc(*),g(*),g0(*),su0(*),sm0(*),evr(*),evl(*) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy data ibit/0/ c c make sure the system is solved on each domain c ip(6)=iabs(ip(6)) call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d,p,z, 1 time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 -1,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) ip(6)=-ip(6) c c initialize for domain decomposition solve c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=iabs(ip(6)) itask=ip(9) newntf=ip(31) newnvf=ip(32) nvv=ip(34) nvi=ip(36) c nproc=ip(49) irgn=ip(50) nvdd=ip(71) lipath=ip(72) if(nvdd.le.0) then ip(25)=71 return else if(lipath.le.0) then ip(25)=72 return else if(ipath(4,nproc+2).lt.ipath(3,nproc+2)) then ip(25)=72 return else ip(25)=0 endif c c initialize for domain decomposition c rp(52)=1.0d0 rp(56)=1.0d0 rp(57)=1.0d0 rp(54)=0.0d0 c* if(iprob.eq.2) rp(63)=rp(3) c* if(iprob.eq.4) rp(63)=rp(3) c* if(iprob.eq.5) rp(63)=rp(3) c mxdamp=10 ievals=1 itype=0 iconv=0 method=0 ncfact=4 maxlvl=99 maxfil=nvf nblock=1 ib(1)=1 ib(nblock+1)=nvf+1 maxja=ip(18) maxa=ip(19) lenz=17*nvf ispd=ip(8) dtol=rp(6) mxcg=ip(10) mxnwtt=ip(11) lvl=ip(75) eps=ceps(ibit)*1.0d2 epsmg=dmax1(1.0d-4,eps) jnwtt=mxnwtt if(iprob.eq.3) jnwtt=mxnwtt+1 c idu=1 if(iprob.eq.3.or.iprob.eq.4) then idum=idu+nvf iduc=idum elseif(iprob.eq.5) then idum=idu+nvf iduc=idum+nvf else idum=idu iduc=idum endif ir=iduc+nvf img=ir+nvf igm=img+nvf iadu=igm+nvf ihdu=iadu+nvf iadm=ihdu+nvf ismdm=iadm+nvf ismdc=ismdm+nvf isudu=ismdc+nvf isudc=isudu+nvf igdc=isudc+nvf isv=igdc+nvf iin=isv+nvf imk=iadu id1=ihdu id2=iadm m5=4*nvf+1 c cc maxlnk=4*nvf cc call setgr1(ntf,nvf,itnode,ja,a,iequv,maxlnk,kflag) maxja0=9*nvdd/2 call cequv2(nproc,ipath,jequv) call setgr2(irgn,nproc,ntf,nbf,nvv,newnvf,nvi,itnode, + ibndry,ibedge,iequv,ipath,jequv,ja0,maxja0,kflag) if(kflag.ne.0) stop 9011 c if(iprob.eq.3) then if(ip(9).lt.5.or.ip(9).gt.7) ip(9)=7 call ctheta(ip,rp,jflag) if(jflag.ne.0) then ip(25)=9 return endif else if(iprob.eq.4.or.iprob.eq.5) then ip(9)=0 endif call uinit(ip,rp,itnode,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,z(img),iequv,gdxy) if(iprob.eq.2) call bdinit(ip,rp,iequv,u,vx,vy,itnode, + ibndry,bdlwr,bdupr,z(img),1,gdxy) if(iprob.eq.5) call bdinit(ip,rp,iequv,uc,vx,vy,itnode, + ibndry,bdlwr,bdupr,z(img),0,gdxy) if(iprob.eq.4) then t(1)=rp(21) call pl2ip(t,1) rl=t(1)/dfloat(nproc) rmu=rp(3) rllwr=rp(4) rlupr=rp(5) tol=dmax1(1.0d-2*rmu,eps) rr=tol*(rlupr-rllwr) rl=dmax1(rl,rllwr+rr) rl=dmin1(rl,rlupr-rr) rp(21)=rl endif c iqptr=ja(nvf+1)+nvf cc do i=1,nvf cc ja(iqptr+i-1)=i cc enddo c c c linear system c call timer(time,34) call rgnsys(ip,itnode,ibndry,vx,vy,xm,ym,b,d,p,dl, + ja(iqptr),ja,a,h,g,su,sm,ja0,a0,h0,g0,su0,sm0, 1 u,udot,um,uc,z(id1),z(id2),vx0,vy0,u0,u0dot,rp, 2 z(imk),ibedge,iequv,jequv,ipath,bdlwr,bdupr,z(igm), 3 z(iin),1,nn,gf,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) call timer(time,30) c c error estimate for convergence criteria c call cerr(newntf,itnode,vx,vy,u,ux,uy,en,un) t(1)=en**2 t(2)=un**2 call pl2ip(t,2) en=dsqrt(t(1)) un=dsqrt(t(2)) if(un.gt.0.0d0) then rp(59)=en/un else rp(59)=1.0d0 endif c c compute ordering symbolic factorization c cc call timer(time,34) cc call mginit(nvf,ispd,nblock,ib,maxja,ja,maxa,a,ncfact, cc + maxlvl,maxfil,ka,lvl,dtol,method,lenz,z,kflag) cc call timer(time,18) cc ip(73)=ka(7,lvl)-1 cc ip(74)=ka(8,lvl)-1 cc ip(75)=lvl cc if(iprob.eq.4.or.iprob.eq.5) then cc call setgr1(ntf,nvf,itnode,z,z(m5),iequv,maxlnk,kflag) cc call reord(nvf,ja,h,z,z(m5),ja(iqptr),1) cc if(iprob.eq.5) then cc call reord(nvf,ja,g,z,z(m5),ja(iqptr),1) cc call reord(nvf,ja,sm,z,z(m5),ja(iqptr),0) cc call reord(nvf,ja,su,z,z(m5),ja(iqptr),0) cc endif cc endif c c solve equations c do itnum=1,jnwtt c if(itnum.gt.1) then call timer(time,34) call mgilu(ja,a,lvl,ka,z(img)) call timer(time,20) endif do i=1,nvf z(ir+i-1)=b(i) enddo call timer(time,34) call mg(ispd,lvl,mxcg,epsmg,ja,a,z(idu),z(ir), + ka,iequv,reler1,jflag,z(img),hist(1,7)) call timer(time,19) c c block elimination of bordered system c if(iprob.eq.3) then do i=1,nvf z(ir+i-1)=d(i) enddo call timer(time,34) call blk3dd(ip,rp,itnode,vx,vy,z(idu),z(idum),z(ir), + udot,u0dot,p,epsmg,ja,a,ka,iequv, 1 z(img),hist(1,8),nn,gf,ipath,ja0,a0,jequv) call timer(time,29) if(iconv.eq.1) go to 170 if(itnum.gt.mxnwtt) go to 100 else if(iprob.eq.4) then call timer(time,34) call blk4dd(ip,rp,z(idu),z(idum),d,p,dl,epsmg, + ja,a,h,ka,iequv, 1 z(img),hist(1,8),hist(1,9)) call timer(time,32) else if(iprob.eq.5) then call timer(time,34) call blk5(ip,z(idu),z(idum),z(iduc),b,p,dl,epsmg, + ja,a,h,g,su,sm,ka,iequv,z(ir), 1 z(img),hist) call timer(time,26) endif c c line search loop c isw=0 call timer(time,34) call tpickd(ip,rp,u,um,uc,vx,vy,itnode,iequv,ja,a,h,g, + su,sm,b,d,p,dl,z(igm),z(iin),ipath,jequv,ja0,a0,h0, 1 g0,su0,sm0,nn,gf,z(idu),z(idum),z(iduc),z(iadu), 2 z(iadm),z(ihdu),z(ismdm),z(ismdc),z(isudu),z(isudc), 3 z(igdc),bdlwr,bdupr,isw,itnum,z(isv),z(ir),z(img)) call timer(time,31) c c initializization for itnum=1 c if(itnum.eq.1) then bnorm0=rp(53) if(bnorm0.le.0.0d0) bnorm0=eps rp(58)=bnorm0 call hist3(hist(1,11),-1,bnorm0,1.0d0) endif dnew=rp(60) if(dnew.gt.0.0d0) then call hist3(hist(1,11),itnum,rp(53),rp(54)) iconv=icvtst(itnum,-iprob,itask,itype,rp) if(iconv.eq.1) go to 170 ip(25)=2 if(jflag.ne.0) ip(25)=10 go to 130 endif iter=0 70 iter=iter+1 c c linear system c call timer(time,34) call rgnsys(ip,itnode,ibndry,vx,vy,xm,ym,b,d,p,dl, + ja(iqptr),ja,a,h,g,su,sm,ja0,a0,h0,g0,su0,sm0, 1 u,udot,um,uc,z(id1),z(id2),vx0,vy0,u0,u0dot,rp, 2 z(imk),ibedge,iequv,jequv,ipath,bdlwr,bdupr,z(igm), 3 z(iin),0,nn,gf,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) ievals=ievals+1 call timer(time,30) c call tpickd(ip,rp,u,um,uc,vx,vy,itnode,iequv,ja,a,h,g, + su,sm,b,d,p,dl,z(igm),z(iin),ipath,jequv,ja0,a0,h0, 1 g0,su0,sm0,nn,gf,z(idu),z(idum),z(iduc),z(iadu), 2 z(iadm),z(ihdu),z(ismdm),z(ismdc),z(isudu),z(isudc), 3 z(igdc),bdlwr,bdupr,isw,itnum,z(isv),z(ir),z(img)) call timer(time,31) if(isw.ge.0) then if(iter.lt.mxdamp) go to 70 ip(25)=2 return endif c c convergence check c call hist3(hist(1,11),itnum,rp(53),rp(54)) iconv=icvtst(itnum,-iprob,itask,itype,rp) if(iprob.ne.3.and.iconv.eq.1) go to 170 enddo 100 itnum=jnwtt if(iconv.eq.-1) go to 170 ip(25)=11 c c newton iteration failed to converge...reset u, udot, and rp c 130 ip(79)=ievals ip(80)=itnum return c c newton iteration was successful c 170 ip(25)=0 ip(79)=ievals ip(80)=itnum if(iprob.eq.3) then ip(80)=itnum-1 call updpth(path,-1,5,rp) else if(iprob.ne.1) then call updip(path,-1,4,rp,ip) endif c c need lenz > 13*nvf c i1=1 i2=i1+4*nvf i3=i2+4*nvf i4=i3+nvf i5=i4+nvf cc i6=i5+3*nvf call timer(time,34) call recovr(newnvf,newntf,u,ux,uy,vx,vy,itnode, + z(i1),z(i2),iequv,z(i3),z(i4),z(i5)) call timer(time,33) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltmgp(ip,rp,u,ux,uy,udot,u0,u0dot,um,uc,evr,evl, + vx,vy,xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a, 1 h,g,su,sm,b,d,p,dl,z,time,hist,path,bdlwr,bdupr, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 iequv(*),ka(10,*),ja(*) double precision + rp(100),u(*),udot(*),u0(*),u0dot(*),evr(*),evl(*),um(*), 1 vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*),a(*),b(*),p(*), 2 z(*),time(3,*),hist(22,*),path(101,*),ux(*),uy(*),sm(*), 3 bdlwr(*),bdupr(*),h(*),dl(*),uc(*),g(*),su(*) character*80 + iostr,msg external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy save msg data msg/'pltmg: tcur deltat utnorm'/ c c main routine for parabolic problems c itask=ip(9) ntf=ip(1) nvf=ip(2) c call filutl(msg,0) c call uinit(ip,rp,itnode,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,z,iequv,gdxy) c if(itask.eq.9) then tstart=rp(42) tend=rp(43) if(tstart.ge.tend) return mxstep=max0(1,ip(14)) mxfail=5 rp(46)=tstart rp(49)=tend-tstart rp(48)=rp(49)/dfloat(mxstep) tnew=rp(46) ifirst=1 c c compute time step c 60 call dtpick(ntf,nvf,itnode,vx,vy,u,u0,rp,z,itflag,ifirst) c c update solution c if(itflag.ne.-1.and.ifirst.ne.-1) then rp(46)=tnew do i=1,nvf u0(i)=u(i) vx0(i)=vx(i) vy0(i)=vy(i) enddo idsp=0 endif if(ifirst.eq.-1) then rp(46)=tnew rp(42)=tnew rp(43)=tnew endif c c save time history c if(ifirst.eq.1) then if(itflag.le.-3) then call updtm(path,1,itflag,rp) else call updtm(path,0,itflag,rp) endif else if(itflag.eq.-1) then call updtm(path,0,itflag,rp) else call updtm(path,-1,itflag,rp) endif endif write(unit=iostr,fmt='(2i3,3(1x,e12.5))') + ip(25),itflag,rp(46),rp(47),rp(50) call filutl(iostr,0) if(ifirst.eq.-1) return ifirst=0 c c solve equations c 220 idsp=idsp+1 tcur=rp(46) deltat=dmax1(rp(47),rp(48)) rp(21)=tcur+deltat rp(45)=1.0d0/deltat call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) if(ip(25).ne.0) then if(idsp.lt.mxfail) then rp(47)=rp(47)/2.0d0 go to 220 else do i=1,nvf u(i)=u0(i) enddo write(unit=iostr,fmt='(2i3,3(1x,e12.5))') + ip(25),itflag,rp(46),rp(47),rp(50) call filutl(iostr,0) return endif else tnew=rp(46)+rp(47) if(itflag.eq.2.and.idsp.eq.1) ifirst=-1 if(itflag.eq.-4.and.idsp.eq.1) ifirst=-1 go to 60 endif else tcur=rp(46) deltat=dmax1(rp(47),rp(48)) rp(21)=tcur rp(45)=1.0d0/deltat call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) itflag=3 write(unit=iostr,fmt='(2i3,3(1x,e12.5))') + ip(25),itflag,rp(46),rp(47),rp(50) call filutl(iostr,0) call updtm(path,0,3,rp) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltmgc(ip,rp,u,ux,uy,udot,u0,u0dot,um,uc,evr,evl, + vx,vy,xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a, 1 h,g,su,sm,b,d,p,dl,z,time,hist,path,bdlwr,bdupr, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 iequv(*),ka(10,*),ja(*) double precision + rp(100),u(*),udot(*),u0(*),u0dot(*),evr(*),evl(*),sm(*), 1 vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*),a(*),b(*),p(*), 2 z(*),time(3,*),hist(22,*),path(101,*),ux(*),uy(*),su(*), 3 bdlwr(*),bdupr(*),um(*),h(*),dl(*),uc(*),g(*) character*80 + iostr,msg(7) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy save msg data msg(1)/'pltmg: lambda rho lambda dot + rho dot eigenvalue'/ data msg(2)/'pltmg: find limit / bifurcation point'/ data msg(3)/'pltmg: probable limit point'/ data msg(4)/'pltmg: probable regular point'/ data msg(5)/'pltmg: probable bifurcation point'/ data ibit/0/ c c continuation c itask=ip(9) ispd=ip(8) ntf=ip(1) nvf=ip(2) nbf=ip(4) eps=1.0d2*ceps(ibit) c c call filutl(msg(1),0) c istep=0 idsp=0 mxbis=10 mxfail=10 mxstep=10 c igm=1 ipp=igm+nvf iz1=ipp+nvf iz2=iz1+nvf iz3=iz2+nvf c c restore solution c call uinit(ip,rp,itnode,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,z(igm),iequv,gdxy) do i=1,nvf u(i)=u0(i) udot(i)=u0dot(i) enddo do i=1,5 rp(20+i)=rp(30+i) enddo rltrgt=rp(1) rtrgt=rp(2) rp(26)=rp(31) rp(27)=rp(32) c c change itask if things look inconsistant c dd=dabs(rltrgt-rp(21))+dabs(rtrgt-rp(22)) if(dd.eq.0.0d0.and.itask.le.1) itask=7 if(dd.ne.0.0d0.and.itask.ge.5) itask=0 ip(9)=itask c c switch branches at bifurcation point c if(itask.eq.2) then call timer(time,34) call swbrch(nvf,ntf,nbf,itnode,ibndry,iequv,vx,vy,xm,ym, + evl,evr,udot,u,u0dot,z(ipp),z(iz1),z(iz2),z(iz3),z(igm), 1 rp,ibedge,ispd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,0) call timer(time,27) call updpth(path,0,6,rp) do i=1,nvf u0dot(i)=udot(i) enddo rp(33)=rp(23) rp(34)=rp(24) ip(9)=0 ip(80)=0 write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0) return endif c c switch functional and/or parameters c if(itask.ge.3) then call ctheta(ip,rp,iflag) if(iflag.ne.0) then ip(25)=9 return endif call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0) if(ip(25).ne.0) then ip(9)=itask rp(1)=rp(21) rp(2)=rp(22) return else if(itask.le.4) then call updpth(path,1,1,rp) ip(9)=0 else call updpth(path,-1,3,rp) endif go to 40 endif endif c c get set for an arc length continuation step c 10 idsp=0 istep=istep+1 if(istep.gt.mxstep) then ip(25)=9 ip(9)=itask rp(1)=rp(21) rp(2)=rp(22) return endif c c step picker c call timer(time,34) call predct(ip,itnode,ibndry,vx,vy,xm,ym,z(ipp),z(iz1), + z(igm),u0,u0dot,rp,ibedge,idsp,mxfail,iequv, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) call timer(time,23) if(idsp.gt.mxfail) then ip(25)=9 ip(9)=itask rp(1)=rp(21) rp(2)=rp(22) return endif c c solve nonlinear equations c call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0) if(ip(25).ne.0) then ip(9)=itask rp(1)=rp(21) rp(2)=rp(22) return endif sval=rp(25) sval0=rp(35) if(istep.eq.1) then call updpth(path,-1,4,rp) else call updpth(path,0,4,rp) endif if(sval0*sval.ge.0.0d0.or.itask.eq.0) go to 40 c c change in sign in determinent c call filutl(msg(2),0) c c information for testing type of singular point c rqmx=dmax1(dabs(sval),dabs(sval0)) rlsign=rp(23)*rp(33) idsp=0 isw=0 call hist3(hist(1,15),-2,sval,sval0) c do istep=1,mxbis c c bisection/secant step c call bisect(rp,isw,rqup,rqlow) call hist3(hist(1,15),istep,rqup,rqlow) if(isw.eq.-1) go to 30 sigma=rp(71) 20 call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 1,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0) if(ip(25).ne.0) then if(dabs(sigma).eq.dabs(rp(71))) then rp(71)=sigma*(1.0d0-eps) go to 20 else if(dabs(sigma).lt.dabs(rp(71))) then rp(71)=sigma*(1.0d0+eps) go to 20 else rp(1)=rp(31) rp(2)=rp(32) return endif endif enddo 30 ip(9)=0 c c fixup tangent for the case of bifurcation c dnorm=rl2nrm(nvf,udot)*rl2nrm(nvf,evr) if(dnorm.gt.0.0d0) dnorm=1.0d0/dnorm udr=rl2ip(nvf,evr,udot)*dnorm if(dabs(udr).gt.1.0d-1.and.rlsign.lt.0.0d0) then call filutl(msg(3),0) call updpth(path,0,2,rp) else if(dabs(rp(25)).gt.rqmx*1.0d-2) then call filutl(msg(4),0) call updpth(path,0,4,rp) else call filutl(msg(5),0) call updpth(path,0,6,rp) call timer(time,34) call swbrch(nvf,ntf,nbf,itnode,ibndry,iequv,vx,vy,xm,ym, + evl,evr,udot,u,u0dot,z(ipp),z(iz1),z(iz2),z(iz3),z(igm), 1 rp,ibedge,ispd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,1) call timer(time,27) ip(80)=0 write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0) endif c c successful continuation c 40 do i=1,5 rp(30+i)=rp(20+i) enddo do i=1,nvf u0(i)=u(i) u0dot(i)=udot(i) enddo if(idsp.ne.0) go to 10 rp(1)=rp(31) rp(2)=rp(32) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltmgo(ip,rp,u,ux,uy,udot,u0,u0dot,um,uc,evr,evl, + vx,vy,xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a, 1 h,g,su,sm,b,d,p,dl,z,time,hist,path,bdlwr,bdupr, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 iequv(*),ka(10,*),ja(*) double precision + rp(100),u(*),udot(*),u0(*),u0dot(*),evr(*),evl(*),sm(*), 1 vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*),a(*),b(*),p(*), 2 z(*),time(3,*),hist(22,*),path(101,*),ux(*),uy(*),su(*), 3 bdlwr(*),bdupr(*),um(*),h(*),dl(*),uc(*),g(*) character*80 + iostr external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy save isw data isw/1/ c c solve equations c iprob=ip(6) if(iprob.eq.2) then rp(63)=rp(3) if(isw.eq.1) then rp(64)=rp(3) endif endif call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) if(iprob.eq.2.and.ip(25).eq.0) then rp(64)=rp(63) if(isw.eq.1) then call updip(path,1,1,rp,ip) isw=0 else call updip(path,-1,2,rp,ip) endif write(unit=iostr,fmt='(a11,e12.5,3x,a3,e12.5)') + 'pltmg: rho=',rp(22),'mu=',rp(63) call filutl(iostr,0) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltmgi(ip,rp,u,ux,uy,udot,u0,u0dot,um,uc,evr,evl, + vx,vy,xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a, 1 h,g,su,sm,b,d,p,dl,z,time,hist,path,bdlwr,bdupr, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 iequv(*),ka(10,*),ja(*) double precision + rp(100),u(*),udot(*),u0(*),u0dot(*),evr(*),evl(*),sm(*), 1 vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*),a(*),b(*),p(*), 2 z(*),time(3,*),hist(22,*),path(101,*),ux(*),uy(*),su(*), 3 bdlwr(*),bdupr(*),h(*),um(*),dl(*),uc(*),g(*) character*80 + iostr external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy save isw data isw/1/ data ibit/0/ c c solve equations c iprob=ip(6) itask=ip(9) if(iprob.eq.4) then if(itask.eq.8) then rp(21)=rp(1) cc rp(21)=(rp(4)+rp(5))/2.0e0 ip(9)=0 endif rmu=rp(3) rllwr=rp(4) rlupr=rp(5) eps=100.0d0*ceps(ibit) tol=dmax1(1.0d-2*rmu,eps) rr=tol*(rlupr-rllwr) rl=rp(21) rl=dmax1(rl,rllwr+rr) rl=dmin1(rl,rlupr-rr) rp(21)=rl endif rp(63)=rp(3) if(isw.eq.1) then rp(64)=rp(3) endif call nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d, 1 p,z,time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c if(ip(25).eq.0) then rp(64)=rp(63) if(isw.eq.1) then call updip(path,1,1,rp,ip) isw=0 else if(iprob.eq.4.and.itask.eq.8) then call updip(path,-1,3,rp,ip) else call updip(path,-1,2,rp,ip) endif endif if(iprob.eq.4) then write(unit=iostr,fmt='(a11,e12.5,3x,a7,e12.5,3x,a3,e12.5)') + 'pltmg: rho=',rp(22),'lambda=',rp(21),'mu=',rp(63) else write(unit=iostr,fmt='(a11,e12.5,3x,a3,e12.5)') + 'pltmg: rho=',rp(22),'mu=',rp(63) endif call filutl(iostr,0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine nwtt(ip,rp,u,ux,uy,udot,u0,u0dot,evr,evl,vx,vy, + xm,ym,vx0,vy0,itnode,ibndry,ibedge,iequv,ka,ja,a,b,d,p,z, 1 time,hist,bdlwr,bdupr,h,g,su,sm,um,uc,dl, 2 itype,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),ibedge(2,*), 1 iequv(*),ka(10,*),ja(*),ib(10) double precision + u(*),udot(*),u0(*),u0dot(*),evr(*),evl(*),z(*),vx0(*), 1 rp(100),time(3,*),hist(22,*),xm(*),ym(*),vy0(*),a(*), 2 sp(100),vx(*),vy(*),b(*),p(*),d(*),ux(*),uy(*),g(*), 3 bdlwr(*),bdupr(*),dl(*),h(*),um(*),uc(*),sm(*),su(*) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy data ibit/0/ c c approximate newton method c ntf=ip(1) nvf=ip(2) itask=ip(9) iprob=ip(6) eps=1.0d2*ceps(ibit) c rp(52)=1.0d0 rp(56)=1.0d0 rp(57)=1.0d0 if(itype.eq.0) then epsmg=dmax1(1.0d-3,eps) else epsmg=dmax1(1.0d-4,eps) endif mxdamp=20 iconv=0 jflag=0 c method=0 ncfact=4 maxlvl=99 maxfil=nvf nblock=1 ib(1)=1 ib(nblock+1)=nvf+1 maxja=ip(18) maxa=ip(19) lenz=17*nvf ispd=ip(8) mxcg=ip(10) mxnwtt=ip(11) jnwtt=mxnwtt if(iprob.eq.3) jnwtt=mxnwtt+1 dtol=rp(6) c c get pointers c m0=1 jmg=1 if(iprob.eq.3.or.iprob.eq.4) then m1=m0+nvf else if(iprob.eq.5) then m1=m0+2*nvf else m1=1 endif m2=m1+nvf idsav=m0 isav=m1 idu=m2 idum=m0 iduc=m0+nvf m3=m2+nvf m4=m3+nvf m5=m4+nvf m6=m5+nvf m7=m6+nvf m8=m7+nvf img=m3 if(ispd.eq.1) then ns1=m1 ns2=m2 ns3=m3 kmg=m4 else ns1=m4 ns2=m5 ns3=m6 kmg=m7 endif c c save u, udot, and rp c do i=1,100 sp(i)=rp(i) enddo c maxlnk=4*nvf call setgr1(ntf,nvf,itnode,ja,a,iequv,maxlnk,kflag) c iqptr=ja(nvf+1)+nvf call uinit(ip,rp,itnode,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,z(m3),iequv,gdxy) if(iprob.eq.2) call bdinit(ip,rp,iequv,u,vx,vy,itnode, + ibndry,bdlwr,bdupr,z(m3),1,gdxy) if(iprob.eq.5) call bdinit(ip,rp,iequv,uc,vx,vy,itnode, + ibndry,bdlwr,bdupr,z(m3),0,gdxy) c do i=1,nvf ja(iqptr+i-1)=i enddo if(itask.le.1.and.iprob.eq.3) then seqdot=rp(74) sigma=rp(71) if(seqdot.ne.0.0d0) then ss=dsqrt(eps)*sigma/seqdot c* ss=sigma/(seqdot*100.0e0) else ss=dsqrt(eps) endif do j=1,nvf u(j)=u(j)+ss*u0dot(j) enddo endif c c first matrix and right hand side c call timer(time,34) call linsys(ip,itnode,ibndry,vx,vy,xm,ym,b,d,p,dl, + ja(iqptr),ja,a,h,g,su,sm,u,um,uc,z(m3),z(m4),udot, 1 vx0,vy0,u0,u0dot,rp,z(m5),ibedge,iequv,bdlwr,bdupr, 2 z(m6),1,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) call timer(time,22) c*** c c print out matrix and return (for mutigraph testing) c c call mkmtx(nvf,ispd,ja,a,b,ja(iqptr),z(m3)) c ip(25)=77 c if(ip(25).ne.0) return c*** c c error estimate for convergence criteria c call cerr(ntf,itnode,vx,vy,u,ux,uy,en,un) if(un.gt.0.0d0) then rp(59)=en/un else rp(59)=1.0d0 endif ievals=1 c c compute ordering symbolic factorization c call timer(time,34) call mginit(nvf,ispd,nblock,ib,maxja,ja,maxa,a,ncfact, + maxlvl,maxfil,ka,lvl,dtol,method,lenz,z(jmg),kflag) call timer(time,18) if(kflag.ne.0) then ip(25)=kflag return endif ip(73)=ka(7,lvl)-1 ip(74)=ka(8,lvl)-1 ip(75)=lvl c*** c compute eigenvecttors corresponding to spectral radius c cc call cev1(ip,ja,a,ka,evl,evr,rp,iequv,ibndry,z(m1), cc + z(ns1),z(m2),z(ns2),z(kmg),hist) c*** if(iprob.eq.4.or.iprob.eq.5) then call setgr1(ntf,nvf,itnode,z,z(m5),iequv,maxlnk,kflag) call reord(nvf,ja,h,z,z(m5),ja(iqptr),1) if(iprob.eq.5) then call reord(nvf,ja,g,z,z(m5),ja(iqptr),1) call reord(nvf,ja,sm,z,z(m5),ja(iqptr),0) call reord(nvf,ja,su,z,z(m5),ja(iqptr),0) endif endif c c the main loop c do itnum=1,jnwtt c c compute approximate factorization c if(itnum.gt.1) then call timer(time,34) call mgilu(ja,a,lvl,ka,z(img)) call timer(time,20) endif c c compute singular vectors c if(iprob.eq.3) then call timer(time,34) call cev(ip,ja,a,ka,evl,evr,rp,iequv,ibndry,z(m1), + z(ns1),z(m2),z(ns2),z(m3),z(ns3),z(kmg),hist) call timer(time,21) endif c c multi-level solution of newton equations c do j=1,nvf z(isav+j-1)=b(j) enddo call timer(time,34) call mg(ispd,lvl,mxcg,epsmg,ja,a,z(idu),z(isav), + ka,iequv,reler1,jflag,z(img),hist(1,7)) call timer(time,19) c c block elimination of bordered system c if(iprob.eq.3) then do j=1,nvf z(idsav+j-1)=d(j) enddo call timer(time,34) call blk3(ntf,nvf,itnode,vx,vy,rp,z(idu),z(isav), + z(idsav),udot,u0dot,p,z(m3),ispd,lvl,mxcg,epsmg, 1 ja,a,ka,iequv,z(img),hist(1,8)) call timer(time,24) if(iconv.eq.1) go to 170 if(itnum.gt.mxnwtt) go to 100 else if(iprob.eq.4) then call timer(time,34) call blk4(nvf,rp,z(idu),z(idum),d,p,dl,ispd, + lvl,mxcg,epsmg,ja,a,h,ka,iequv, 1 z(img),hist(1,8),hist(1,9)) call timer(time,25) else if(iprob.eq.5) then call timer(time,34) call blk5(ip,z(idu),z(idum),z(iduc),b,p,dl,epsmg, + ja,a,h,g,su,sm,ka,iequv,z(isav), 1 z(img),hist) call timer(time,26) endif c c line search and sufficient decrease loop c isw=0 call timer(time,34) call tpick(ip,rp,itnode,ja,a,h,g,su,sm,b,d,z(idu),u, + z(isav),z(idum),um,z(m7),z(iduc),uc,z(m8),p,dl,z(m3), 1 z(m4),iequv,z(m5),z(m6),vx,vy,isw,bdlwr,bdupr,itnum) call timer(time,28) if(itnum.eq.1) then bnorm0=rp(53) if(bnorm0.eq.0.0d0) bnorm0=eps rp(58)=bnorm0 call hist3(hist(1,11),0,bnorm0,1.0d0) endif dnew=rp(60) cc write(6,*) itnum,dnew,rp(52) if(dnew.gt.0.0d0) then call hist3(hist(1,11),itnum,rp(53),rp(54)) iconv=icvtst(itnum,iprob,itask,itype,rp) if(iconv.eq.1) go to 170 ip(25)=2 if(jflag.ne.0) ip(25)=10 go to 130 endif iter=0 70 iter=iter+1 c call timer(time,34) call linsys(ip,itnode,ibndry,vx,vy,xm,ym,b,d,p,dl, + ja(iqptr),ja,a,h,g,su,sm,u,um,uc,z(m3),z(m4),udot, 1 vx0,vy0,u0,u0dot,rp,z(m5),ibedge,iequv,bdlwr,bdupr, 2 z(m6),0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) ievals=ievals+1 call timer(time,22) call tpick(ip,rp,itnode,ja,a,h,g,su,sm,b,d,z(idu),u, + z(isav),z(idum),um,z(m7),z(iduc),uc,z(m8),p,dl,z(m3), 1 z(m4),iequv,z(m5),z(m6),vx,vy,isw,bdlwr,bdupr,itnum) call timer(time,28) c c test for sufficient decrease c if(isw.ge.0) then if(iter.lt.mxdamp) go to 70 ip(25)=2 if(jflag.ne.0) ip(25)=10 go to 130 endif c c convergence test c call hist3(hist(1,11),itnum,rp(53),rp(54)) iconv=icvtst(itnum,iprob,itask,itype,rp) if(iprob.ne.3.and.iconv.eq.1) go to 170 c enddo 100 itnum=jnwtt if(iconv.eq.-1) go to 170 ip(25)=11 c c newton iteration failed to converge...reset u, udot, and rp c 130 ip(79)=ievals ip(80)=itnum do i=1,100 rp(i)=sp(i) enddo if(iprob.eq.3) then do j=1,nvf udot(j)=u0dot(j) u(j)=u0(j) enddo else if(iprob.eq.6) then do j=1,nvf u(j)=u0(j) enddo endif return c c newton iteration was successful c 170 ip(25)=0 ip(79)=ievals ip(80)=itnum if(iprob.eq.3) ip(80)=itnum-1 c c need lenz > 13*nvf c i1=1 i2=i1+4*nvf i3=i2+4*nvf i4=i3+nvf i5=i4+nvf cc i6=i5+3*nvf call timer(time,34) call recovr(nvf,ntf,u,ux,uy,vx,vy,itnode,z(i1),z(i2),iequv, + z(i3),z(i4),z(i5)) call timer(time,33) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- integer function icvtst(itnum,iprob,itask,itype,rp) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100) save tol,eps,erf,egf,tole,tolr,isw,trf data ibit/0/ c c convergence test for outer newton loop c c icvtst = -1 making progress c icvtst = 0 not converged c icvtst = 1 converged c ii=0 if(iabs(iprob).ne.3.or.itask.ge.5) ii=1 if(iprob.lt.0) ii=1 if(itype.lt.0) ii=2 c if(itnum.le.1) then isw=0 eps=1.0d2*ceps(ibit) tol=eps if(itype.eq.1) tol=dsqrt(tol) trf=0.5d0 erf=1.0d0-eps egf=0.1d0 if(ii.eq.1) then tole=1.0d-1 tolr=1.0d-2 else if(ii.eq.2) then tole=1.0d-2 tolr=1.0d-4 else tole=1.0d-2 tolr=1.0d-4 endif endif c relerr=rp(54) relres=rp(56) ratio=rp(57) reler0=rp(59) c c revise tol if indicated c if(isw.eq.0.and.ii.ge.1.and.relerr.lt.trf) then isw=1 tol=dmax1(relerr*tole,tol) if(reler0.lt.0.5d0) tol=dmax1(reler0*tole,tol) endif c c convergence test c icvtst=0 if(relerr.lt.tole.or.relres.lt.tolr) icvtst=-1 if(relerr.le.tol.and.ratio.le.erf) icvtst=1 if(relres.lt.eps.and.ratio.ge.egf) icvtst=1 if(relerr.lt.eps) icvtst=1 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cev(ip,ja,a,ka,evl,evr,rp,iequv,ibndry, + br,bl,devr,devl,evr0,evl0,z,hist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),iequv(*),ibndry(6,*),ka(10,*) double precision + a(*),evl(*),evr(*),rp(100),bl(*),br(*), 1 devr(*),devl(*),z(*),hist(22,*),evr0(*),evl0(*) c c compute approximate left and right singular vectors c this routine should work when evl is allocated and ispd=1 c and also when evl=evr but ispd=0 c nvf=ip(2) nbf=ip(4) idbcpt=ip(7) ispd=ip(8) mxcg=ip(10) lvl=ip(75) anorm=rp(55) jspd=1 if(ispd.ne.1) jspd=-1 i1=1 i2=i1+nvf i3=i2+nvf iqptr=ja(nvf+1)+nvf c eps=1.0d-3 itmax=max0(10,mxcg) c c check for null vectors c sval=1.0d0 evrn=rl2nrm(nvf,evr) evln=rl2nrm(nvf,evl) if(evrn.eq.0.0d0.or.evln.eq.0.0d0) then do i=1,nvf evr(i)=1.0d0 evl(i)=1.0d0 enddo endif c c boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then evr(ibndry(1,i))=0.0d0 evr(ibndry(2,i))=0.0d0 evl(ibndry(1,i))=0.0d0 evl(ibndry(2,i))=0.0d0 endif enddo if(idbcpt.gt.0) then evr(idbcpt)=0.0d0 evl(idbcpt)=0.0d0 endif do i=1,nvf evr(i)=evr(iequv(i)) evl(i)=evl(iequv(i)) devr(i)=0.0d0 devl(i)=0.0d0 evr0(i)=0.0d0 evl0(i)=0.0d0 enddo c evrn=rl2nrm(nvf,evr) evln=rl2nrm(nvf,evl) dp=rl2ip(nvf,evl,evr) c if(evrn.eq.0.0d0.or.evln.eq.0.0d0) then rp(25)=sval return endif c c normalize initial vectors c if(dp.lt.0.0d0) evln=-evln do i=1,nvf ee=evr(i)/evrn evl(i)=evl(i)/evln evr(i)=ee enddo do i=1,nvf ii=ja(iqptr+i-1) z(i1+ii-1)=evr(i) z(i2+ii-1)=evl(i) enddo do i=1,nvf evr(i)=z(i1+i-1) evl(i)=z(i2+i-1) enddo c c inverse iteration loop c call hist1(hist(1,14),0,1.0d0) do itnum=1,itmax c c a evr = sval * evl c a(transpose) evl = sval * evr c call mtxmlt(nvf,ja,a,evr,z,ispd) sval=rl2ip(nvf,evl,z) do i=1,nvf br(i)=sval*evl(i)-z(i) bl(i)=br(i) enddo dr=rl2nrm(nvf,br)/(dabs(sval)+eps*anorm) if(ispd.ne.1) then call mtxmlt(nvf,ja,a,evl,z,jspd) svll=rl2ip(nvf,evr,z) do i=1,nvf bl(i)=svll*evr(i)-z(i) enddo dl=rl2nrm(nvf,bl)/(dabs(svll)+eps*anorm) dr=dmax1(dr,dl) endif call hist1(hist(1,14),itnum,dr) if(dr.lt.eps.and.itnum.gt.1) go to 100 c call cycle(ispd,lvl,ja,a,devr,br,ka,z) call csv(nvf,ja,a,evr,z(i1),devr,z(i2),evr0,z(i3),ispd) c if(ispd.ne.1) then call cycle(jspd,lvl,ja,a,devl,bl,ka,z) call csv(nvf,ja,a,evl,z(i1),devl,z(i2),evl0,z(i3),jspd) else do i=1,nvf evl(i)=evr(i) evl0(i)=evr0(i) devl(i)=devr(i) enddo endif c enddo itnum=itmax c c final computation of singular value c sign determined such that evl * evr is positive c 100 dp=rl2ip(nvf,evr,evl) if(dp.lt.0.0d0) then sval=-sval do i=1,nvf evl(i)=-evl(i) enddo endif do i=1,nvf ii=ja(iqptr+i-1) z(i1+i-1)=evr(ii) z(i2+i-1)=evl(ii) enddo do i=1,nvf evr(i)=z(i1+i-1) evl(i)=z(i2+i-1) enddo do i=1,nvf evr(i)=evr(iequv(i)) evl(i)=evl(iequv(i)) enddo rp(25)=sval return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine csv(nvf,ja,a,ev,aev,dev,adev,ev0,aev0,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + a(*),ev(*),aev(*),dev(*),adev(*),ev0(*),aev0(*), 1 aa(3,3),r(3),q(3,3) c c orthogonalize c call orthog(nvf,ev,dev,ev0,irank) c call mtxmlt(nvf,ja,a,ev,aev,ispd) call mtxmlt(nvf,ja,a,dev,adev,ispd) call mtxmlt(nvf,ja,a,ev0,aev0,ispd) c c compute inner products for quadratic equation c aa(1,1)=rl2ip(nvf,aev,aev) aa(1,2)=rl2ip(nvf,aev,adev) aa(1,3)=rl2ip(nvf,aev,aev0) aa(2,1)=aa(1,2) aa(2,2)=rl2ip(nvf,adev,adev) aa(2,3)=rl2ip(nvf,adev,aev0) aa(3,1)=aa(1,3) aa(3,2)=aa(2,3) aa(3,3)=rl2ip(nvf,aev0,aev0) call ev3x3(aa,r,q,irank) c c reset ev c do i=1,nvf s=q(2,1)*dev(i)+q(3,1)*ev0(i) ev(i)=q(1,1)*ev(i)+s ev0(i)=s enddo evnorm=rl2nrm(nvf,ev) if(evnorm.gt.0.0d0) evnorm=1.0d0/evnorm ev0nrm=rl2nrm(nvf,ev0) if(ev0nrm.gt.0.0d0) ev0nrm=1.0d0/ev0nrm do i=1,nvf ev(i)=ev(i)*evnorm ev0(i)=ev0(i)*ev0nrm enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ev3x3(a,r,q,irank) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + a(3,3),r(3),root(3),q(3,3) c c solve 3 x 3 eigenvalue problem for all special cases c do i=1,3 r(i)=0.0d0 do j=1,3 q(i,j)=0.0d0 enddo q(i,i)=1.0d0 enddo as=dmax1(a(1,1),a(2,2),a(3,3)) if(as.eq.0.0d0) return a11=a(1,1)/as a22=a(2,2)/as a33=a(3,3)/as a12=a(1,2)/as a13=a(1,3)/as a23=a(2,3)/as c c irank=1 c if(irank.eq.1) then r(1)=a(1,1) return endif if(irank.eq.2) then c c coefficients of quadratic c d12=a12**2 b=(a11+a22)/2.0d0 c0=dmax1(a11*a22-d12,0.0d0) d=(a11-a22)/2.0d0 d=dsqrt(d*d+d12) r1=c0/(b+d) r(1)=r1*as r(2)=(b+d)*as r(3)=0.0d0 d1=a11-r1 d2=a22-r1 if(dmax1(dabs(d1),dabs(d2)).eq.0.0d0) then c=1.0d0 s=0.0d0 else if(dabs(d1).gt.dabs(d2)) then dd=1.0d0/dsqrt(d1**2+d12) c=-a12*dd s=d1*dd else dd=1.0d0/dsqrt(d2**2+d12) s=-a12*dd c=d2*dd endif q(1,1)=c q(2,1)=s q(1,2)=-s q(2,2)=c return endif c c coefficients of cubic polynomial c tol=1.0d-3 d12=a12**2 d13=a13**2 d23=a23**2 p=-(a11+a22+a33)/3.0d0 qq=a11*a22+a22*a33+a33*a11-d12-d13-d23 s=a11*d23+a22*d13+a33*d12 + -a11*a22*a33-2.0d0*a12*a23*a13 c c solve cubic equation (all roots should be real and non-neg.) c aa=qq/3.0d0-p**2 bb=p**3-(p*qq-s)/2.0d0 if(bb**2+aa**3.ge.0.0d0) then c c case of two equal roots (assume b*b+a*a*a=0) c sgn=2.0d0 if(bb.gt.0.0d0) sgn=-2.0d0 bb=sgn*(dabs(bb)**(1.0d0/3.0d0)) r(1)=bb-p r(2)=-bb/2.0d0-p r(3)=r(2) else c c three distinct roots c d=dsqrt(-aa)*2.0d0 theta=2.0d0*bb/(aa*d) theta=dmin1(1.0d0,theta) theta=dmax1(-1.0d0,theta) theta=dacos(theta)/3.0d0 pi=3.141592653589793d0/3.0d0 r(1)=d*dcos(theta)-p r(2)=d*dcos(theta+2.0d0*pi)-p r(3)=d*dcos(theta+4.0d0*pi)-p endif c c order c ic1=1 if(r(2).lt.r(1)) ic1=2 if(r(3).lt.r(ic1)) ic1=3 ic2=(5-ic1)/2 ic3=6-ic1-ic2 if(r(ic3).lt.r(ic2)) ic2=ic3 ic3=6-ic1-ic2 root(1)=r(ic1) root(2)=r(ic2) root(3)=r(ic3) r(1)=root(1)*as r(2)=root(2)*as r(3)=root(3)*as c c now get eigenvectors c if(r(3)-r(1).lt.tol*r(3)) then return else if(dmin1(r(2)-r(1),r(3)-r(2)).le.tol*r(2)) then a1=a11-root(2) a2=a22-root(2) a3=a33-root(2) s1=a1**2+d12+d13 s2=a2**2+d12+d23 s3=a3**2+d13+d23 if(s1.gt.dmax1(s2,s3)) then qq=1.0d0/dsqrt(s1) v1=qq*a1 v2=qq*a12 v3=qq*a13 else if(s2.gt.s3) then qq=1.0d0/dsqrt(s2) v1=qq*a12 v2=qq*a2 v3=qq*a23 else qq=1.0d0/dsqrt(s3) v1=qq*a13 v2=qq*a23 v3=qq*a3 endif if(v1.eq.0.0d0) then w1=1.0d0 w2=0.0d0 w3=0.0d0 else if(v2.eq.0.0d0) then w1=0.0d0 w2=1.0d0 w3=0.0d0 else qq=1.0d0/dsqrt(v1**2+v2**2) w1=-v2*qq w2=v1*qq w3=0.0d0 endif z1=v2*w3-v3*w2 z2=v3*w1-v1*w3 z3=v1*w2-v2*w1 if(r(2)-r(1).le.tol*r(2)) then dd=dsqrt((z1-w2)**2+(z2+w1)**2) c=(z2+w1)/dd s=(z1-w2)/dd q(1,1)=c*w1+s*z1 q(2,1)=c*w2+s*z2 q(3,1)=c*w3+s*z3 q(1,2)=c*z1-s*w1 q(2,2)=c*z2-s*w2 q(3,2)=c*z3-s*w3 q(1,3)=v1 q(2,3)=v2 q(3,3)=v3 else dd=dsqrt((z2-w3)**2+(z3+w2)**2) c=(z3+w2)/dd s=(z2-w3)/dd q(1,1)=v1 q(2,1)=v2 q(3,1)=v3 q(1,2)=c*w1+s*z1 q(2,2)=c*w2+s*z2 q(3,2)=c*w3+s*z3 q(1,3)=c*z1-s*w1 q(2,3)=c*z2-s*w2 q(3,3)=c*z3-s*w3 endif else c c the general case c c if(r(2)-r(1).gt.(r(3)-r(2))*1.d-2) then js=1 jf=2 else js=2 jf=3 endif do i=js,jf a1=a11-root(i) a2=a22-root(i) a3=a33-root(i) v1=a2*a3-d23 v2=a13*a23-a12*a3 v3=a12*a23-a13*a2 vv=v1**2+v2**2+v3**2 w1=v2 w2=a1*a3-d13 w3=a13*a12-a23*a1 ww=w1**2+w2**2+w3**2 z1=v3 z2=w3 z3=a1*a2-d12 zz=z1**2+z2**2+z3**2 if(vv.gt.dmax1(ww,zz)) then qq=1.0d0/dsqrt(vv) q(1,i)=qq*v1 q(2,i)=qq*v2 q(3,i)=qq*v3 else if(ww.gt.zz) then qq=1.0d0/dsqrt(ww) q(1,i)=qq*w1 q(2,i)=qq*w2 q(3,i)=qq*w3 else qq=1.0d0/dsqrt(zz) q(1,i)=qq*z1 q(2,i)=qq*z2 q(3,i)=qq*z3 endif enddo ic=6-js-jf q(1,ic)=q(2,js)*q(3,jf)-q(3,js)*q(2,jf) q(2,ic)=q(3,js)*q(1,jf)-q(1,js)*q(3,jf) q(3,ic)=q(1,js)*q(2,jf)-q(2,js)*q(1,jf) endif do i=1,3 if(q(i,i).lt.0.0d0) then q(1,i)=-q(1,i) q(2,i)=-q(2,i) q(3,i)=-q(3,i) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine orthog(nvf,v1,v2,v3,irank) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + v1(*),v2(*),v3(*),r(3) c c orthogonalize, normalize, determine rank c tol=1.d-1 a11=0.0d0 a22=0.0d0 a33=0.0d0 do i=1,nvf a11=a11+v1(i)**2 a22=a22+v2(i)**2 a33=a33+v3(i)**2 enddo if(a11.gt.0.0d0) a11=1.0d0/dsqrt(a11) if(a22.gt.0.0d0) a22=1.0d0/dsqrt(a22) if(a33.gt.0.0d0) a33=1.0d0/dsqrt(a33) d12=0.0d0 d13=0.0d0 do i=1,nvf v1(i)=v1(i)*a11 v2(i)=v2(i)*a22 v3(i)=v3(i)*a33 d12=d12+v1(i)*v2(i) d13=d13+v1(i)*v3(i) enddo a22=0.0d0 a33=0.0d0 do i=1,nvf v2(i)=v2(i)-d12*v1(i) v3(i)=v3(i)-d13*v1(i) a22=a22+v2(i)**2 a33=a33+v3(i)**3 enddo if(a22.gt.0.0d0) a22=1.0d0/dsqrt(a22) if(a33.gt.0.0d0) a33=1.0d0/dsqrt(a33) d23=0.0d0 do i=1,nvf v2(i)=v2(i)*a22 v3(i)=v3(i)*a33 d23=d23+v2(i)*v3(i) enddo a33=0.0d0 do i=1,nvf v3(i)=v3(i)-d23*v2(i) a33=a33+v3(i)**2 enddo if(a33.gt.0.0d0) a33=1.0d0/dsqrt(a33) a12=0.0d0 a13=0.0d0 a23=0.0d0 do i=1,nvf v3(i)=v3(i)*a33 a12=a12+v1(i)*v2(i) a13=a13+v1(i)*v3(i) a23=a23+v2(i)*v3(i) enddo c c coefficients of cubic polynomial c if(a11.gt.0.0d0) a11=1.0d0 if(a22.gt.0.0d0) a22=1.0d0 if(a33.gt.0.0d0) a33=1.0d0 d12=a12**2 d13=a13**2 d23=a23**2 p=-(a11+a22+a33)/3.0d0 qq=a11*a22+a22*a33+a33*a11-d12-d13-d23 s=a11*d23+a22*d13+a33*d12 + -a11*a22*a33-2.0d0*a12*a23*a13 c c solve cubic equation (all roots should be real and non-neg.) c aa=qq/3.0d0-p**2 bb=p**3-(p*qq-s)/2.0d0 if(bb**2+aa**3.ge.0.0d0) then c c case of two equal roots (assume b*b+a*a*a=0) c sgn=2.0d0 if(bb.gt.0.0d0) sgn=-2.0d0 bb=sgn*(dabs(bb)**(1.0d0/3.0d0)) r(1)=bb-p r(2)=-bb/2.0d0-p r(3)=r(2) else c c three distinct roots c d=dsqrt(-aa)*2.0d0 theta=2.0d0*bb/(aa*d) theta=dmin1(1.0d0,theta) theta=dmax1(-1.0d0,theta) theta=dacos(theta)/3.0d0 pi=3.141592653589793d0/3.0d0 r(1)=d*dcos(theta)-p r(2)=d*dcos(theta+2.0d0*pi)-p r(3)=d*dcos(theta+4.0d0*pi)-p endif c c order c ic1=1 if(r(2).lt.r(1)) ic1=2 if(r(3).lt.r(ic1)) ic1=3 ic2=(5-ic1)/2 ic3=6-ic1-ic2 if(r(ic3).lt.r(ic2)) ic2=ic3 ic3=6-ic1-ic2 c irank=1 if(r(ic2).gt.tol) irank=2 if(r(ic1).gt.tol) irank=3 c if(irank.eq.1) then do i=1,nvf v2(i)=0.0d0 v3(i)=0.0d0 enddo else if(irank.eq.2.and.a33.gt.0.0d0) then if(a22.le.0.0d0) then do i=1,nvf v2(i)=v3(i) enddo else if(dabs(a13).lt.dabs(a12)) then do i=1,nvf v2(i)=v3(i) enddo endif do i=1,nvf v3(i)=0.0d0 enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine grad(ux,uy,vx,vy,u,iv,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + iv(3) double precision + vx(*),vy(*),u(*) c c compute the gradient of u in element defined by iv c iv1=iv(1) iv2=iv(2) iv3=iv(3) x2=vx(iv2)-vx(iv1) x3=vx(iv3)-vx(iv1) y2=vy(iv2)-vy(iv1) y3=vy(iv3)-vy(iv1) if(isw.eq.1) then u2=u(2)-u(1) u3=u(3)-u(1) else u2=u(iv2)-u(iv1) u3=u(iv3)-u(iv1) endif det=x2*y3-x3*y2 ux=(u2*y3-u3*y2)/det uy=(x2*u3-x3*u2)/det return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function carea(ntf,itnode,itedge, + ibndry,vx,vy,xm,ym) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3) double precision + vx(*),vy(*),xm(*),ym(*),c(3) save index data index/1,2,3,2,3,1,3,1,2/ c c compute area of domain c carea=0.0d0 pi=3.141592653589793d0 do i=1,ntf x2=vx(itnode(2,i))-vx(itnode(1,i)) x3=vx(itnode(3,i))-vx(itnode(1,i)) y2=vy(itnode(2,i))-vy(itnode(1,i)) y3=vy(itnode(3,i))-vy(itnode(1,i)) det=dabs(x2*y3-x3*y2)/2.0d0 c c curved edges c do 5 j=1,3 if(itedge(j,i).ge.0) go to 5 k=-itedge(j,i) if(ibndry(3,k).le.0) go to 5 kt=ibndry(3,k) iv1=itnode(index(2,j),i) iv2=itnode(index(3,j),i) call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(kt),ym(kt),theta1,theta2,rad,alen) call bari(xm(kt),ym(kt),vx,vy,itnode(1,i),c) theta=dabs(theta2-theta1)*pi aa=(rad**2/2.0d0)*(theta-dsin(theta)) if(c(j).lt.0.0d0) aa=-aa det=det+aa 5 enddo carea=carea+det enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bari(x,y,vx,vy,iv,c) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + iv(3) double precision + vx(*),vy(*),c(3) c c compute the barycentric coordinates of the point (x,y) c iv1=iv(1) iv2=iv(2) iv3=iv(3) x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) xr=x-vx(iv1) yr=y-vy(iv1) det=x2*y3-x3*y2 c(2)=(xr*y3-x3*yr)/det c(3)=(x2*yr-xr*y2)/det c(1)=1.0d0-c(2)-c(3) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function rl2nrm(n,b) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + b(*) c c compute norm of b and update history c bnorm=0.0d0 bmax=0.0d0 do i=1,n if(dabs(b(i)).lt.bmax) then bnorm=bnorm+(b(i)/bmax)**2 else if(b(i).ne.0.0d0) then bnorm=1.0d0+bnorm*(bmax/b(i))**2 bmax=dabs(b(i)) endif enddo rl2nrm=dsqrt(bnorm)*bmax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function rl2ip(n,x,y) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*) c c compute dot product c rl2ip=0.0d0 spmax=0.0d0 snmax=0.0d0 sp=0.0d0 sn=0.0d0 do i=1,n t=x(i)*y(i) if(t.ge.0.0d0) then if(t.lt.spmax) then sp=sp+t/spmax else if(t.ne.0.0d0) then sp=1.0d0+sp*(spmax/t) spmax=t endif else if(-t.lt.snmax) then sn=sn+t/snmax else sn=-(1.0d0+sn*(snmax/t)) snmax=-t endif endif enddo rl2ip=sp*spmax+sn*snmax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function cl2ip(nvf,ntf,vx,vy,u,z,itnode) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),u(*),z(*) c c compute continuous l2 inner product c cl2ip=0.0d0 umax=0.0d0 zmax=0.0d0 do i=1,nvf umax=dmax1(umax,dabs(u(i))) zmax=dmax1(zmax,dabs(z(i))) enddo if(umax.le.0.0d0.or.zmax.le.0.0d0) return sum=0.0d0 do i=1,ntf iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) det=dabs(x2*y3-x3*y2) u1=(u(iv2)+u(iv3))/umax u2=(u(iv3)+u(iv1))/umax u3=(u(iv1)+u(iv2))/umax z1=(z(iv2)+z(iv3))/zmax z2=(z(iv3)+z(iv1))/zmax z3=(z(iv1)+z(iv2))/zmax sum=sum+det*(u1*z1+u2*z2+u3*z3) enddo cl2ip=(sum*umax)*zmax/24.0d0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function cl2nrm(nvf,ntf,vx,vy,u,itnode) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),u(*) c c compute continuous l2 inner product c cl2nrm=0.0d0 umax=0.0d0 do i=1,nvf umax=dmax1(umax,dabs(u(i))) enddo if(umax.le.0.0d0) return sum=0.0d0 do i=1,ntf iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) det=dabs(x2*y3-x3*y2) u1=(u(iv2)+u(iv3))/umax u2=(u(iv3)+u(iv1))/umax u3=(u(iv1)+u(iv2))/umax sum=sum+det*(u1**2+u2**2+u3**2) enddo cl2nrm=dsqrt(sum/24.0d0)*umax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function ch1ip(nvf,ntf,vx,vy,u,z,itnode) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),u(*),z(*) c c compute continuous h1 inner product c ch1ip=0.0d0 umax=0.0d0 zmax=0.0d0 do i=1,nvf umax=dmax1(umax,dabs(u(i))) zmax=dmax1(zmax,dabs(z(i))) enddo if(umax.le.0.0d0.or.zmax.le.0.0d0) return sum=0.0d0 do i=1,ntf iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) det=x2*y3-x3*y2 c c compute gradient c u2=(u(iv2)-u(iv1))/umax u3=(u(iv3)-u(iv1))/umax ux=u2*y3-u3*y2 uy=x2*u3-x3*u2 z2=(z(iv2)-z(iv1))/zmax z3=(z(iv3)-z(iv1))/zmax zx=z2*y3-z3*y2 zy=x2*z3-x3*z2 c sum=sum+(ux*zx+uy*zy)/dabs(det) enddo ch1ip=(sum*umax)*zmax/2.0d0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function ch1nrm(nvf,ntf,vx,vy,u,itnode) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),u(*) c c compute continuous h1 norm c ch1nrm=0.0d0 umax=0.0d0 do i=1,nvf umax=dmax1(umax,dabs(u(i))) enddo if(umax.le.0.0d0) return sum=0.0d0 do i=1,ntf iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) det=x2*y3-x3*y2 c c compute gradient c u2=(u(iv2)-u(iv1))/umax u3=(u(iv3)-u(iv1))/umax ux=u2*y3-u3*y2 uy=x2*u3-x3*u2 c sum=sum+(ux**2+uy**2)/dabs(det) enddo ch1nrm=dsqrt(sum/2.0d0)*umax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cerr(ntf,itnode,vx,vy,u,ux,uy,enorm,unorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),u(*),ux(*),uy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c norm computations c enorm=0.0d0 unorm=0.0d0 uhnorm=0.0d0 c do i=1,ntf iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) x3=vx(iv3)-vx(iv1) y2=vy(iv2)-vy(iv1) y3=vy(iv3)-vy(iv1) det=x2*y3-x3*y2 c c compute gradients of u c u2=u(iv2)-u(iv1) u3=u(iv3)-u(iv1) uhx=(u2*y3-u3*y2)/det uhy=(x2*u3-x3*u2)/det c c local h1 norms c u1=0.0d0 e1=0.0d0 do j=1,3 j2=itnode(index(2,j),i) j3=itnode(index(3,j),i) rx=(ux(j2)+ux(j3))/2.0d0 ry=(uy(j2)+uy(j3))/2.0d0 u1=u1+rx**2+ry**2 e1=e1+(rx-uhx)**2+(ry-uhy)**2 enddo enorm=enorm+e1*dabs(det)/6.0d0 unorm=unorm+u1*dabs(det)/6.0d0 uhnorm=uhnorm+(uhx**2+uhy**2)*dabs(det)/2.0d0 enddo c enorm=dsqrt(enorm) unorm=dsqrt(dmax1(unorm,uhnorm)) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine l2mtx(nvf,ntf,vx,vy,itnode,ja,a,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),iequv(*),ja(*),iv(3) double precision + vx(*),vy(*),a(*) c c do i=1,ja(nvf+1)-1 a(i)=0.0d0 enddo c c compute mass matrix c ishift=0 do i=1,ntf iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) x3=vx(iv3)-vx(iv1) y2=vy(iv2)-vy(iv1) y3=vy(iv3)-vy(iv1) det=dabs(x2*y3-x3*y2)/24.0d0 do k=1,3 iv(k)=iequv(itnode(k,i)) enddo do k=1,3 ivk=iv(k) a(ivk)=a(ivk)+2.0d0*det do j=k+1,3 call jamap(ivk,iv(j),kj,jk,ja,ishift) a(jk)=a(jk)+det enddo enddo enddo anorm=0.0d0 do i=1,nvf anorm=dmax1(anorm,dabs(a(i))) enddo do i=1,nvf if(a(i).eq.0.0d0) a(i)=anorm enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine h10mtx(nvf,ntf,vx,vy,itnode,ja,a,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),iequv(*),ja(*),iv(3),index(3,3) double precision + vx(*),vy(*),a(*),gx(3),gy(3) save index data index/1,2,3,2,3,1,3,1,2/ c c do i=1,ja(nvf+1)-1 a(i)=0.0d0 enddo c c compute stiffness matrix for laplacian with natural bc c ishift=0 do i=1,ntf c c tangent directions c do k=1,3 k2=itnode(index(2,k),i) k3=itnode(index(3,k),i) gy(k)=vx(k3)-vx(k2) gx(k)=vy(k2)-vy(k3) iv(k)=iequv(itnode(k,i)) enddo det=1.0d0/(dabs(gy(2)*gx(3)-gy(3)*gx(2))*2.0d0) do k=1,3 ivk=iv(k) a(ivk)=a(ivk)+det*(gx(k)**2+gy(k)**2) do j=k+1,3 call jamap(ivk,iv(j),kj,jk,ja,ishift) a(jk)=a(jk)+det*(gx(k)*gx(j)+gy(k)*gy(j)) enddo enddo enddo anorm=0.0d0 do i=1,nvf anorm=dmax1(anorm,dabs(a(i))) enddo do i=1,nvf if(a(i).eq.0.0d0) a(i)=anorm enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine h1mtx(nvf,ntf,nbf,idbcpt,vx,vy,itnode,ibndry, + ja,a,iequv,q,mark) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),iequv(*),ja(*),iv(3),index(3,3),mark(*), 1 ibndry(6,*),q(*) double precision + vx(*),vy(*),a(*),gx(3),gy(3) save index data index/1,2,3,2,3,1,3,1,2/ c c do i=1,ja(nvf+1)-1 a(i)=0.0d0 enddo c c compute laplace stiffness matrix c ishift=0 do i=1,ntf c c tangent directions c do k=1,3 k2=itnode(index(2,k),i) k3=itnode(index(3,k),i) gy(k)=vx(k3)-vx(k2) gx(k)=vy(k2)-vy(k3) iv(k)=q(iequv(itnode(k,i))) enddo det=1.0d0/(dabs(gy(2)*gx(3)-gy(3)*gx(2))*2.0d0) do k=1,3 ivk=iv(k) a(ivk)=a(ivk)+det*(gx(k)**2+gy(k)**2) do j=k+1,3 call jamap(ivk,iv(j),kj,jk,ja,ishift) a(jk)=a(jk)+det*(gx(k)*gx(j)+gy(k)*gy(j)) enddo enddo enddo anorm=0.0d0 do i=1,nvf anorm=dmax1(anorm,dabs(a(i))) mark(i)=0 enddo c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then mark(q(ibndry(1,i)))=1 mark(q(ibndry(2,i)))=1 endif enddo if(idbcpt.gt.0) mark(q(idbcpt))=1 do i=1,nvf if(a(i).eq.0.0d0) a(i)=anorm if(iequv(i).ne.i) a(i)=anorm if(mark(i).eq.1) a(i)=anorm do jj=ja(i),ja(i+1)-1 if(mark(i).eq.1.or.mark(ja(jj)).eq.1) a(jj)=0.0d0 enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sgscg(n,ja,a,x,r,mxcg,ap,p,z,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + a(*),ap(*),p(*),z(*),x(*),r(*) c c sgs-cg using just one matrix multiply per iteration c c initialize c zdz=0.0d0 relerr=1.0d0 do i=1,n p(i)=0.0d0 ap(i)=0.0d0 sum=a(i)*x(i) do j=ja(i),ja(i+1)-1 sum=sum+x(ja(j))*a(j) enddo r(i)=r(i)-sum z(i)=r(i) enddo c c the main loop c do itnum=1,mxcg c c forward sweep c sum=0.0d0 do i=1,n t=z(i)/a(i) sum=sum+t*z(i) do j=ja(i),ja(i+1)-1 z(ja(j))=z(ja(j))-(t+x(i))*a(j) enddo enddo c c test for convergence c if(itnum.gt.1) then if(zdz.eq.0.0d0) return beta=sum/zdz relerr=relerr*beta if(dsqrt(relerr).lt.eps) return else beta=0.0d0 endif zdz=sum c c backward sweep c pap=0.0d0 do i=n,1,-1 ap(i)=z(i)+beta*ap(i) sum=0.0d0 do j=ja(i),ja(i+1)-1 sum=sum+z(ja(j))*a(j) enddo z(i)=(z(i)-sum)/a(i) p(i)=z(i)+beta*p(i) pap=pap+p(i)*(2.0d0*ap(i)-p(i)*a(i)) enddo if(pap.eq.0.0d0) return alpha=zdz/pap c c update x,r c do i=1,n x(i)=x(i)+alpha*p(i) r(i)=r(i)-alpha*ap(i) z(i)=r(i) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine jcg(n,ja,a,x,r,mxcg,ap,p,z,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + a(*),x(*),r(*),p(*),ap(*),z(*) c c cg with identity preconditioner c c initialize c ispd=1 zdz=0.0d0 relerr=1.0d0 call mtxmlt(n,ja,a,x,ap,ispd) do i=1,n r(i)=r(i)-ap(i) p(i)=0.0d0 ap(i)=0.0d0 enddo c c the main loop c do itnum=1,mxcg c c compute alpha and pecondition c do i=1,n cc z(i)=r(i)/a(i) z(i)=r(i) enddo sum=rl2ip(n,z,r) if(itnum.gt.1) then if(zdz.eq.0.0d0) return beta=sum/zdz relerr=relerr*beta if(dsqrt(relerr).lt.eps) return else beta=0.0d0 endif zdz=sum do i=1,n p(i)=z(i)+beta*p(i) enddo call mtxmlt(n,ja,a,p,ap,ispd) pap=rl2ip(n,p,ap) if(pap.eq.0.0d0) return alpha=zdz/pap do i=1,n x(i)=x(i)+alpha*p(i) r(i)=r(i)-alpha*ap(i) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function dl2nrm(n,b,d,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + b(*),d(*) c c compute norm of b and update history c bnorm=0.0d0 bmax=0.0d0 do i=1,n dd=0.0d0 if(isw.ge.0) then dd=d(i) else if(d(i).ne.0.0d0) dd=1.0d0/d(i) endif if(dabs(b(i)).lt.bmax) then bnorm=bnorm+dd*(b(i)/bmax)**2 else if(b(i).ne.0.0d0) then bnorm=dd+bnorm*(bmax/b(i))**2 bmax=dabs(b(i)) endif enddo dl2nrm=dsqrt(bnorm)*bmax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function dl2ip(n,x,y,d,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),d(*) c c compute dot product c dl2ip=0.0d0 spmax=0.0d0 snmax=0.0d0 sp=0.0d0 sn=0.0d0 do i=1,n t=0.0d0 if(isw.ge.0) then t=x(i)*y(i)*d(i) else if(d(i).ne.0.0d0) t=x(i)*y(i)/d(i) endif if(t.ge.0.0d0) then if(t.lt.spmax) then sp=sp+t/spmax else if(t.ne.0.0d0) then sp=1.0d0+sp*(spmax/t) spmax=t endif else if(-t.lt.snmax) then sn=sn+t/snmax else sn=-(1.0d0+sn*(snmax/t)) snmax=-t endif endif enddo dl2ip=sp*spmax+sn*snmax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),iequv(*) double precision + vx(*),vy(*),gm(*) c c compute weight discrete l2 inner product c do i=1,nvf gm(i)=0.0d0 enddo do i=1,ntf x2=vx(itnode(2,i))-vx(itnode(1,i)) y2=vy(itnode(2,i))-vy(itnode(1,i)) x3=vx(itnode(3,i))-vx(itnode(1,i)) y3=vy(itnode(3,i))-vy(itnode(1,i)) det=dabs(x2*y3-x3*y2)/12.0d0 do j=1,3 k=iequv(itnode(j,i)) gm(k)=gm(k)+det enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkgmd(ip,itnode,vx,vy,iequv,ipath,gm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),iequv(*),ip(100),ipath(4,*),iv(3) double precision + vx(*),vy(*),gm(*) c c compute diag of gram matrix form interface vertices c c initialize c newntf=ip(31) nproc=ip(49) irgn=ip(50) nvv=ip(34) nn=ipath(2,nproc+2) c do i=1,nn gm(i)=0.0d0 enddo c c compute integrals on elements c do i=1,newntf do k=1,3 iv(k)=iequv(itnode(k,i)) enddo if(min0(iv(1),iv(2),iv(3)).le.nvv) then x2=vx(itnode(2,i))-vx(itnode(1,i)) y2=vy(itnode(2,i))-vy(itnode(1,i)) x3=vx(itnode(3,i))-vx(itnode(1,i)) y3=vy(itnode(3,i))-vy(itnode(1,i)) det=dabs(x2*y3-x3*y2)/12.0d0 do k=1,3 if(iv(k).le.nvv) then ivkb=iv(k)+ipath(1,irgn)-1 gm(ivkb)=gm(ivkb)+det endif enddo endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine centre(x1,y1,x2,y2,x3,y3,xc,yc) c implicit double precision (a-h,o-z) implicit integer (i-n) c c compute the center of the circle which passes c through (x1,y1), (x2,y2), and (x3,y3) c z1=x1-x3 z2=x2-x3 w1=y1-y3 w2=y2-y3 det=(z1*w2-z2*w1)*2.0d0 if(det.ne.0.0d0) then r1=(z1*(x1+x3)+w1*(y1+y3))/det r2=(z2*(x2+x3)+w2*(y2+y3))/det xc=r1*w2-r2*w1 yc=z1*r2-z2*r1 else xc=x1 yc=y1 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine midpt(x1,y1,x2,y2,xc,yc,x,y) c implicit double precision (a-h,o-z) implicit integer (i-n) c c compute the midpoint of the circle with center (xc,yc) c which passes through the points (x1,y1),(x2,y2). c the midpoint (x,y) is relative to the shorter c of the two arcs. c x=(x1+x2)/2.0d0 y=(y1+y2)/2.0d0 c=(x+x1-2.0d0*xc)*(x1-x)+(y+y1-2.0d0*yc)*(y1-y) if(c.le.0.0d0) return dy=y1-y2 dx=x1-x2 b=(x-xc)*dy-(y-yc)*dx a=dx*dx+dy*dy a=c/(dabs(b)+dsqrt(b*b+a*c)) if(b.lt.0.0d0) a=-a x=x+a*dy y=y-a*dx return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function ceps(ibit) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + eptst save isw,sveps,jbit data isw,jbit,sveps/1,0,0.0d0/ c c compute machine epsilon c if(isw.eq.0) then ceps=sveps ibit=jbit return else ibit=-4 eps=1.0d0 3 eps1=1.0d0+eps if(eptst(eps1).eq.1) then ceps=2.0d0**(-ibit) sveps=ceps jbit=ibit isw=0 return else eps=eps/2.0d0 ibit=ibit+1 go to 3 endif endif end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- integer function eptst(x) c implicit double precision (a-h,o-z) implicit integer (i-n) c c this is to force a store of eps1 to memory c if(x.eq.1.0d0) then eptst=1 else eptst=0 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine stor(ip) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100) c c set up /val*/ common blocks c call setval c c storage allocation c iprob=iabs(ip(6)) ispd=ip(8) lenw=ip(20) maxt=ip(21) maxv=ip(22) maxb=ip(24) nproc=ip(49) if(nproc.gt.1) then maxpth=max0(maxv/10,maxb)*min0(nproc,8) else maxpth=0 endif ip(81)=maxpth c c pointers c iuu=1 iux=iuu+maxv iuy=iux+maxv if(iprob.eq.1.or.iprob.eq.2) then iu0=iuy iudot=iu0 iu0dot=iudot ngf=3 else if(iprob.eq.4) then iu0=iuy+maxv iudot=iu0 iu0dot=iudot ngf=4 else if(iprob.eq.5) then iu0=iuy+maxv iudot=iu0+maxv iu0dot=iudot ngf=5 else iu0=iuy+maxv iudot=iu0+maxv iu0dot=iudot+maxv ngf=6 endif if(nproc.gt.1) then iudl=iu0dot+maxv ngf=ngf+1 else iudl=iu0dot endif ievr=iudl+maxv if(ispd.eq.1) then ievl=ievr ngf=ngf+1 else ievl=ievr+maxv ngf=ngf+2 endif nef=1 jtime=ievl+maxv jhist=jtime+150 jpath=jhist+660 ka=jpath+606 jstat=ka+1000 iee=jstat+10*nproc ipath=iee+maxt iz=ipath+4*maxpth c ip(76)=nef ip(77)=ngf ip(83)=iuu ip(84)=iux ip(85)=iuy ip(86)=iu0 ip(87)=iudot ip(88)=iu0dot ip(89)=iudl ip(90)=ievr ip(91)=ievl ip(92)=jtime ip(93)=jhist ip(94)=jpath ip(95)=ka ip(96)=jstat ip(97)=iee ip(98)=ipath ip(99)=iz if(iz.gt.lenw) then ip(25)=20 else ip(25)=0 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine memptr(newptr,length,type,ibegin,iend,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(2,100),link(100) character*4 type save len,ifirst,link,list,level data len,ifirst/100,1/ c c this is a very crude memory manager, mainly for arrays c it assumes generally higest priority stuff is allocated first, low c priority stuff last (or from the tail, and that freeing goes in c reverse order from allocating. c iflag=0 c c allocate from the head of available space c if(type.eq.'head') then newptr=ibegin ibegin=ibegin+length if(ibegin.gt.iend+1) iflag=20 c c allocate from the tail of the available space c elseif(type.eq.'tail') then iend=iend-length newptr=iend+1 if(ibegin.gt.iend+1) iflag=20 c c save the current state of allocation (to allow a massive free) c elseif(type.eq.'mark') then if(ifirst.eq.1) then ifirst=0 level=1 do i=1,len link(i)=i+1 enddo link(len)=0 endif newptr=level if(level.gt.0) then level=link(level) list(1,newptr)=ibegin list(2,newptr)=iend else iflag=20 endif c c restore to state newptr c elseif(type.eq.'free') then link(newptr)=level level=newptr ibegin=list(1,level) iend=list(2,level) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dtpick(ntf,nvf,itnode,vx,vy,u,u0,rp,z,iflag,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),u(*),u0(*),rp(100),z(*) c c compute time step c c iflag = -5 initialize, deltat=dtmin, next to last step c iflag = -4 initialize, deltat=dtmin, last step c iflag = -3 initialize, deltat=dtmin c iflag = -2 step failed, accept step (dt=dtmin) c iflag = -1 step failed, retake step c iflag = 0 normal step accepted c iflag = 1 next to last step c iflag = 2 last step c iflag = 3 just computed utnorm c c c initialize c deltat=rp(47) if(isw.eq.1) then tcur=rp(46) else tcur=rp(46)+deltat endif dtmin=rp(48) dtmax=rp(49) utnorm=rp(50) tend=rp(43) tmtol=rp(44) ratio=10.0d0 fudge=0.9d0 iflag=3 c c the main loop c if(isw.eq.1) go to 30 do i=1,nvf z(i)=u(i)-u0(i) enddo unorm=cl2nrm(nvf,ntf,vx,vy,u,itnode) utnorm=cl2nrm(nvf,ntf,vx,vy,z,itnode) if(unorm.gt.0.0d0) utnorm=utnorm/unorm rp(50)=utnorm if(isw.eq.-1) return c c compute a new tentative time step c 30 if(utnorm.gt.tmtol) then c c cut step back c if(deltat.le.dtmin) then iflag=-2 deltat=dtmin else deltat=dmax1(dtmin,deltat/ratio, + deltat*tmtol*fudge/utnorm) iflag=-1 endif else if(utnorm.gt.0.0d0) then c c increase step (slight cutback if utnorm > tmtol*fudge) c deltat=dmin1(dtmax,deltat*ratio, + deltat*tmtol*fudge/utnorm) deltat=dmax1(dtmin,deltat) iflag=0 else iflag=-3 deltat=dtmin endif endif c c check for end of interval c if(tcur+deltat.ge.tend) then deltat=tend-tcur if(iflag.ne.-3) then iflag=2 else iflag=-4 endif else if(tcur+2.0d0*deltat.ge.tend) then if(tend-tcur-deltat.le.2.0d0*deltat/ratio) + deltat=tend-tcur-2.0d0*deltat/ratio if(iflag.ne.-3) then iflag=1 else iflag=-5 endif endif rp(47)=deltat return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bisect(rp,isw,rqup0,rqlow0) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100) save tol,fract,sigup,siglow,signew,sigold, + rqup,rqlow,rqnew,rqold,rqmx data ibit/0/ c c this routine carries out a bisection c or secant iteration c c isw = 0 initialize c > 0 update c < 0 converged c if(isw.eq.0) then fract=1.0d-3 tol=dmax1(1.0d-6,ceps(ibit)*1.0d2) sigup=rp(71) siglow=0.0d0 signew=sigup sigold=siglow rqup=rp(25) rqlow=rp(35) rqnew=rqup rqold=rqlow rqmx=dmax1(dabs(rqup),dabs(rqlow)) isw=1 else sigold=signew signew=rp(71) rqold=rqnew rqnew=rp(25) if(rqnew*rqlow.lt.0.0d0) then sigup=signew rqup=rqnew else siglow=signew rqlow=rqnew endif endif c c return rqup, rqlow just for the history file c rqup0=rqup rqlow0=rqlow sigma=(sigup+siglow)/2.0d0 al=dabs(sigup-siglow) c c convergence test c if(sigma.eq.signew.or.al.lt.tol*dabs(sigma).or. + dabs(rqnew).lt.tol*rqmx) then isw=-1 return endif c if(rqnew-rqold.ne.0.0d0) then qq=signew-rqnew*(signew-sigold)/(rqnew-rqold) dism=dmax1(dabs(siglow-qq),dabs(sigup-qq)) c c move toward middle of interval if too close to boundary c if(dism.gt.al*(1.0d0-fract)) + qq=qq+(sigma-qq)*fract c c accept secant step if inside interval c dism=dmax1(dabs(siglow-qq),dabs(sigup-qq)) if(dism.lt.al*(1.0d0-fract)) sigma=qq endif rp(71)=sigma return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tpick(ip,rp,itnode,ja,a,h,g,su,sm,b,d,del,u,usv, + delm,um,umsv,delc,uc,ucsv,p,dl,adel,hdel,iequv,gm, 1 z,vx,vy,isw,bdlwr,bdupr,itnum) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ja(*),iequv(*),ip(100) double precision + a(*),b(*),del(*),adel(*),vx(*),vy(*),rp(100),delm(*), 1 gm(*),p(*),u(*),z(*),usv(*),bdlwr(*),bdupr(*),d(*), 2 um(*),umsv(*),hdel(*),h(*),dl(*),uc(*),ucsv(*), 3 delc(*),g(*),su(*),sm(*) save ksw,tol,eps,snew,sold,sleft,sright,dnew,dold, + bold,rlsv,b20,bd0,d20,ibit data ibit/0/ c c this routine carries out a bisection c or secant iteration c c isw = 0 initialize c > 0 update c < 0 converged c c compute norms c ntf=ip(1) nvf=ip(2) iprob=ip(6) c call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) if(iprob.eq.2) then call norm2(ip,ja,a,gm,u,del,adel,b,iequv,z,rp, + bdlwr,bdupr,isw,itnum,unorm,enorm,bnorm,ddnew,dnorm) else if(iprob.eq.3) then call norm3(ip,ja,a,gm,u,del,adel,b,iequv,z,rp, + p,d,unorm,enorm,bnorm,ddnew,dnorm) else if(iprob.eq.4) then call norm4(ip,ja,a,h,gm,u,um,del,delm,adel,hdel, + b,iequv,z,rp,p,d,dl,unorm,enorm,bnorm,ddnew,dnorm) else if(iprob.eq.5) then call norm5(ip,ja,a,h,g,su,sm,gm,u,um,uc,del,delm, + delc,adel,hdel,b,iequv,z,rp,p,dl,unorm,enorm,bnorm, 1 ddnew,dnorm) else call norm1(ip,ja,a,gm,u,del,adel,b,iequv,z, + unorm,enorm,bnorm,ddnew,dnorm) endif c relerr=1.0d0 if(unorm.ne.0.0d0) relerr=enorm/unorm if(unorm+enorm.le.0.0d0) relerr=0.0d0 rp(53)=bnorm rp(54)=relerr rp(60)=ddnew c c initialization c if(isw.le.0) then b20=bnorm**2 bd0=ddnew*2.0d0 d20=dnorm**2 eps=1.0d2*ceps(ibit) tol=1.d-2 snew=0.0d0 sleft=0.0d0 sright=0.0d0 ksw=0 dnew=ddnew bold=bnorm if(bold.eq.0.0d0) bold=eps step=rp(52) ratio=rp(57) step=step/(step+(1.0d0-step)*ratio/100.0d0) if(dnew.lt.0.0d0.and.d20.gt.0.0d0) + step=dmin1(step,-dnew/d20) frac=0.75d0 if(iprob.eq.2) then step0=stepmx(nvf,del,u,bdlwr,bdupr) if(step0.lt.1.0d0) step=dmin1(step,frac*step0) else if(iprob.eq.3) then rlsv=rp(21) else if(iprob.eq.4) then rlsv=rp(21) rllwr=rp(4) rlupr=rp(5) delta=rp(72) if(delta.lt.0.0d0) then step0=(rllwr-rlsv)/delta if(step0.lt.1.0d0) step=dmin1(step,frac*step0) else if(delta.gt.0.0d0) then step0=(rlupr-rlsv)/delta if(step0.lt.1.0d0) step=dmin1(step,frac*step0) endif do i=1,nvf umsv(i)=um(i) enddo else if(iprob.eq.5) then step0=stepmx(nvf,delc,uc,bdlwr,bdupr) if(step0.lt.1.0d0) step=dmin1(step,frac*step0) do i=1,nvf umsv(i)=um(i) ucsv(i)=uc(i) enddo endif do i=1,nvf usv(i)=u(i) enddo isw=1 else c c the case isw > 0 c isw=isw+1 sold=snew snew=rp(52) dold=dnew dnew=ddnew relres=bnorm/rp(58) rp(56)=relres rp(57)=bnorm/bold c if(sright.le.0.0d0) then sright=snew if(dnew.le.0.0d0) ksw=1 else if(dnew.gt.0.0d0.or.ksw.eq.1) then sright=snew else sleft=snew endif c c sufficient decrease c al=(sright-sleft)/2.0d0 q1=(1.0d0-eps*snew)*bold c** qq=amax1(b20+snew*bd0+snew**2*d20,0.0e0) c** q2=bold-eps*(sqrt(b20)-sqrt(qq)) if(al.le.tol) isw=-1 if(bnorm.le.q1) isw=-1 if(dmin1(relerr,relres).le.eps) isw=-1 if(isw.eq.-1) return c step=(sleft+sright)/2.0d0 if(dold.ne.dnew) then qq=snew-dnew*(snew-sold)/(dnew-dold) c c move towards middle of interval c al2=al**2 if(dmax1(qq-sleft,sright-qq).gt.al*(2.0d0-al2)) + qq=qq+(step-qq)*dmax1(al2,tol) c c if in interval, accept (modified) secant step c if(dmax1(qq-sleft,sright-qq).lt.al*(2.0d0-tol)) step=qq endif endif rp(52)=step c c update solution with current step c delta=rp(72) if(iprob.eq.3) then rp(21)=rlsv+step*delta else if(iprob.eq.4) then rp(21)=rlsv+step*delta do i=1,nvf um(i)=umsv(i)+step*delm(i) enddo else if(iprob.eq.5) then do i=1,nvf um(i)=umsv(i)+step*delm(i) uc(i)=ucsv(i)+step*delc(i) enddo endif do i=1,nvf u(i)=usv(i)+step*del(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function stepmx(nvf,del,u,bdlwr,bdupr) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + u(*),del(*),bdlwr(*),bdupr(*) c c compute maximum stepmx for interior point c stepmx=1.0d0 do i=1,nvf if(del(i).lt.0.0d0) then stepmx=dmin1((bdlwr(i)-u(i))/del(i),stepmx) else if(del(i).gt.0.0d0) then stepmx=dmin1((bdupr(i)-u(i))/del(i),stepmx) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm1(ip,ja,a,gm,u,del,adel,b,iequv,z, + unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iequv(*),ip(100) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*) c c compute norms -- iprob=1 c nvf=ip(2) ispd=ip(8) c call mtxml0(nvf,ja,a,del,adel,iequv,z,ispd) unorm=dl2nrm(nvf,u,gm,1) enorm=dl2nrm(nvf,del,gm,1) bnorm=dl2nrm(nvf,b,gm,-1) ddnew=-dl2ip(nvf,b,adel,gm,-1) dnorm=dl2nrm(nvf,adel,gm,-1) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm2(ip,ja,a,gm,u,del,adel,b,iequv,z,rp, + bdlwr,bdupr,isw,itnum,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iequv(*),ip(100) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*),rp(100), 1 bdlwr(*),bdupr(*) c c compute norms -- iprob=2 c nvf=ip(2) ispd=ip(8) rmu=rp(63) rmu0=rmu c** if(itnum.eq.1.and.isw.eq.0) rmu0=rp(64) if(rmu.ne.rmu0) then iqptr=ja(nvf+1)-1+nvf do i=1,nvf uu=0.0d0 if(u(i).gt.bdlwr(i)) then uu=uu+(rmu-rmu0)/(u(i)-bdlwr(i))**2 endif if(u(i).lt.bdupr(i)) then uu=uu+(rmu-rmu0)/(u(i)-bdupr(i))**2 endif ii=ja(iqptr+i) if(iequv(i).eq.i) a(ii)=a(ii)+uu*gm(i) enddo endif c call mtxml0(nvf,ja,a,del,adel,iequv,z,ispd) unorm=dl2nrm(nvf,u,gm,1) enorm=dl2nrm(nvf,del,gm,1) bnorm=dl2nrm(nvf,b,gm,-1) ddnew=-dl2ip(nvf,b,adel,gm,-1) dnorm=dl2nrm(nvf,adel,gm,-1) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm3(ip,ja,a,gm,u,del,adel,b,iequv,z,rp, + p,d,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iequv(*),ip(100) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*),rp(100), 1 p(*),d(*) c c compute norms -- iprob=3 c nvf=ip(2) ispd=ip(8) rl=rp(21) scale=dsqrt(rp(68)) scleqn=rp(67)*scale thetal=rp(69)*scale thetar=rp(70)*scale delta=rp(72) drdrl=rp(73) c call mtxml0(nvf,ja,a,del,adel,iequv,z,ispd) c unorm=dl2nrm(nvf,u,gm,1) enorm=dl2nrm(nvf,del,gm,1) bnorm=dl2nrm(nvf,b,gm,-1) ddnew=-dl2ip(nvf,b,adel,gm,-1) dnorm=dl2nrm(nvf,adel,gm,-1) c bd=dl2ip(nvf,b,d,gm,-1) ad=dl2ip(nvf,adel,d,gm,-1)*delta dd=dl2nrm(nvf,d,gm,-1)*dabs(delta) pdel=rl2ip(nvf,p,del) c ss=thetar*(pdel+drdrl*delta)+thetal*delta ddnew=ddnew+ss*scleqn+bd*delta dmax=dmax1(dnorm,dd,dabs(ss)) if(dmax.gt.0.0d0) dnorm=dmax*dsqrt((dnorm/dmax)**2 + +(dd/dmax)**2-2.0d0*ad/dmax**2+(ss/dmax)**2) c umax=dmax1(dabs(rl),unorm) if(umax.gt.0.0d0) unorm=umax*dsqrt((unorm/umax)**2 + +(rl/umax)**2) c emax=dmax1(dabs(delta),enorm) if(emax.gt.0.0d0) enorm=emax*dsqrt((enorm/emax)**2 + +(delta/emax)**2) c bmax=dmax1(dabs(scleqn),bnorm) if(bmax.gt.0.0d0) bnorm=bmax*dsqrt((bnorm/bmax)**2 + +(scleqn/bmax)**2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm4(ip,ja,a,h,gm,u,um,del,delm,adel,hdel, + b,iequv,z,rp,p,d,dl,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iequv(*),ip(100) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*),rp(100), 1 p(*),d(*),h(*),hdel(*),dl(*),um(*),delm(*) c c compute norms -- iprob=4 c nvf=ip(2) ispd=ip(8) scleqn=rp(67) seqdot=rp(74) delta=rp(72) rl=rp(21) c c matrix multiplies c call mtxml0(nvf,ja,h,del,hdel,iequv,z,1) jspd=1 if(ispd.ne.1) jspd=-1 call mtxml0(nvf,ja,a,delm,adel,iequv,z,jspd) do i=1,nvf hdel(i)=hdel(i)+adel(i)-delta*dl(i) enddo call mtxml0(nvf,ja,a,del,adel,iequv,z,ispd) do i=1,nvf adel(i)=adel(i)-delta*d(i) enddo c unorm=dl2nrm(nvf,u,gm,1) umnorm=dl2nrm(nvf,um,gm,1) umax=dmax1(dabs(rl),unorm,umnorm) if(umax.gt.0.0d0) unorm=umax*dsqrt((rl/umax)**2 + +(unorm/umax)**2+(umnorm/umax)**2) c enorm=dl2nrm(nvf,del,gm,1) emnorm=dl2nrm(nvf,delm,gm,1) emax=dmax1(dabs(delta),enorm,emnorm) if(emax.gt.0.0d0) enorm=emax*dsqrt((delta/emax)**2 + +(enorm/emax)**2+(emnorm/emax)**2) c bnorm=dl2nrm(nvf,b,gm,-1) pnorm=dl2nrm(nvf,p,gm,-1) bmax=dmax1(dabs(scleqn),bnorm,pnorm) if(bmax.gt.0.0d0) bnorm=bmax*dsqrt((scleqn/bmax)**2 + +(bnorm/bmax)**2+(pnorm/bmax)**2) c c=-rl2ip(nvf,del,dl)-rl2ip(nvf,delm,d)-seqdot*delta ddnew=-dl2ip(nvf,b,adel,gm,-1) + -dl2ip(nvf,p,hdel,gm,-1)-c*scleqn c dnorm=dl2nrm(nvf,adel,gm,-1) hnorm=dl2nrm(nvf,hdel,gm,-1) dmax=dmax1(dabs(c),dnorm,hnorm) if(dmax.gt.0.0d0) dnorm=dmax*dsqrt((c/dmax)**2 + +(dnorm/dmax)**2+(hnorm/dmax)**2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm5(ip,ja,a,h,g,su,sm,gm,u,um,uc,del,delm, + delc,adel,hdel,b,iequv,z,rp,p,dl,unorm,enorm,bnorm, 1 ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iequv(*),ip(100) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*),rp(100), 1 p(*),uc(*),h(*),delc(*),um(*),delm(*),g(*),hdel(*), 2 dl(*),su(*),sm(*) c c compute norms -- iprob=5 c nvf=ip(2) ispd=ip(8) c c first equation c call mtxml0(nvf,ja,h,del,hdel,iequv,z,1) jspd=1 if(ispd.ne.1) jspd=-1 call mtxml0(nvf,ja,a,delm,adel,iequv,z,jspd) do i=1,nvf hdel(i)=hdel(i)+adel(i) enddo call mtxml0(nvf,ja,su,delc,adel,iequv,z,0) do i=1,nvf hdel(i)=hdel(i)+adel(i) enddo dmnorm=dl2nrm(nvf,hdel,gm,-1) umip=dl2ip(nvf,p,hdel,gm,-1) umnorm=dl2nrm(nvf,um,gm,1) emnorm=dl2nrm(nvf,delm,gm,1) bmnorm=dl2nrm(nvf,p,gm,-1) c c second equation c call mtxml0(nvf,ja,sm,delc,hdel,iequv,z,0) call mtxml0(nvf,ja,a,del,adel,iequv,z,ispd) do i=1,nvf adel(i)=adel(i)+hdel(i) enddo dnorm=dl2nrm(nvf,adel,gm,-1) uip=dl2ip(nvf,b,adel,gm,-1) unorm=dl2nrm(nvf,u,gm,1) enorm=dl2nrm(nvf,del,gm,1) bnorm=dl2nrm(nvf,b,gm,-1) c c third equation c call mtxml0(nvf,ja,g,delc,hdel,iequv,z,1) call mtxml0(nvf,ja,sm,delm,adel,iequv,z,-1) do i=1,nvf hdel(i)=hdel(i)+adel(i) enddo call mtxml0(nvf,ja,su,del,adel,iequv,z,-1) do i=1,nvf hdel(i)=hdel(i)+adel(i) enddo dcnorm=dl2nrm(nvf,hdel,gm,-1) ucip=dl2ip(nvf,dl,hdel,gm,-1) ucnorm=dl2nrm(nvf,uc,gm,1) ecnorm=dl2nrm(nvf,delc,gm,1) bcnorm=dl2nrm(nvf,dl,gm,-1) c umax=dmax1(ucnorm,unorm,umnorm) if(umax.gt.0.0d0) unorm=umax*dsqrt((ucnorm/umax)**2 + +(unorm/umax)**2+(umnorm/umax)**2) c emax=dmax1(ecnorm,enorm,emnorm) if(emax.gt.0.0d0) enorm=emax*dsqrt((ecnorm/emax)**2 + +(enorm/emax)**2+(emnorm/emax)**2) c bmax=dmax1(bcnorm,bnorm,bmnorm) if(bmax.gt.0.0d0) bnorm=bmax*dsqrt((bcnorm/bmax)**2 + +(bnorm/bmax)**2+(bmnorm/bmax)**2) c ddnew=-(uip+umip+ucip) c dmax=dmax1(dcnorm,dnorm,dmnorm) if(dmax.gt.0.0d0) dnorm=dmax*dsqrt((dcnorm/dmax)**2 + +(dnorm/dmax)**2+(dmnorm/dmax)**2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tpickd(ip,rp,u,um,uc,vx,vy,itnode,iequv,ja,a,h,g, + su,sm,b,d,p,dl,gm,z,ipath,jequv,ja0,a0,h0,g0,su0,sm0, 1 nn,gf,del,delm,delc,adel,adelm,hdel,smdelm,smdelc, 2 sudel,sudelc,gdelc,bdlwr,bdupr,isw,itnum,usv,umsv,ucsv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*), 1 iequv(*),ja(*),ipath(4,*),jequv(*),ja0(*) double precision + rp(100),u(*),vx(*),vy(*),a(*),b(*),p(*),gm(*),z(*), 1 usv(*),a0(*),gf(nn,*),del(*),adel(*),h(*),delm(*), 2 bdlwr(*),bdupr(*),d(*),dl(*),h0(*),um(*),umsv(*), 3 hdel(*),adelm(*),uc(*),g(*),g0(*),delc(*),su0(*), 4 smdelm(*),gdelc(*),ucsv(*),su(*),smdelc(*),sm(*), 5 sm0(*),sudel(*),sudelc(*) save ksw,tol,eps,snew,sold,sleft,sright,dnew,dold, + bold,rlsv,b20,bd0,d20,ibit data ibit/0/ c c this routine carries out a bisection c or secant iteration c c isw = 0 initialize c > 0 update c < 0 converged c c compute norms c ntf=ip(1) nvf=ip(2) iprob=iabs(ip(6)) c c compute norms c call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) if(iprob.eq.2) then call mkgmd(ip,itnode,vx,vy,iequv,ipath,z) call norm2p(ip,ja,a,gm,u,del,adel,b,z,ipath, + jequv,ja0,a0,nn,gf,z,rp,iequv,bdlwr,bdupr, 1 isw,itnum,unorm,enorm,bnorm,ddnew,dnorm) else if(iprob.eq.3) then call norm3p(ip,ja,a,gm,u,del,adel,b,z,ipath,jequv,ja0,a0, + nn,gf,rp,p,d,unorm,enorm,bnorm,ddnew,dnorm) else if(iprob.eq.4) then call norm4p(ip,ja,a,h,gm,u,um,del,delm,adel,adelm, + hdel,b,z,ipath,jequv,ja0,a0,h0,nn,gf,rp, 1 p,d,dl,unorm,enorm,bnorm,ddnew,dnorm) else if(iprob.eq.5) then call norm5p(ip,ja,a,h,g,su,sm,gm,u,um,uc,del,delm,delc, + adel,adelm,gdelc,hdel,smdelm,smdelc,sudel,sudelc, 1 b,z,rp,p,dl,ipath,jequv,ja0,a0,h0,g0,su0,sm0, 2 nn,gf,unorm,enorm,bnorm,ddnew,dnorm) else call norm1p(ip,ja,a,gm,u,del,adel,b,z,ipath,jequv, + ja0,a0,nn,gf,unorm,enorm,bnorm,ddnew,dnorm) endif c relerr=1.0d0 if(unorm.ne.0.0d0) relerr=enorm/unorm if(unorm+enorm.le.0.0d0) relerr=0.0d0 rp(53)=bnorm rp(54)=relerr rp(60)=ddnew c c initialization c if(isw.le.0) then b20=bnorm**2 bd0=ddnew*2.0d0 d20=dnorm**2 eps=1.0d2*ceps(ibit) tol=1.d-2 snew=0.0d0 sleft=0.0d0 sright=0.0d0 ksw=0 dnew=ddnew bold=bnorm if(bold.eq.0.0d0) bold=eps step=rp(52) ratio=rp(57) step=step/(step+(1.0d0-step)*ratio/100.0d0) if(dnew.lt.0.0d0.and.d20.gt.0.0d0) + step=dmin1(step,-dnew/d20) frac=0.75d0 if(iprob.eq.2) then step0=stepmx(nvf,del,u,bdlwr,bdupr) if(step0.lt.1.0d0) step=dmin1(step,frac*step0) call exstep(step) else if(iprob.eq.3) then rlsv=rp(21) else if(iprob.eq.4) then rlsv=rp(21) rllwr=rp(4) rlupr=rp(5) delta=rp(72) if(delta.lt.0.0d0) then step0=(rllwr-rlsv)/delta if(step0.lt.1.0d0) step=dmin1(step,frac*step0) else if(delta.gt.0.0d0) then step0=(rlupr-rlsv)/delta if(step0.lt.1.0d0) step=dmin1(step,frac*step0) endif call exstep(step) do i=1,nvf umsv(i)=um(i) enddo else if(iprob.eq.5) then step0=stepmx(nvf,delc,uc,bdlwr,bdupr) if(step0.lt.1.0d0) step=dmin1(step,frac*step0) call exstep(step) do i=1,nvf umsv(i)=um(i) ucsv(i)=uc(i) enddo endif do i=1,nvf usv(i)=u(i) enddo isw=1 else c c the case isw > 0 c isw=isw+1 sold=snew snew=rp(52) dold=dnew dnew=ddnew relres=bnorm/rp(58) rp(56)=relres rp(57)=bnorm/bold c if(sright.le.0.0d0) then sright=snew if(dnew.le.0.0d0) ksw=1 else if(dnew.gt.0.0d0.or.ksw.eq.1) then sright=snew else sleft=snew endif c c sufficient decrease c al=(sright-sleft)/2.0d0 q1=(1.0d0-eps*snew)*bold c** qq=amax1(b20+snew*bd0+snew**2*d20,0.0e0) c** q2=bold-eps*(sqrt(b20)-sqrt(qq)) if(al.le.tol) isw=-1 if(bnorm.le.q1) isw=-1 if(dmin1(relerr,relres).le.eps) isw=-1 if(isw.eq.-1) return c step=(sleft+sright)/2.0d0 if(dold.ne.dnew) then qq=snew-dnew*(snew-sold)/(dnew-dold) c c move towards middle of interval c al2=al**2 if(dmax1(qq-sleft,sright-qq).gt.al*(2.0d0-al2)) + qq=qq+(step-qq)*dmax1(al2,tol) c c if in interval, accept (modified) secant step c if(dmax1(qq-sleft,sright-qq).lt.al*(2.0d0-tol)) step=qq endif endif rp(52)=step c c update solution with current step c delta=rp(72) if(iprob.eq.3) then rp(21)=rlsv+step*delta else if(iprob.eq.4) then rp(21)=rlsv+step*delta do i=1,nvf um(i)=umsv(i)+step*delm(i) enddo else if(iprob.eq.5) then do i=1,nvf um(i)=umsv(i)+step*delm(i) uc(i)=ucsv(i)+step*delc(i) enddo endif do i=1,nvf u(i)=usv(i)+step*del(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm1p(ip,ja,a,gm,u,del,adel,b,z,ipath, + jequv,ja0,a0,nn,gf,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(4,*),jequv(*),ja0(*) double precision + u(*),a(*),b(*),gm(*),z(*),a0(*),gf(nn,*), 1 t(10),del(*),adel(*) c c compute norms -- iprob=-1 c nvf=ip(2) ispd=ip(8) newnvf=ip(32) nvv=ip(34) nvi=ip(36) c nproc=ip(49) irgn=ip(50) iin=1 iout=iin+2*nn icnt=iout+2*nn ioff=icnt+nproc c c compute adu c call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + del,adel,z,ispd) ii=ipath(1,irgn)-1 do i=1,nvv gf(ii+i,1)=adel(i) gf(ii+i,2)=-del(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adel,z,ispd,1) c c form inner products for line search/convergence c t(1)=dl2ip(newnvf,adel,adel,gm,-1) t(2)=dl2ip(newnvf,adel,b,gm,-1) t(3)=dl2ip(newnvf,b,b,gm,-1) t(4)=dl2ip(newnvf,del,del,gm,1) t(5)=dl2ip(newnvf,u,u,gm,1) c call pl2ip(t,5) c dnorm=dsqrt(t(1)) ddnew=-t(2) bnorm=dsqrt(t(3)) enorm=dsqrt(t(4)) unorm=dsqrt(t(5)) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm2p(ip,ja,a,gm,u,del,adel,b,z,ipath, + jequv,ja0,a0,nn,gf,gmd,rp,iequv,bdlwr,bdupr, 1 isw,itnum,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),iequv(*),ja(*),ipath(4,*),jequv(*),ja0(*) double precision + rp(100),u(*),a(*),b(*),gm(*),gmd(*),z(*),a0(*),gf(nn,*), 1 t(10),del(*),adel(*),bdlwr(*),bdupr(*) c c compute norms -- iprob=-2 c nvf=ip(2) ispd=ip(8) newnvf=ip(32) nvv=ip(34) nvi=ip(36) c nproc=ip(49) irgn=ip(50) c iin=1 iout=iin+2*nn icnt=iout+2*nn ioff=icnt+nproc c c compute adu c rmu=rp(21) rmu0=rmu c** if(itnum.eq.1.and.isw.eq.0) rmu0=rp(31) if(rmu.ne.rmu0) then iqptr=ja(nvf+1)-1+nvf do i=1,nvf uu=0.0d0 if(u(i).gt.bdlwr(i)) then uu=uu+(rmu-rmu0)/(u(i)-bdlwr(i))**2 endif if(u(i).lt.bdupr(i)) then uu=uu+(rmu-rmu0)/(u(i)-bdupr(i))**2 endif ii=ja(iqptr+i) if(iequv(i).eq.i) a(ii)=a(ii)+uu*gm(i) enddo c c now do interface points c do i=1,nvv uu=0.0d0 if(u(i).gt.bdlwr(i)) then uu=uu+(rmu-rmu0)/(u(i)-bdlwr(i))**2 endif if(u(i).lt.bdupr(i)) then uu=uu+(rmu-rmu0)/(u(i)-bdupr(i))**2 endif ii=i+ipath(1,irgn)-1 a0(ii)=a0(ii)+uu*gmd(ii) enddo endif c c compute adu c call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + del,adel,z,ispd) ii=ipath(1,irgn)-1 do i=1,nvv gf(ii+i,1)=adel(i) gf(ii+i,2)=-del(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adel,z,ispd,1) c c form inner products for line search/convergence c t(1)=dl2ip(newnvf,adel,adel,gm,-1) t(2)=dl2ip(newnvf,adel,b,gm,-1) t(3)=dl2ip(newnvf,b,b,gm,-1) t(4)=dl2ip(newnvf,del,del,gm,1) t(5)=dl2ip(newnvf,u,u,gm,1) c call pl2ip(t,5) c dnorm=dsqrt(t(1)) ddnew=-t(2) bnorm=dsqrt(t(3)) enorm=dsqrt(t(4)) unorm=dsqrt(t(5)) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm3p(ip,ja,a,gm,u,del,adel,b,z,ipath,jequv,ja0,a0, + nn,gf,rp,p,d,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(4,*),jequv(*),ja0(*) double precision + rp(100),u(*),a(*),b(*),p(*),gm(*),z(*),d(*), 1 a0(*),gf(nn,*),t(10),del(*),adel(*) c c compute norms -- iprob=-3 c nvf=ip(2) ispd=ip(8) newnvf=ip(32) nvv=ip(34) nvi=ip(36) c rl=rp(21) scale=dsqrt(rp(68)) scleqn=rp(67)*scale thetal=rp(69)*scale thetar=rp(70)*scale delta=rp(72) drdrl=rp(73) c nproc=ip(49) irgn=ip(50) c iin=1 iout=iin+2*nn icnt=iout+2*nn ioff=icnt+nproc c c compute adu c call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + del,adel,z,ispd) ii=ipath(1,irgn)-1 do i=1,nvv gf(ii+i,1)=adel(i) gf(ii+i,2)=-del(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adel,z,ispd,1) c c form inner products for line search/convergence c t(1)=dl2ip(newnvf,adel,adel,gm,-1) t(2)=dl2ip(newnvf,adel,b,gm,-1) t(3)=dl2ip(newnvf,b,b,gm,-1) t(4)=dl2ip(newnvf,del,del,gm,1) t(5)=dl2ip(newnvf,u,u,gm,1) t(6)=dl2ip(newnvf,b,d,gm,-1) t(7)=dl2ip(newnvf,adel,d,gm,-1) t(8)=dl2ip(newnvf,d,d,gm,-1) t(9)=rl2ip(newnvf,p,del) call pl2ip(t,9) c dnorm=dsqrt(t(1)) ddnew=-t(2) bnorm=dsqrt(t(3)) enorm=dsqrt(t(4)) unorm=dsqrt(t(5)) c bd=t(6) ad=t(7)*delta dd=dsqrt(t(8))*dabs(delta) pdel=t(9) c ss=thetar*(pdel+drdrl*delta)+thetal*delta ddnew=ddnew+ss*scleqn+bd*delta dmax=dmax1(dnorm,dd,dabs(ss)) if(dmax.gt.0.0d0) dnorm=dmax*dsqrt((dnorm/dmax)**2 + +(dd/dmax)**2-2.0d0*ad/dmax**2+(ss/dmax)**2) c umax=dmax1(dabs(rl),unorm) if(umax.gt.0.0d0) unorm=umax*dsqrt((unorm/umax)**2 + +(rl/umax)**2) c emax=dmax1(dabs(delta),enorm) if(emax.gt.0.0d0) enorm=emax*dsqrt((enorm/emax)**2 + +(delta/emax)**2) c bmax=dmax1(dabs(scleqn),bnorm) if(bmax.gt.0.0d0) bnorm=bmax*dsqrt((bnorm/bmax)**2 + +(scleqn/bmax)**2) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm4p(ip,ja,a,h,gm,u,um,del,delm,adel,adelm, + hdel,b,z,ipath,jequv,ja0,a0,h0,nn,gf,rp, 1 p,d,dl,unorm,enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),ipath(4,*),jequv(*),ja0(*) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*),rp(100), 1 p(*),d(*),h(*),hdel(*),dl(*),um(*),delm(*),a0(*), 2 h0(*),gf(nn,*),t(20),adelm(*) c c compute norms -- iprob=-4 c nvf=ip(2) ispd=ip(8) newnvf=ip(32) nvv=ip(34) nvi=ip(36) scleqn=rp(67) seqdot=rp(74) delta=rp(72) rl=rp(21) c nproc=ip(49) irgn=ip(50) c num=5 iin=1 iout=iin+num*nn icnt=iout+num*nn ioff=icnt+nproc c c matrix multiplies c ii=ipath(1,irgn)-1 call blkmlt(irgn,nproc,newnvf,nvf,ja,h,ipath,ja0,h0, + del,hdel,z,1) jspd=1 if(ispd.ne.1) jspd=-1 call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + delm,adelm,z,jspd) call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + del,adel,z,ispd) c do i=1,nvv gf(ii+i,1)=hdel(i) gf(ii+i,2)=-del(i) gf(ii+i,3)=adelm(i) gf(ii+i,4)=-delm(i) gf(ii+i,5)=adel(i) enddo call exbdy(ipath,gf,nn,num,z(iin),z(iout),z(icnt),z(ioff)) c call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,1),hdel,z,1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),adelm,z,jspd,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,5),adel,z,ispd,1) c do i=1,newnvf hdel(i)=hdel(i)+adelm(i)-delta*dl(i) adel(i)=adel(i)-delta*d(i) enddo c t(1)=dl2ip(newnvf,u,u,gm,1) t(2)=dl2ip(newnvf,um,um,gm,1) t(3)=dl2ip(newnvf,del,del,gm,1) t(4)=dl2ip(newnvf,delm,delm,gm,1) t(5)=dl2ip(newnvf,b,b,gm,-1) t(6)=dl2ip(newnvf,p,p,gm,-1) t(7)=rl2ip(newnvf,del,dl) t(8)=rl2ip(newnvf,delm,d) t(9)=dl2ip(newnvf,b,adel,gm,-1) t(10)=dl2ip(newnvf,p,hdel,gm,-1) t(11)=dl2ip(newnvf,adel,adel,gm,-1) t(12)=dl2ip(newnvf,hdel,hdel,gm,-1) c call pl2ip(t,12) c unorm=dsqrt(t(1)) umnorm=dsqrt(t(2)) enorm=dsqrt(t(3)) emnorm=dsqrt(t(4)) bnorm=dsqrt(t(5)) pnorm=dsqrt(t(6)) c=-t(7)-t(8)-seqdot*delta ddnew=-t(9)-t(10)-c*scleqn dnorm=dsqrt(t(11)) hnorm=dsqrt(t(12)) c umax=dmax1(dabs(rl),unorm,umnorm) if(umax.gt.0.0d0) unorm=umax*dsqrt((rl/umax)**2 + +(unorm/umax)**2+(umnorm/umax)**2) c emax=dmax1(dabs(delta),enorm,emnorm) if(emax.gt.0.0d0) enorm=emax*dsqrt((delta/emax)**2 + +(enorm/emax)**2+(emnorm/emax)**2) c bmax=dmax1(dabs(scleqn),bnorm,pnorm) if(bmax.gt.0.0d0) bnorm=bmax*dsqrt((scleqn/bmax)**2 + +(bnorm/bmax)**2+(pnorm/bmax)**2) c dmax=dmax1(dabs(c),dnorm,hnorm) if(dmax.gt.0.0d0) dnorm=dmax*dsqrt((c/dmax)**2 + +(dnorm/dmax)**2+(hnorm/dmax)**2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine norm5p(ip,ja,a,h,g,su,sm,gm,u,um,uc,del,delm,delc, + adel,adelm,gdelc,hdel,smdelm,smdelc,sudel,sudelc,b,z,rp, 1 p,dl,ipath,jequv,ja0,a0,h0,g0,su0,sm0,nn,gf,unorm, 2 enorm,bnorm,ddnew,dnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),ipath(4,*),jequv(*),ja0(*) double precision + a(*),b(*),del(*),adel(*),gm(*),u(*),z(*),rp(100), 1 p(*),uc(*),h(*),delc(*),um(*),delm(*),g(*),hdel(*), 2 dl(*),adelm(*),gdelc(*),smdelm(*),a0(*),h0(*),su(*), 3 g0(*),gf(nn,*),t(15),su0(*),smdelc(*),sm(*),sm0(*), 4 sudel(*),sudelc(*) c c compute norms -- iprob=-5 c nvf=ip(2) ispd=ip(8) newnvf=ip(32) nvv=ip(34) nvi=ip(36) c nproc=ip(49) irgn=ip(50) c num=11 iin=1 iout=iin+num*nn icnt=iout+num*nn ioff=icnt+nproc c c matrix multiplies c ii=ipath(1,irgn)-1 jspd=1 if(ispd.ne.1) jspd=-1 c call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + del,adel,z,ispd) call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + delm,adelm,z,jspd) call blkmlt(irgn,nproc,newnvf,nvf,ja,h,ipath,ja0,h0, + del,hdel,z,1) call blkmlt(irgn,nproc,newnvf,nvf,ja,g,ipath,ja0,g0, + delc,gdelc,z,1) call blkmlt(irgn,nproc,newnvf,nvf,ja,sm,ipath,ja0,sm0, + delc,smdelc,z,0) call blkmlt(irgn,nproc,newnvf,nvf,ja,sm,ipath,ja0,sm0, + delm,smdelm,z,-1) call blkmlt(irgn,nproc,newnvf,nvf,ja,su,ipath,ja0,su0, + delc,sudelc,z,0) call blkmlt(irgn,nproc,newnvf,nvf,ja,su,ipath,ja0,su0, + delm,sudel,z,-1) c do i=1,nvv gf(ii+i,1)=hdel(i) gf(ii+i,2)=-del(i) gf(ii+i,3)=adelm(i) gf(ii+i,4)=-delm(i) gf(ii+i,5)=adel(i) gf(ii+i,6)=gdelc(i) gf(ii+i,7)=-delc(i) gf(ii+i,8)=smdelm(i) gf(ii+i,9)=smdelc(i) gf(ii+i,10)=sudel(i) gf(ii+i,11)=sudelc(i) enddo call exbdy(ipath,gf,nn,num,z(iin),z(iout),z(icnt),z(ioff)) c call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,5),adel,z,ispd,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),adelm,z,jspd,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,1),hdel,z,1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,g0,gf(1,7),gf(1,6),gdelc,z,1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,sm0,gf(1,7),gf(1,9),smdelc,z,0,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,sm0,gf(1,4),gf(1,8),smdelm,z,-1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,su0,gf(1,7),gf(1,11),sudelc,z,0,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,su0,gf(1,2),gf(1,10),sudel,z,-1,1) c do i=1,nvf hdel(i)=hdel(i)+adelm(i)+sudelc(i) adel(i)=adel(i)+smdelc(i) gdelc(i)=gdelc(i)+smdelm(i)+sudel(i) enddo c t(1)=dl2ip(newnvf,hdel,hdel,gm,-1) t(2)=dl2ip(newnvf,adel,adel,gm,-1) t(3)=dl2ip(newnvf,gdelc,gdelc,gm,-1) t(4)=dl2ip(newnvf,p,hdel,gm,-1) t(5)=dl2ip(newnvf,b,adel,gm,-1) t(6)=dl2ip(newnvf,dl,gdelc,gm,-1) t(7)=dl2ip(newnvf,um,um,gm,1) t(8)=dl2ip(newnvf,u,u,gm,1) t(9)=dl2ip(newnvf,uc,uc,gm,1) t(10)=dl2ip(newnvf,delm,delm,gm,1) t(11)=dl2ip(newnvf,del,del,gm,1) t(12)=dl2ip(newnvf,delc,delc,gm,1) t(13)=dl2ip(newnvf,p,p,gm,-1) t(14)=dl2ip(newnvf,b,b,gm,-1) t(15)=dl2ip(newnvf,dl,dl,gm,-1) c call pl2ip(t,15) c dmnorm=dsqrt(t(1)) dnorm=dsqrt(t(2)) dcnorm=dsqrt(t(3)) umip=t(4) uip=t(5) ucip=t(6) umnorm=dsqrt(t(7)) unorm=dsqrt(t(8)) ucnorm=dsqrt(t(9)) emnorm=dsqrt(t(10)) enorm=dsqrt(t(11)) ecnorm=dsqrt(t(12)) bmnorm=dsqrt(t(13)) bnorm=dsqrt(t(14)) bcnorm=dsqrt(t(15)) c c umax=dmax1(ucnorm,unorm,umnorm) if(umax.gt.0.0d0) unorm=umax*dsqrt((ucnorm/umax)**2 + +(unorm/umax)**2+(umnorm/umax)**2) c emax=dmax1(ecnorm,enorm,emnorm) if(emax.gt.0.0d0) enorm=emax*dsqrt((ecnorm/emax)**2 + +(enorm/emax)**2+(emnorm/emax)**2) c bmax=dmax1(bcnorm,bnorm,bmnorm) if(bmax.gt.0.0d0) bnorm=bmax*dsqrt((bcnorm/bmax)**2 + +(bnorm/bmax)**2+(bmnorm/bmax)**2) c ddnew=-(uip+umip+ucip) c dmax=dmax1(dcnorm,dnorm,dmnorm) if(dmax.gt.0.0d0) dnorm=dmax*dsqrt((dcnorm/dmax)**2 + +(dnorm/dmax)**2+(dmnorm/dmax)**2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ctheta(ip,rp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100) double precision + rp(100) c c compute normalization equation parameters c iflag=0 itask=ip(9) c c rtrgt=rp(2) rltrgt=rp(1) rstrt=rp(27) rlstrt=rp(26) scale=rp(68) c c compute theta c if(itask.le.1) then rl0dot=rp(33) r0dot=rp(34) if(rtrgt.eq.rstrt) then if(rl0dot.eq.0.0d0) iflag=1 theta=0.0d0 else if(rltrgt.eq.rlstrt) then if(r0dot.eq.0.0d0) iflag=1 theta=2.0d0 else iflag=1 theta=1.0d0 endif rl0=rp(31) r0=rp(32) thetal=(2.0d0-theta)*rl0dot thetar=theta*r0dot sigma=thetar*(rtrgt-r0)+thetal*(rltrgt-rl0) seqdot=thetar*r0dot+thetal*rl0dot rp(69)=thetal rp(70)=thetar rp(71)=sigma rp(74)=seqdot if(scale.eq.0.0d0) rp(68)=1.0d0 else if(itask.ge.3.and.itask.le.7) then c c initialize for changing parameters or functional c if(itask.le.4) then rp(68)=1.0d0 rp(21)=rltrgt rp(22)=rtrgt rp(23)=1.0d0 rp(24)=1.0d0 c rp(31)=rltrgt rp(32)=rtrgt rp(33)=1.0d0 rp(34)=1.0d0 endif rl0dot=rp(33) r0dot=rp(34) if(itask.eq.3.or.itask.eq.5) then if(rl0dot.eq.0.0d0) iflag=1 theta=0.0d0 else if(itask.eq.4.or.itask.eq.6) then if(r0dot.eq.0.0d0) iflag=1 theta=2.0d0 else if(itask.eq.7) then if(r0dot.eq.0.0d0.and.rl0dot.eq.0.0d0) iflag=1 theta=1.0d0 endif c thetal=(2.0d0-theta)*rl0dot thetar=theta*r0dot seqdot=thetar*r0dot+thetal*rl0dot rp(69)=thetal rp(70)=thetar rp(71)=0.0d0 rp(74)=seqdot if(scale.eq.0.0d0) rp(68)=1.0d0 else rp(69)=0.0d0 rp(70)=0.0d0 rp(71)=0.0d0 rp(74)=0.0d0 rp(68)=1.0d0 iflag=1 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine updpth(path,isw,itype,rp) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + path(101,*),rp(100) c c update continutaion path c isw=1 initialize c =0 replace last entry c =-1 append to end of list c c itype=1 initialize c =2 limit point c =3 adaptive (itask =5,6,7) c =4 regular point c =5 mpi solution c =6 bifurcation point c =7 start of new branch (set in fixpth) c if(isw.eq.1) then num=1 do i=1,101 do j=1,6 path(i,j)=0.0d0 enddo enddo else if(isw.eq.0) then num=idint(path(101,1)) else num=idint(path(101,1)) if(num.ge.100) then do i=1,100 do j=1,6 path(i,j)=path(i+1,j) enddo enddo num=100 else num=num+1 endif endif path(num,1)=rp(21) path(num,2)=rp(22) path(num,3)=rp(23) path(num,4)=rp(24) path(num,5)=rp(25) if(isw.eq.0) then jtype=idint(path(num,6)) if(jtype.ne.7) path(num,6)=dfloat(itype) else path(num,6)=dfloat(itype) endif path(101,1)=dfloat(num) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine updtm(path,isw,itype,rp) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + path(101,*),rp(100) c c update time history c c isw=1 initialize c =0 replace last entry c =-1 append to end of list c if(isw.eq.1) then num=1 else if(isw.eq.0) then num=idint(path(101,1)) else num=idint(path(101,1)) if(num.ge.100) then do i=1,100 do j=1,6 path(i,j)=path(i+1,j) enddo enddo num=100 else num=num+1 endif endif path(num,1)=rp(46) path(num,2)=rp(47) path(num,3)=rp(50) path(num,4)=0.0d0 path(num,5)=0.0d0 path(num,6)=dfloat(itype) path(101,1)=dfloat(num) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine updip(path,isw,itype,rp,ip) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100) double precision + path(101,*),rp(100) c c update continutaion path c isw=1 initialize c =0 replace last entry c =-1 append to end of list c c itype=1 initialization c =2 regular solve c =3 switch lambda (itask=8, iprob=4) c =4 parallel solve c if(isw.eq.1) then num=1 do i=1,101 do j=1,6 path(i,j)=0.0d0 enddo enddo else if(isw.eq.0) then num=idint(path(101,1)) else num=idint(path(101,1)) if(num.ge.100) then do i=1,100 do j=1,6 path(i,j)=path(i+1,j) enddo enddo num=100 else num=num+1 endif endif path(num,1)=rp(63) path(num,2)=rp(22) if(itype.eq.3) then path(num,3)=dfloat(ip(39)) else path(num,3)=dfloat(ip(2)) endif path(num,4)=0.0d0 path(num,5)=0.0d0 path(num,6)=dfloat(itype) if(num.gt.1) then jsw=0 if(path(num-1,1).ne.path(num,1)) jsw=1 if(path(num-1,3).ne.path(num,3)) jsw=1 if(path(num-1,6).ne.path(num,6)) jsw=1 if(jsw.eq.0) then num=num-1 path(num,2)=rp(22) endif endif path(101,1)=dfloat(num) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine hist1(hist,itnum,bnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + hist(22) c c update history array c mxhist=20 if(itnum.le.0) then hist(mxhist+2)=bnorm else if(itnum.gt.mxhist) then do i=1,mxhist-1 hist(i)=hist(i+1) enddo hist(mxhist)=bnorm else hist(itnum)=bnorm endif if(itnum.ge.0) hist(mxhist+1)=dfloat(itnum) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine hist2(hist,rp,iadapt,nvf) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100),hist(22,*) c c hist(*, 1) = nvf c hist(*, 2) = iadapt (color indictaor) c hist(*, 3) = error in h1 norm c hist(*, 4) = error in l2 norm c hist(*, 5) = c hist(*, 6) = c hist(*, 7) = mg convergence history -- main call c hist(*, 8) = mg convergence history -- block g.e. call c hist(*, 9) = mg convregence history -- block g.e. call c hist(*,10) = mg convregence history -- block g.e. call c hist(*,11) = newton convergence history -- residual norm c hist(*,12) = newton convergence history -- increment norm c hist(*,13) = c hist(*,14) = singular vector convergence history c hist(*,15) = bisection convergence history -- upper bound c hist(*,16) = bisection convergence history -- lower bound c hist(*,17) = c hist(*,18) = c hist(*,19) = c hist(*,20) = c hist(*,21) = c hist(*,22) = c hist(*,23) = spectral biscetion --- inverse iteration c hist(*,24) = spectral biscetion --- inverse iteration c hist(*,25) = spectral biscetion --- inverse iteration c hist(*,26) = spectral biscetion --- inverse iteration c hist(*,27) = c hist(*,28) = c hist(*,29) = c hist(*,30) = c c save convergence history c mxhist=20 if(nvf.eq.0) then numhst=20 do j=1,numhst do i=1,mxhist+2 hist(i,j)=0.0d0 enddo enddo return endif num=idint(hist(mxhist+2,1)) if(num.eq.mxhist) then do j=1,6 do i=1,mxhist-1 hist(i,j)=hist(i+1,j) enddo enddo num=mxhist-1 endif c num=num+1 hist(num,1)=dfloat(nvf) hist(num,2)=dfloat(iadapt) hist(num,3)=rp(37) hist(num,4)=rp(39) hist(mxhist+2,1)=dfloat(num) hist(mxhist+2,3)=rp(38) hist(mxhist+2,4)=rp(40) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine hist3(hist,itnum,bnorm,enorm) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + hist(22,*) c c update history array c mxhist=20 if(itnum.le.0) then hist(mxhist+2,1)=bnorm hist(mxhist+2,2)=enorm hist(mxhist+1,2)=dfloat(itnum) else if(itnum.gt.mxhist) then do i=1,mxhist-1 hist(i,1)=hist(i+1,1) hist(i,2)=hist(i+1,2) enddo hist(mxhist,1)=bnorm hist(mxhist,2)=enorm else hist(itnum,1)=bnorm hist(itnum,2)=enorm endif if(itnum.ge.0) hist(mxhist+1,1)=dfloat(itnum) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pstat1(ntf,nproc,pstat,itnode,e,itype) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + e(*),pstat(10,*) save mxstat data mxstat/10/ c c pstat(1, *) -- load balance triangle fraction c pstat(2, *) -- load balance error fraction c pstat(3, *) -- adaptive mesh triangle fraction (mpi) c pstat(4, *) -- adaptive mesh error fraction (mpi) c pstat(5, *) -- triangle fraction c pstat(6, *) -- error fraction c pstat(7, *) -- c pstat(8, *) -- c pstat(9, *) -- c pstat(10,*) -- c if(itype.eq.1) then do i=1,nproc pstat(1,i)=0.0d0 pstat(2,i)=0.0d0 enddo do i=1,ntf k=min0(itnode(4,i),nproc) k=max0(1,k) pstat(1,k)=pstat(1,k)+1.0d0 pstat(2,k)=pstat(2,k)+e(i) enddo do i=1,nproc pstat(3,i)=pstat(1,i) pstat(4,i)=pstat(2,i) pstat(5,i)=pstat(1,i) pstat(6,i)=pstat(2,i) enddo else if(itype.eq.2) then do i=1,nproc pstat(3,i)=0.0d0 pstat(4,i)=0.0d0 enddo do i=1,ntf k=min0(itnode(4,i),nproc) k=max0(1,k) pstat(3,k)=pstat(3,k)+1.0d0 pstat(4,k)=pstat(4,k)+e(i) enddo do i=1,nproc pstat(5,i)=pstat(3,i) pstat(6,i)=pstat(4,i) enddo else do i=1,nproc do j=1,mxstat pstat(j,i)=0.0d0 enddo enddo return endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cequv1(nvf,nbf,ibndry,iequv,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),iequv(*) c c initialize iequv c do i=1,nvf iequv(i)=i enddo c c set up equivalence classes for vertices c do 60 i=1,nbf if(ibndry(4,i).ge.0) go to 60 if(isw.eq.2) then if(ibndry(5,i).eq.0) go to 60 if(iabs(ibndry(5,i)).eq.5) go to 60 endif j=-ibndry(4,i) if(j.lt.i) go to 60 c c mark periodic vertices (vtype=8 have one equivalence) c do 50 mm=1,2 iv=ibndry(mm,i) jv=ibndry(3-mm,j) it=iv 40 it=iequv(it) if(it.eq.jv) go to 50 if(it.ne.iv) go to 40 it=iequv(iv) iequv(iv)=iequv(jv) iequv(jv)=it 50 continue 60 continue c c make all equivalent vertices point at a smallest member c if(isw.eq.0) return do i=1,nvf if(iequv(i).gt.0) then num=1 imin=i next=i 70 next=iequv(next) if(next.ne.i) then imin=min0(imin,next) num=num+1 go to 70 endif last=imin do k=1,num next=iequv(last) iequv(last)=-imin last=next enddo endif enddo do i=1,nvf iequv(i)=-iequv(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),iseed(*),itedge(3,*), 1 vtype(*),elist(500),tlist(500),vlist(500), 2 ibedge(2,*),blist(500) double precision 1 xm(*),ym(*),vx(*),vy(*) c c vtype(i) = 1 internal vertex c vtype(i) = 2 interface vertex with no interface edge c vtype(i) = 3 interface corner with no interface edge c vtype(i) = 4 interface vertex with interface edge c vtype(i) = 5 interface corner with interface edge c vtype(i) = 6 boundary vextex c vtype(i) = 7 boundary corner c vtype(i) = 8 boundary vextex with linked edge c vtype(i) = 9 boundary corner with linked edge c c initailize iseed to seed triangle/edge for vertex i c do i=1,nvf vtype(i)=1 enddo do i=1,nbf if(ibndry(4,i).gt.0) then do k=1,2 vtype(ibndry(k,i))=6 enddo else if(ibndry(4,i).lt.0) then do k=1,2 if(vtype(ibndry(k,i)).ne.6) vtype(ibndry(k,i))=8 enddo else do k=1,2 if(vtype(ibndry(k,i)).eq.1) vtype(ibndry(k,i))=4 enddo endif enddo c c mark interfaces in itedge c call cedge5(nbf,itedge,ibedge,1) c do i=1,ntf iseed(itnode(1,i))=1+4*i iseed(itnode(2,i))=2+4*i iseed(itnode(3,i))=3+4*i enddo c c initialize vtype c do i=1,nvf call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) call tstvty(i,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) enddo c c special dirichlet point c if(idbcpt.gt.0) then if(vtype(idbcpt).eq.8) then vtype(idbcpt)=9 else vtype(idbcpt)=7 endif endif call cedge5(nbf,itedge,ibedge,0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tstvty(i,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3),iv(3), 1 vtype(*),elist(100),tlist(100),vlist(100),corner(9) double precision + xm(*),ym(*),vx(*),vy(*),c(3) save index,corner data index/1,2,3,2,3,1,3,1,2/ data corner/0,0,1,0,1,0,1,0,1/ c c test for vertex type c this version marks all vertices between different parallel c subregions as corners. c if(corner(vtype(i)).eq.1) return c c count interfaces c jcount=0 icount=0 kcount=0 if(vtype(i).le.5) then l2=len+1 else l2=len-1 endif do ll=2,l2 i1=tlist(ll) i2=tlist(ll+1) if(itnode(4,i1).ne.itnode(4,i2)) kcount=kcount+1 if(itnode(5,i1).ne.itnode(5,i2)) then icount=min0(icount+1,3) iv(icount)=ll+1 ke=iabs(elist(ll+1)) if(itedge(index(3,ke),i2).lt.0) jcount=jcount+1 endif enddo c if(vtype(i).eq.1) then if(icount.lt.2.and.kcount.eq.0) return vtype(i)=3 if(icount.eq.2.and.kcount.eq.0) then aa=dabs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(dabs(aa-1.0d0).lt.angmin) vtype(i)=2 endif else if(vtype(i).eq.4) then vtype(i)=5 if(icount.ne.2.or.jcount.ne.2.or.kcount.gt.0) return kt=tlist(iv(1)) ke=iabs(elist(iv(1))) ie1=-itedge(index(3,ke),kt) kt=tlist(iv(2)) ke=iabs(elist(iv(2))) ie2=-itedge(index(3,ke),kt) if(ie1.le.0.or.ie2.le.0) stop 9321 if(ibndry(6,ie1).ne.ibndry(6,ie2)) return if(ibndry(5,ie1).ne.0.and.ibndry(5,ie2).eq.0) return if(ibndry(5,ie1).eq.0.and.ibndry(5,ie2).ne.0) return if(iabs(ibndry(5,ie1)-ibndry(5,ie2)).gt.1) return if(max0(ibndry(3,ie1),ibndry(3,ie2)).gt.0) then if(ibndry(3,ie1).ne.ibndry(3,ie2)) return endif if(ibndry(3,ie1).le.0) then aa=dabs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(dabs(aa-1.0d0).lt.angmin) vtype(i)=4 else iv1=vlist(iv(1)) iv2=vlist(iv(2)) kt=ibndry(3,ie1) call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(kt),ym(kt),theta1,theta2,r,alen) if(dabs(theta2-theta1).le.arcmax) vtype(i)=4 endif else if(vtype(i).eq.6) then vtype(i)=7 if(icount.gt.0.or.kcount.gt.0) return ie1=iabs(tlist(1)) ie2=iabs(tlist(len+1)) if(ibndry(6,ie1).ne.ibndry(6,ie2)) return if(ibndry(4,ie1).ne.ibndry(4,ie2)) return if(max0(ibndry(3,ie1),ibndry(3,ie2)).gt.0) then if(ibndry(3,ie1).ne.ibndry(3,ie2)) return endif if(ibndry(3,ie1).le.0) then aa=dabs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(dabs(aa-1.0d0).lt.angmin) vtype(i)=6 else tol=1.0d-1 iv(1)=vlist(2) iv(2)=vlist(len+1) iv(3)=i do kk=3,len k=vlist(kk) call bari(vx(k),vy(k),vx,vy,iv,c) if(dmin1(c(1),c(2),c(3)).ge.-tol) return enddo kt=ibndry(3,ie1) call arc(vx(iv(1)),vy(iv(1)),vx(iv(2)),vy(iv(2)), + xm(kt),ym(kt),theta1,theta2,r,alen) if(dabs(theta2-theta1).le.arcmax) vtype(i)=6 endif else if(vtype(i).eq.8) then vtype(i)=9 ii=vlist(len+2) if(vtype(ii).eq.9) go to 40 ie1=iabs(tlist(1)) ie2=iabs(tlist(len+1)) it1=tlist(2) it2=tlist(len) len1=elist(len+2) ie3=iabs(tlist(len1+1)) ie4=iabs(tlist(len+2)) it3=tlist(len1) it4=tlist(len+3) if(ibndry(4,ie1).ne.-ie3) go to 40 if(ibndry(4,ie3).ne.-ie1) go to 40 if(ibndry(5,ie1).ne.0.and.ibndry(5,ie2).eq.0) go to 40 if(ibndry(5,ie1).eq.0.and.ibndry(5,ie2).ne.0) go to 40 if(iabs(ibndry(5,ie1)-ibndry(5,ie2)).gt.1) go to 40 if(itnode(4,it1).ne.itnode(4,it3)) kcount=kcount+1 if(itnode(4,it2).ne.itnode(4,it4)) kcount=kcount+1 if(itnode(5,it1).ne.itnode(5,it3)) icount=icount+1 if(itnode(5,it2).ne.itnode(5,it4)) icount=icount+1 if(icount.gt.0.or.kcount.gt.0) go to 40 if(ibndry(4,ie1)*ibndry(4,ie2).le.0) go to 40 if(ibndry(6,ie1).ne.ibndry(6,ie2)) go to 40 if(ibndry(6,ie3).ne.ibndry(6,ie4)) go to 40 if(max0(ibndry(3,ie1),ibndry(3,ie2)).gt.0) then if(ibndry(3,ie1).ne.ibndry(3,ie2)) go to 40 endif if(ibndry(3,ie1).le.0) then aa=dabs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(dabs(aa-1.0d0).lt.angmin) vtype(i)=8 else iv1=vlist(2) iv2=vlist(len+1) kt=ibndry(3,ie1) call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(kt),ym(kt),theta1,theta2,r,alen) if(dabs(theta2-theta1).le.arcmax) vtype(i)=8 endif 40 ii=vlist(len+2) vtype(ii)=vtype(i) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tstvt5(i,itnode,ibndry,itedge, + vtype,ibase,irgn,tlist,elist,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3),iv(3), 1 elist(100),tlist(100),jv(3),jb(3),ity(3),vtype(*) data index/1,2,3,2,3,1,3,1,2/ c c modification of tstvty for interface vertices of type 5 only c c count interfaces c if(vtype(i).ne.5) return if(ibase.le.0) return jcount=0 icount=0 kcount=0 do ll=2,len+1 i1=tlist(ll) i2=tlist(ll+1) if(itnode(4,i1).ne.itnode(4,i2)) then kcount=min0(kcount+1,3) jv(kcount)=ll+1 ke=iabs(elist(ll+1)) jcount=jcount+1 jb(kcount)=-itedge(index(3,ke),i2) ity(kcount)=0 if(itnode(4,i1).eq.irgn) ity(kcount)=1 if(itnode(4,i2).eq.irgn) ity(kcount)=1 endif if(itnode(5,i1).ne.itnode(5,i2)) then icount=min0(icount+1,3) iv(icount)=ll+1 ke=iabs(elist(ll+1)) if(itedge(index(3,ke),i2).lt.0) jcount=jcount+1 endif enddo c if(jcount.ne.2) return if(icount.ge.3) return if(kcount.ne.2) return cc if(ity(1).ne.0.or.ity(2).ne.0) return if(icount.eq.2) then if(iv(1).ne.jv(1)) return if(iv(2).ne.jv(2)) return endif c ie1=jb(1) ie2=jb(2) if(ie1.le.0.or.ie2.le.0) stop 9323 if(ibndry(5,ie1).eq.0.or.ibndry(5,ie2).eq.0) return c it1=iabs(ibndry(5,ie1))/ibase+1 ir1=iabs(ibndry(5,ie1))-(it1-1)*ibase it2=iabs(ibndry(5,ie2))/ibase+1 ir2=iabs(ibndry(5,ie2))-(it2-1)*ibase if(ir1.ne.ir2) return if(it2.gt.it1) then if(it1+1.ne.it2) return if((it1/2)*2.ne.it1) return else if(it2+1.ne.it1) return if((it2/2)*2.ne.it2) return endif vtype(i)=4 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine updhp(i,len,p,q,qual,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*) double precision + qual(*) c c this routine makes a heap with root at vertex i, assuming its c sons are already roots of heaps c k=i if(isw.eq.0.or.k.eq.1) go to 10 kfath=k/2 if(qual(p(k)).gt.qual(p(kfath))) go to 60 c c push c 10 kson=2*k if(kson.gt.len) return if(kson.lt.len) then if(qual(p(kson+1)).gt.qual(p(kson))) kson=kson+1 endif if(qual(p(k)).ge.qual(p(kson))) return itemp=p(k) p(k)=p(kson) p(kson)=itemp q(p(kson))=kson q(p(k))=k k=kson go to 10 c c pull c 50 kfath=k/2 if(kfath.eq.0) return if(qual(p(kfath)).gt.qual(p(k))) return 60 itemp=p(k) p(k)=p(kfath) p(kfath)=itemp q(p(kfath))=kfath q(p(k))=k k=kfath go to 50 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setgr(ntf,nvf,nbf,itnode,ibndry,ja,lenja) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ja(*),index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c construct ja from triangle data c do i=1,lenja ja(i)=0 enddo ja(1)=nvf+2 c c count edges... each edge except for boundary c edges will be counted twice as all the triangles c are processed c do i=1,ntf do j=1,3 kmax=max0(itnode(index(2,j),i),itnode(index(3,j),i)) ja(kmax+1)=ja(kmax+1)+1 enddo enddo do i=1,nbf if(ibndry(4,i).ne.0) then kmax=max0(ibndry(1,i),ibndry(2,i)) ja(kmax+1)=ja(kmax+1)+1 endif enddo c c compute pointers in 1st n+1 locations of ja c do j=1,nvf ja(j+1)=ja(j)+ja(j+1)/2 enddo c do i=1,ntf do 70 j=1,3 kmax=max0(itnode(index(2,j),i),itnode(index(3,j),i)) kmin=min0(itnode(index(2,j),i),itnode(index(3,j),i)) c c check if kmin is already on list for kmax c jmin=ja(kmax) jmax=ja(kmax+1)-1 do jj=jmin,jmax if(ja(jj).eq.0) then ja(jj)=kmin go to 70 else if(ja(jj).eq.kmin) then go to 70 endif enddo 70 continue enddo c c sort indices in decreasing order c do i=1,nvf j1=ja(i)+1 j2=ja(i+1)-1 if(j1.le.j2) then do j=j1,j2 jmax=j-1 do k=j,j2 if(ja(k).gt.ja(jmax)) jmax=k enddo jtemp=ja(j-1) ja(j-1)=ja(jmax) ja(jmax)=jtemp enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setgr1(ntf,nvf,itnode,ja,link,iequv,maxja,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),link(*),itnode(5,*),iequv(*),index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c construct hbmg ja c iflag=1 do i=1,nvf ja(i)=0 link(i)=0 enddo next=nvf+2 do it=1,ntf do j=1,3 i2=iequv(itnode(index(2,j),it)) i3=iequv(itnode(index(3,j),it)) irow=min0(i2,i3) icol=max0(i2,i3) ilink=link(irow) 10 if(ilink.eq.0) then if(next.gt.maxja) return ja(next)=icol link(next)=link(irow) link(irow)=next ja(irow)=ja(irow)+1 next=next+1 else if(ja(ilink).ne.icol) then ilink=link(ilink) go to 10 endif enddo enddo c c now make new ja c jai=nvf+2 do i=1,nvf itemp=ja(i) ja(i)=jai jai=jai+itemp enddo ja(nvf+1)=jai c do i=1,nvf next=link(i) if(ja(i+1).gt.ja(i)) then do m=ja(i),ja(i+1)-1 ii=next next=link(next) link(ii)=m enddo endif enddo do i=ja(1),ja(nvf+1)-1 100 if(link(i).ne.i) then jj=ja(i) ii=link(i) ja(i)=ja(ii) link(i)=link(ii) ja(ii)=jj link(ii)=ii go to 100 endif enddo c c sort indices c do i=1,nvf len=ja(i+1)-ja(i) call ihp(ja(ja(i)),len) enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkmtx(n,ispd,ja,a,b,q,z) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iblock(2),q(*) double precision + a(*),b(*),z(*) character*80 + filnam,temp save num data num/1/ c c write matrix file c filnam='mtx000' call sint(temp,ll,num) num=num+1 iunit=31 filnam(7-ll:6)=temp(1:ll) open(unit=iunit,form='formatted',status='unknown', + file=filnam,access='sequential',err=10) c iblock(1)=1 iblock(2)=n+1 nblock=1 write(unit=iunit,fmt='(i7,i3,i3)') n,ispd,nblock do i=1,nblock+1 write(unit=iunit,fmt='(i3,i6)') i,iblock(i) enddo do i=1,n z(q(i))=b(i) enddo do i=1,n write(unit=iunit,fmt='(i6,e14.7)') i,z(i) enddo do i=1,n write(unit=iunit,fmt='(i6,i6,e14.7)') i,i,a(i) enddo do i=1,n do j=ja(i),ja(i+1)-1 write(unit=iunit,fmt='(i6,i6,e14.7)') i,ja(j),a(j) enddo enddo if(ispd.eq.1) return ii=ja(n+1)-ja(1) do i=1,n do j=ja(i),ja(i+1)-1 write(unit=iunit,fmt='(i6,i6,e14.7)') ja(j),i,a(j+ii) enddo enddo close(unit=iunit) return 10 stop 3421 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100) double precision + w(*),vx(*),vy(*),xm(*),ym(*),rp(100) character*80 + sp(100),errmsg(20) save errmsg data (errmsg(i),i=1,16)/ + 'input data error -31: illegal itnode(k,*), 1 <= k <= 3 ', 1 'input data error -32: overlapping triangles in itnode ', 2 'input data error -40: illegal ntf, nvf, ncf, or nbf ', 3 'input data error -41: illegal ibndry(k,*), 1 <= k <= 2 ', 4 'input data error -42: illegal ibndry(3,*) ', 5 'input data error -43: illegal ibndry(4,*) ', 6 'input data error -44: incorrect circle center coordinates ', 7 'input data error -45: arc greater than pi/2 in length ', 8 'input data error -46: error in linked edges ', 9 'input data error -47: bdy vertex without two boundary edges ', + 'input data error -48: boundary iconsistent with elements ', 1 'input data error -51: illegal itnode(1,*) ', 2 'input data error -52: illegal itnode(2,*) ', 3 'input data error -53: skeleton region tracing error ', 4 'input data error -54: region specified in clockwise order ', 5 'input data error -55: illegal itnode(3,*) '/ c lenw=ip(20) iz=max0(ip(99),ip(22),0)+1 lenz=lenw-iz+1 c ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) call xybox(nbf,vx,vy,xm,ym,ibndry, + rp(87),rp(88),rp(89),rp(90),rp(78)) if(itnode(3,1).eq.0) then call sklchk(ntf,nvf,nbf,ncf,itnode,ibndry, + vx,vy,xm,ym,rp(78),lenz,w(iz),iflag) else call trichk(ntf,nvf,nbf,ncf,itnode,ibndry, + vx,vy,xm,ym,lenz,w(iz),rp(80),iflag) endif c ip(25)=iflag sp(12)(1:6)='input ' if(iflag.eq.0) then sp(11)='input: ok' else if(iflag.le.-31.and.iflag.ge.-32) then sp(11)=errmsg(-iflag-30) else if(iflag.le.-40.and.iflag.ge.-48) then sp(11)=errmsg(-iflag-37) else if(iflag.le.-51.and.iflag.ge.-55) then sp(11)=errmsg(-iflag-39) else if(iflag.ge.20.and.iflag.le.24) then sp(11)='input: insufficient storage' else sp(11)='input: unknown error' endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine trichk(ntf,nvf,nbf,ncf,itnode,ibndry, + vx,vy,xm,ym,lenz,z,area,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*),z(*) c c superficial check of input data c iflag=0 if(lenz.lt.nvf+3*nbf+6*ntf) then iflag=20 return endif if(nbf.lt.3.or.nvf.lt.3.or.ntf.lt.1.or.ncf.lt.0) then iflag=-40 return endif c c check ibndry array c call bdychk(ibndry,nvf,nbf,ncf,vx,vy,xm,ym,iflag) if(iflag.ne.0) return c c orient triangles and boundary edges c call orient(nvf,ntf,nbf,itnode,ibndry,vx,vy,z,iflag) if(iflag.ne.0) return c c compute number of regions, holes, consistency check c call cnhnr(nvf,ntf,nbf,nh,nr,ibndry,z,z(nvf+1),iflag) if(iflag.ne.0) return c c compute itedge c itedge=1 ibedge=itedge+3*ntf list=ibedge+2*nbf call cedge1(nvf,ntf,nbf,itnode,ibndry,z(itedge),z(ibedge), + vx,vy,z(list),iflag) if(iflag.ne.0) return area=carea(ntf,itnode,z(itedge),ibndry,vx,vy,xm,ym) c c initialize region labels c do i=1,ntf itnode(4,i)=1 enddo do i=1,nbf ibndry(5,i)=0 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cnhnr(nvf,ntf,nbf,nh,nr,ibndry,list,mark,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),list(*),mark(*) c c compute nh and nr c this is a good consistency check c iflag=-40 do i=1,nvf list(i)=0 mark(i)=0 enddo c c make circular lists, assumes bdy edges are already oriented. c nb=0 do i=1,nbf if(ibndry(4,i).ne.0) then nb=nb+1 list(ibndry(1,i))=ibndry(2,i) endif enddo c c nt+nb-2nv=2nh-2nr c id=ntf+nb-2*nvf if((id/2)*2.ne.id) return id=id/2 c c now count loops which should be equal to nr+nh c is=0 do i=1,nvf if(list(i).ne.0.and.mark(i).eq.0) then is=is+1 next=i ic=0 10 mark(next)=is next=list(next) ic=ic+1 if(ic.gt.nvf) return if(next.ne.i) go to 10 endif enddo c nh=id+is if((nh/2)*2.ne.nh) return nh=nh/2 if(nh.lt.0) return nr=is-id if((nr/2)*2.ne.nr) return nr=nr/2 if(nr.lt.1) return iflag=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine orient(nvf,ntf,nbf,itnode,ibndry,vx,vy,list,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),list(2,*),index(3,3) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c orient triangles c do i=1,ntf do j=1,3 k=itnode(j,i) if(k.lt.1.or.k.gt.nvf) then iflag=-31 return endif enddo r=geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) if(r.lt.0.0d0) then itemp=itnode(2,i) itnode(2,i)=itnode(3,i) itnode(3,i)=itemp endif enddo c c orient ibndry c do i=1,nvf list(1,i)=0 list(2,i)=0 enddo do i=1,nbf if(ibndry(4,i).ne.0) then do j=1,2 k=ibndry(j,i) if(list(1,k).eq.0) then list(1,k)=i else if(list(2,k).eq.0) then list(2,k)=i else iflag=-47 return endif enddo endif enddo do i=1,nvf if(list(1,i).ne.0) then if(list(2,i).eq.0) then iflag=-47 return endif endif enddo c do i=1,ntf do j=1,3 j2=itnode(index(2,j),i) j3=itnode(index(3,j),i) if(list(1,j2).ne.0) then k1=list(1,j2) k2=list(2,j2) k=0 if(ibndry(1,k1).eq.j3) then k=k1 ibndry(1,k1)=j2 ibndry(2,k1)=j3 else if(ibndry(2,k1).eq.j3) then k=k1 else if(ibndry(1,k2).eq.j3) then k=k2 ibndry(1,k2)=j2 ibndry(2,k2)=j3 else if(ibndry(2,k2).eq.j3) then k=k2 endif endif enddo enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bdychk(ibndry,nvf,nbf,ncf,vx,vy,xm,ym,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*) c c check ibndry array c iflag=0 eps=1.0d-3 c c simple consistency checks c do i=1,nbf if(ibndry(1,i).lt.1.or.ibndry(1,i).gt.nvf) then iflag=-41 return endif if(ibndry(2,i).lt.1.or.ibndry(2,i).gt.nvf) then iflag=-41 return endif c c* if(ibndry(3,i).lt.0.or.ibndry(3,i).gt.ncf) then if(ibndry(3,i).gt.ncf) then iflag=-42 return endif c if(ibndry(4,i).lt.0) then j=-ibndry(4,i) if(j.gt.nbf) then iflag=-43 return endif if(ibndry(4,j).ne.-i) then iflag=-43 return endif c* else c* if(ibndry(4,i).gt.2) then c* iflag=-43 c* return c* endif endif enddo c c do i=1,nbf c c check circle centers c if(ibndry(3,i).gt.0) then i1=ibndry(1,i) i2=ibndry(2,i) ic=ibndry(3,i) dx=vx(i1)-vx(i2) dy=vy(i1)-vy(i2) xc=xm(ic)-(vx(i1)+vx(i2))/2.0d0 yc=ym(ic)-(vy(i1)+vy(i2))/2.0d0 if(dabs(xc*dx+yc*dy).gt.dabs(xc*dy-yc*dx)*eps) then iflag=-44 return endif c c check arc length c call arc(vx(i1),vy(i1),vx(i2),vy(i2), + xm(ic),ym(ic),theta1,theta2,r,alen) aa=dabs(theta1-theta2) if(aa.gt.0.5d0+eps) then iflag=-45 return endif endif enddo c c check periodic edges...each checked twice (i/j interchanged) c do i=1,nbf if(ibndry(4,i).lt.0) then j=-ibndry(4,i) i1=ibndry(1,i) i2=ibndry(2,i) j1=ibndry(1,j) j2=ibndry(2,j) di=dsqrt((vx(i1)-vx(i2))**2+(vy(i1)-vy(i2))**2) dj=dsqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2) if(dabs(di-dj).gt.eps*(di+dj)) then iflag=-46 return endif ic=ibndry(3,i) jc=ibndry(3,j) if(ic.le.0) then if(jc.gt.0) then iflag=-46 return endif else if(jc.le.0) then iflag=-46 return endif call arc(vx(i1),vy(i1),vx(i2),vy(i2), + xm(ic),ym(ic),theti1,theti2,ri,ai) call arc(vx(j1),vy(j1),vx(j2),vy(j2), + xm(jc),ym(jc),thetj1,thetj2,rj,aj) if(dabs(ri-rj).gt.eps*(dabs(ri)+dabs(rj))) then iflag=-46 return endif if(dabs(ai-aj).gt.eps*(ai+aj)) then iflag=-46 return endif endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sklchk(ntr,nvr,nbr,ncr,itnode,ibndry, + vx,vy,xm,ym,diam,lenz,z,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*),z(*) c c this routine does some checking of data for obvious c errors which could cause infinite loops or abnomal c termination of trigen c iflag=0 if(lenz.lt.5*nbr+ntr+3*nvr+2) then iflag=20 return endif if(nbr.lt.3.or.nvr.lt.3.or.ntr.lt.1.or.ncr.lt.0) then iflag=-40 return endif c c check ibndry c call bdychk(ibndry,nvr,nbr,ncr,vx,vy,xm,ym,iflag) if(iflag.ne.0) return c c try to make jb c do i=1,ntr if(itnode(1,i).le.0.or.itnode(1,i).gt.nvr) then iflag=-51 return endif if(itnode(2,i).le.0.or.itnode(1,i).gt.nbr) then iflag=-52 return endif enddo c ivx0=1 ivy0=ivx0+nvr jb=ivy0+nvr list=jb+ntr+1+2*nbr c call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,z(jb), + z(list),z(ivx0),z(ivy0),iflag) if(iflag.ne.0) return c c now check each region c call rgnchk(ntr,itnode,ibndry,vx,vy,xm,ym,z(jb),iflag) if(iflag.ne.0) return c c check symmetry specifications c call symtst(ntr,itnode,ibndry,vx,vy,xm,ym,z(jb),diam,iflag) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rgnchk(ntr,itnode,ibndry,vx,vy,xm,ym,jb,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*),x(20),y(20) c c check for counterclockwise orientientation of regions c iflag=0 pi=3.141592653589793d0 c do ii=1,ntr i1=jb(ii) i2=jb(ii+1)-1 j=jb(i2) k=jb(i1) kv=itnode(1,ii) kb=ibndry(1,j)+ibndry(2,j)-kv if(ibndry(3,j).le.0) then x(2)=vx(kb) y(2)=vy(kb) else km=ibndry(3,j) call arc(vx(kb),vy(kb),vx(kv),vy(kv), + xm(km),ym(km),thetab,thetav,r,alen) aa=dabs(thetav-thetab)*8.0d0 m1=max0(idint(aa),1) dtheta=(thetav-thetab)/dfloat(m1+1) ang=(thetab+dfloat(m1)*dtheta)*pi x(2)=xm(km)+r*dcos(ang) y(2)=ym(km)+r*dsin(ang) endif x(3)=vx(kv) y(3)=vy(kv) last=1 bsum=2.0d0 do i=i1,i2 k=jb(i) ka=ibndry(1,k)+ibndry(2,k)-kv km=ibndry(3,k) do m=1,2 x(m)=x(last+m) y(m)=y(last+m) enddo last=1 if(km.gt.0) then call arc(vx(kv),vy(kv),vx(ka),vy(ka), + xm(km),ym(km),thetav,thetaa,r,alen) aa=dabs(thetaa-thetav)*8.0d0 m1=max0(idint(aa),1) dtheta=(thetaa-thetav)/dfloat(m1+1) do m=1,m1 ang=(thetav+dfloat(m)*dtheta)*pi x(m+2)=xm(km)+r*dcos(ang) y(m+2)=ym(km)+r*dsin(ang) enddo last=m1+1 endif x(last+2)=vx(ka) y(last+2)=vy(ka) do m=1,last bsum=bsum+cang(m,m+1,m+2,x,y)-1.0d0 enddo kv=ka enddo c c bsum = 0 for counterclockwise, bsum = 4 for clockwise c if(dabs(bsum).gt.0.01d0) then iflag=-54 return endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine symtst(ntr,itnode,ibndry,vx,vy,xm,ym,jb,diam,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*) c c check symmetry specifications in itnode c iflag=0 eps=1.0d-3 if(ntr.eq.1) return c iflag=-55 if(itnode(3,1).ne.0) return tol=(eps*diam)**2 do 90 jr=2,ntr if(itnode(3,jr).eq.0) go to 90 ir=iabs(itnode(3,jr)) if(ir.ge.jr) return i1=jb(ir) i2=jb(ir+1)-1 j1=jb(jr) j2=jb(jr+1)-1 if(i2-i1.ne.j2-j1) return c c find common vertices c iv1=itnode(1,ir) iedge=jb(i1) iv2=ibndry(1,iedge)+ibndry(2,iedge)-iv1 c jv1=itnode(1,jr) if(itnode(3,jr).gt.0) then j=j1 inc=1 else j=j2 inc=-1 endif jedge=jb(j) jv2=ibndry(1,jedge)+ibndry(2,jedge)-jv1 c c compute affine map c dxi=vx(iv2)-vx(iv1) dyi=vy(iv2)-vy(iv1) dxj=vx(jv2)-vx(jv1) dyj=vy(jv2)-vy(jv1) dd=dxj*dxj+dyj*dyj a11=(dxi*dxj+dyi*dyj*dfloat(inc))/dd a12=(dxi*dyj-dyi*dxj*dfloat(inc))/dd a21=-a12*dfloat(inc) a22=a11*dfloat(inc) xx=vx(iv1)-a11*vx(jv1)-a12*vy(jv1) yy=vy(iv1)-a21*vx(jv1)-a22*vy(jv1) c c check all points c iv=iv1 jv=jv1 do i=i1,i2 dx=a11*vx(jv)+a12*vy(jv)+xx-vx(iv) dy=a21*vx(jv)+a22*vy(jv)+yy-vy(iv) if(dx*dx+dy*dy.gt.tol) return c iedge=jb(i) jedge=jb(j) if(ibndry(3,iedge).le.0) then if(ibndry(3,jedge).gt.0) return else if(ibndry(3,jedge).le.0) return im=ibndry(3,iedge) jm=ibndry(3,jedge) dx=a11*xm(jm)+a12*ym(jm)+xx-xm(im) dy=a21*xm(jm)+a22*ym(jm)+yy-ym(im) if(dx*dx+dy*dy.gt.tol) return endif iv=ibndry(1,iedge)+ibndry(2,iedge)-iv jv=ibndry(1,jedge)+ibndry(2,jedge)-jv j=j+inc enddo 90 continue iflag=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sklutl(isw,vx,vy,xm,ym,itnode,ibndry,ip,w,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100) double precision + vx(*),vy(*),xm(*),ym(*),w(*) c c utility function for skeleton creation c ntf=ip(1) nvf=ip(2) nbf=ip(4) lenw=ip(20) maxv=ip(22) maxb=ip(24) c c create an itnode array from other skeleton data c if(isw.eq.0) then list=1 ivx0=list+3*nbf+nvf+1 ivy0=ivx0+nvf ii=ivy0+nvf if(ii.gt.lenw) then iflag=20 return endif call mkitnd(nvf,nbf,ntf,vx,vy,xm,ym,itnode,ibndry, + w(list),w(ivx0),w(ivy0),iflag) if(iflag.ne.0) return ip(1)=ntf c c divide long curved edges c else if(isw.eq.1) then list=1 ii=list+2*max0(nvf,nbf) if(ii.gt.lenw) then iflag=20 return endif call dvedge(ntf,nvf,nbf,maxv,maxb,vx,vy,xm,ym, + ibndry,itnode,w(list),iflag) if(iflag.ne.0) return ip(2)=nvf ip(4)=nbf c c find symmetric regions in skeleton c else if(isw.eq.2) then jb=1 list=jb+ntf+2*nbf+1 ivx0=list+nvf+3*nbf+1 ivy0=ivx0+nvf ii=ivy0+nvf if(ii.gt.lenw) then iflag=20 return endif call fndsym(ntf,nvf,nbf,vx,vy,xm,ym,ibndry,w(jb), + itnode,w(list),w(ivx0),w(ivy0),iflag) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkitnd(nvf,nbf,ntf,vx,vy,xm,ym,itnode,ibndry, + list,vx0,vy0,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),list(*) double precision + vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*) c c compute itnode from skeleton data arrays ibndry,vx,vy,xm,ym c iflag=0 ntf=0 c c initialize with list of edges as function of vertex in list c do i=1,nvf list(i+1)=0 enddo do i=1,nbf list(ibndry(1,i)+1)=list(ibndry(1,i)+1)+1 list(ibndry(2,i)+1)=list(ibndry(2,i)+1)+1 if(ibndry(4,i).eq.0) then list(nvf+1+i)=2 else list(nvf+1+i)=1 endif enddo list(1)=nvf+nbf+2 do i=1,nvf list(i+1)=list(i)+list(i+1) enddo do i=1,nbf do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo enddo do i=nvf,2,-1 list(i)=list(i-1) enddo list(1)=nvf+nbf+2 c c jiggle vertices a bit towards the center of their regions c to avoid failed tests due to cracks c itmax=3 eps=1.0d-3 do i=1,nvf vx0(i)=vx(i) vy0(i)=vy(i) enddo do itnum=1,itmax do i=1,nvf xx=0.0d0 yy=0.0d0 do j=list(i),list(i+1)-1 k=list(j) xx=xx+vx0(ibndry(1,k))+vx0(ibndry(2,k)) yy=yy+vy0(ibndry(1,k))+vy0(ibndry(2,k)) enddo vx0(i)=vx0(i)+eps*xx/dfloat(list(i+1)-list(i)) vy0(i)=vy0(i)+eps*yy/dfloat(list(i+1)-list(i)) enddo enddo c c find lower left vertex c 10 left=0 do i=1,nbf if(list(nvf+1+i).gt.0) then if(left.eq.0) left=ibndry(1,i) do k=1,2 j=ibndry(k,i) if(vx0(j).lt.vx0(left)) then left=j else if(vx0(j).eq.vx0(left).and. + vy0(j).lt.vy0(left)) then left=j endif enddo endif enddo c c find starting edge c if(left.eq.0) return i1=list(left) i2=list(left+1)-1 icur=0 jcur=0 do ii=i1,i2 i=list(ii) if(list(nvf+1+i).eq.1) then if(icur.eq.0) then icur=i else jcur=i iv1=ibndry(1,icur)+ibndry(2,icur)-left iv2=ibndry(1,jcur)+ibndry(2,jcur)-left qq=geom(left,iv1,iv2,vx0,vy0) if(qq.lt.0.0d0) then jcur=icur icur=i endif endif endif enddo if(jcur.eq.0) then iflag=-43 return endif c c comput itnode for new region c ntf=ntf+1 itnode(1,ntf)=left itnode(2,ntf)=icur itnode(3,ntf)=0 itnode(4,ntf)=1 itnode(5,ntf)=ntf c c istart=icur iv=left do nnbf=1,nbf 20 if(list(nvf+1+icur).le.0) then iflag=-53 return endif list(nvf+1+icur)=list(nvf+1+icur)-1 jv=ibndry(1,icur)+ibndry(2,icur)-iv j1=list(jv) j2=list(jv+1)-1 if(j2.eq.j1+1) then next=list(j1) if(next.eq.icur) next=list(j2) else next=0 ang=3.0d0 do kk=j1,j2 k=list(kk) if(k.ne.icur) then kv=ibndry(1,k)+ibndry(2,k)-jv if(max0(ibndry(3,icur),ibndry(3,k)).gt.0) then aa=cang1(iv,jv,kv,icur,k,vx0,vy0, + xm,ym,ibndry) else aa=cang(iv,jv,kv,vx0,vy0) endif if(aa.lt.ang) then ang=aa next=k endif endif enddo endif if(next.eq.istart) then go to 10 else icur=next iv=jv go to 20 endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dvedge(ntf,nvf,nbf,maxv,maxb,vx,vy,xm,ym, + ibndry,itnode,list,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),list(2,*) double precision + vx(*),vy(*),xm(*),ym(*) c iflag=0 pi=3.141592653589793d0 angmax=1.0d0/8.0d0+1.0d-3 c c orient boundary edges c im=1 do i=1,nvf list(1,i)=0 list(2,i)=0 if(vx(i).lt.vx(im)) then im=i else if(vx(i).eq.vx(im).and.vy(i).lt.vy(im)) then im=i endif enddo do i=1,nbf if(ibndry(4,i).ne.0) then do j=1,2 k=ibndry(j,i) if(list(1,k).eq.0) then list(1,k)=i else if(list(2,k).ne.0) then iflag=-53 return endif list(2,k)=i endif enddo endif enddo r=1.0d0 5 if(list(1,im).eq.0.or.list(2,im).eq.0) then iflag=-53 return endif i1=list(1,im) i2=list(2,im) ibef=ibndry(1,i1)+ibndry(2,i1)-im iaft=ibndry(1,i2)+ibndry(2,i2)-im q=geom(ibef,im,iaft,vx,vy) if(q*r.lt.0.0d0) then istart=i1 iend=i2 ibndry(1,i2)=iaft ibndry(2,i2)=im ibndry(1,i1)=im ibndry(2,i1)=ibef else istart=i2 iend=i1 ibndry(1,i1)=ibef ibndry(2,i1)=im ibndry(1,i2)=im ibndry(2,i2)=iaft endif list(1,im)=-list(1,im) 10 im=ibndry(2,istart) if(list(1,im).le.0.or.list(2,im).le.0) then iflag=-53 return endif i1=list(1,im) i2=list(2,im) list(1,im)=-list(1,im) if(i1.eq.istart) then istart=i2 else istart=i1 endif if(ibndry(2,istart).eq.im) then ibndry(2,istart)=ibndry(1,istart) ibndry(1,istart)=im endif if(istart.ne.iend) go to 10 c c remaining vertices are on the boundary holes c r=-1.0d0 im=0 do i=1,nvf if(list(1,i).gt.0) then if(im.eq.0) then im=i else if(vx(i).lt.vx(im)) then im=i else if(vx(i).eq.vx(im).and.vy(i).lt.vy(im)) then im=i endif endif endif enddo if(im.ne.0) go to 5 c c divide user specified edges c nbf0=nbf do i=1,nbf0 list(1,i)=0 list(2,i)=0 c c the case of a curved edge c if(ibndry(3,i).gt.0) then j1=ibndry(1,i) j2=ibndry(2,i) jc=ibndry(3,i) call arc(vx(j1),vy(j1),vx(j2),vy(j2), + xm(jc),ym(jc),theta1,theta2,radius,alen) xc=xm(jc) yc=ym(jc) d=dabs(theta2-theta1)/angmax np=idint(d) c c add new points on circular arc c if(np.gt.0) then if(nvf+np.gt.maxv) then iflag=22 return endif if(nbf+np.gt.maxb) then iflag=23 return endif nvsave=nvf nbsave=nbf dt=(theta2-theta1)/dfloat(np+1) do j=1,np arg=(theta1+dt*dfloat(j))*pi nvf=nvf+1 vx(nvf)=xc+radius*dcos(arg) vy(nvf)=yc+radius*dsin(arg) nbf=nbf+1 ibndry(1,nbf)=nvf ibndry(2,nbf)=nvf+1 ibndry(3,nbf)=ibndry(3,i) ibndry(4,nbf)=ibndry(4,i) ibndry(5,nbf)=ibndry(5,i) ibndry(6,nbf)=ibndry(6,i) enddo ibndry(2,nbf)=j2 ibndry(2,i)=nvsave+1 list(1,i)=nbsave+1 list(2,i)=nbf endif endif enddo c c fix itnode c do i=1,ntf k=itnode(1,i) j=itnode(2,i) if(ibndry(1,j).ne.k.and.ibndry(2,j).ne.k) then itnode(2,i)=list(2,j) endif enddo c c periodic boundary edges c do i=1,nbf0 j=-ibndry(4,i) if(list(1,i).gt.0.and.j.gt.i) then ni1=list(1,i) ni2=list(2,i) nj1=list(1,j) nj2=list(2,j) ibndry(4,i)=-nj2 ibndry(4,j)=-ni2 num=ni2-ni1 if(num.gt.0) then do k=1,num ibndry(4,ni1+k-1)=-(nj2-k) ibndry(4,nj2-k)=-(ni1+k-1) enddo endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fndsym(ntf,nvf,nbf,vx,vy,xm,ym,ibndry,jb, + itnode,list,vx0,vy0,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jb(*),itnode(5,*),list(*) double precision + vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*) data ibit/0/ c c find symmetry in skeleton c iflag=0 call makjb(nvf,nbf,ntf,vx,vy,xm,ym,ibndry,itnode,jb,list, + vx0,vy0,iflag) if(iflag.ne.0) return c c look for symmetry in mesh c do i=1,ntf itnode(3,i)=0 enddo if(ntf.eq.1) return call xybox(nbf,vx,vy,xm,ym,ibndry,xmin,xmax,ymin,ymax,diam) eps=ceps(ibit)*8.0d0 tol=(eps*diam)**2 do 100 ns1=1,ntf-1 if(itnode(3,ns1).ne.0) go to 100 do 90 ns2=ns1+1,ntf if(itnode(3,ns2).ne.0) go to 90 i1=jb(ns1) i2=jb(ns1+1)-1 j1=jb(ns2) j2=jb(ns2+1)-1 if(i2-i1.ne.j2-j1) go to 90 c do kk=1,2 if(kk.eq.1) inc=1 if(kk.eq.2) inc=-1 do 80 jj=j1,j2 c c initialize region ns1 c iv1=itnode(1,ns1) iedge=jb(i1) iv2=ibndry(1,iedge)+ibndry(2,iedge)-iv1 c c initialize region ns2 c jpedge=jb(jj) jv1=ibndry(1,jpedge) if(inc.eq.1) then if(jj.eq.j1) then jmedge=jb(j2) else jmedge=jb(jj-1) endif else if(jj.eq.j2) then jmedge=jb(j1) else jmedge=jb(jj+1) endif endif if(jv1.ne.ibndry(1,jmedge).and.jv1.ne. + ibndry(2,jmedge)) jv1=ibndry(2,jpedge) jv2=ibndry(1,jpedge)+ibndry(2,jpedge)-jv1 c c compute affine map c dxi=vx(iv2)-vx(iv1) dyi=vy(iv2)-vy(iv1) dxj=vx(jv2)-vx(jv1) dyj=vy(jv2)-vy(jv1) dd=dxj*dxj+dyj*dyj a11=(dxi*dxj+dyi*dyj*dfloat(inc))/dd a12=(dxi*dyj-dyi*dxj*dfloat(inc))/dd a21=-a12*dfloat(inc) a22=a11*dfloat(inc) xx=vx(iv1)-a11*vx(jv1)-a12*vy(jv1) yy=vy(iv1)-a21*vx(jv1)-a22*vy(jv1) c c check all points c iv=iv1 jv=jv1 j=jj do i=i1,i2 dx=a11*vx(jv)+a12*vy(jv)+xx-vx(iv) dy=a21*vx(jv)+a22*vy(jv)+yy-vy(iv) if(dx*dx+dy*dy.gt.tol) go to 80 c iedge=jb(i) jedge=jb(j) if(ibndry(3,iedge).le.0) then if(ibndry(3,jedge).gt.0) go to 80 else if(ibndry(3,jedge).le.0) go to 80 im=ibndry(3,iedge) jm=ibndry(3,jedge) dx=a11*xm(jm)+a12*ym(jm)+xx-xm(im) dy=a21*xm(jm)+a22*ym(jm)+yy-ym(im) if(dx*dx+dy*dy.gt.tol) go to 80 endif iv=ibndry(1,iedge)+ibndry(2,iedge)-iv jv=ibndry(1,jedge)+ibndry(2,jedge)-jv j=j+inc if(j.gt.j2) j=j1 if(j.lt.j1) j=j2 enddo c c we found a similar pair c if(inc.eq.1) then itnode(1,ns2)=jv1 itnode(2,ns2)=jpedge itnode(3,ns2)=ns1 else itnode(1,ns2)=jv1 itnode(2,ns2)=jmedge itnode(3,ns2)=-ns1 endif go to 90 80 continue enddo 90 continue 100 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setval c implicit double precision (a-h,o-z) implicit integer (i-n) common /val0/k0,ku,kx,ky,kl,kuu,kux,kuy,kul, + kxu,kxx,kxy,kxl,kyu,kyx,kyy,kyl,klu,klx,kly,kll common /val1/j0,ju,jl,juu,jul,jlu,jll common /val2/m0,ml,mll,mlb,mub,mic common /val3/kf,kf1,kf2,ksk,kad c c a1xy,a2xy,fxy,p1xy,p2xy c k0=1 ku=2 kx=3 ky=4 kl=5 kuu=6 kxx=7 kyy=8 kux=9 kxu=9 kuy=10 kyu=10 kxy=11 kyx=11 kul=12 klu=12 kxl=13 klx=13 kyl=14 kly=14 kll=15 c c gnxy c j0=1 ju=2 jl=3 juu=4 jul=5 jlu=5 jll=6 c c gdxy c m0=1 ml=2 mll=3 mlb=4 mub=5 mic=6 c c qxy c kf=1 kf=1 kf1=2 kf2=3 ksk=4 kad=5 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mgilu(ja,a,lvl,ka,z) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(10,*) double precision + a(*),z(*),coeff(2) c c lenz=5*n c n=ka(1,1) ispd=ka(1,lvl+1) i1=1 i2=i1+n i3=i2+n i4=i3+n i5=i4+n c a(n+1)=canorm(n,ispd,ja,a) c c compute coarse graph matrices c do level=lvl,1,-1 call getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) if(iuptr.ne.iaptr) then call snfilu(nf,ja(japtr),a(iaptr),ja(juptr),a(iuptr), + z(i1),z(i2),z(i3),z(i4),z(i5),ispd) endif if(level.gt.1) then call getptr(level-1,lvl,nc,ncptr,jacptr,iacptr, + jucptr,iucptr,jvcptr,ivcptr,iqcptr,ibcptr, 1 ncc,nccptr,ka) call ceig(nf,ispd,ja(japtr),a(iaptr),ja(juptr), + a(iuptr),z(i2),z(i3),z(i4),z(i5),0,z(i1),coeff) call cwt(nf,nc,ispd,ja(jvptr),a(ivptr),z(i1), + ja(japtr),a(iaptr),ja(iqcptr),z(i2),z(i3)) call a2ac(nf,ispd,ja(japtr),a(iaptr),nc, + ja(jacptr),a(iacptr),ja(jvptr),a(ivptr)) endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mginit(n,ispd,nblock,ib,maxja,ja,maxa,a,ncfact, + maxlvl,maxfil,ka,lvl,dtol,method,lenz,z,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(10,*),ib(*) double precision + a(*),z(*),coeff(2) c iflag=0 c c maxlvl=max0(1,maxlvl) if(dtol.le.0.0d0) maxlvl=1 dtol=dabs(dtol) ncfact=max0(ncfact,2) if(method.lt.0.or.method.gt.2) method=0 c lenja=ja(n+1)-1 if(ispd.eq.1) then lena=lenja else lena=2*lenja-(n+1) endif minfil=((lenja-(n+1))/n)+3 c nf=n nptr=1 japtr=1 iaptr=1 ibptr=japtr+lenja iqptr=ibptr+nf lvl=1 c ka(1,lvl)=nf ka(2,lvl)=nptr ka(3,lvl)=japtr ka(4,lvl)=iaptr ka(5,lvl)=0 ka(6,lvl)=0 ka(7,lvl)=0 ka(8,lvl)=0 ka(9,lvl)=iqptr ka(10,lvl)=ibptr a(n+1)=canorm(n,ispd,ja,a) do i=1,nblock do j=ib(i),ib(i+1)-1 ja(lenja+j)=i enddo enddo c c c 10 nf=ka(1,lvl) nptr=ka(2,lvl) japtr=ka(3,lvl) iaptr=ka(4,lvl) iqptr=ka(9,lvl) ibptr=ka(10,lvl) c if(iqptr+nf.gt.maxja) then lvl=lvl-1 if(lvl.lt.1) iflag=20 go to 20 endif i0=1 nn=max0(nf,nblock+1) i1=i0+nn i2=i1+nn i3=i2+nn i4=i3+nn i5=i4+nn i6=i5+nn jc=i6+nn maxjc=lenz-jc+1 if(maxjc.lt.2*lenja-(nf+1)) then lvl=lvl-1 if(lvl.lt.1) iflag=20 go to 20 endif c c compute ordering vector q, reorder ja and a c rdtol=dtol cc if(lvl.eq.maxlvl.and.maxlvl.gt.1) rdtol=0.0e0 call ja2jcb(nf,ispd,ja(japtr),a(iaptr),rdtol,maxjc,z(jc), + z(i6),z(i2),lena0,iflag) if(iflag.ne.0) then lvl=lvl-1 if(lvl.ge.1) iflag=0 go to 20 endif cc call ja2jc(nf,ja(japtr),z(jc)) call md(nf,z(jc),z(i1),ja(iqptr),lenu0,z(i2),z(i3),z(i4),z(i5)) call ja2jc1(nf,z(i6),z(i1),ja(iqptr)) call ja2ja(nf,ja(japtr),ja(iqptr),z(jc),ispd,a(iaptr), + ja(ibptr)) if(lvl.gt.1) call vf2vf(ka(1,lvl-1),nf,ja(jvptr),ja(iqptr), + z(i0),z(i1)) c if(method.eq.0) then juptr=iqptr+nf iuptr=iaptr+lena ka(5,lvl)=juptr ka(6,lvl)=iuptr lenju=maxja-juptr+1 lenu=maxa-iuptr+1 rdtol=dtol cc if(lvl.eq.maxlvl.and.maxlvl.gt.1) rdtol=0.0e0 call sfilu(nf,ja(japtr),a(iaptr),lenju,ja(juptr), + lenu,a(iuptr),z(i1),z(i2),z(i3),z(i4),z(i5), 1 ispd,rdtol,maxfil,iflag) if(iflag.ne.0) then lvl=lvl-1 if(lvl.ge.1) iflag=0 go to 20 endif c ka(7,lvl)=juptr+lenju ka(8,lvl)=iuptr+lenu c else if(method.eq.1) then juptr=japtr iuptr=iaptr+lena ka(5,lvl)=juptr ka(6,lvl)=iuptr ka(7,lvl)=iqptr+nf ka(8,lvl)=iuptr+lena if(iuptr+lena.gt.maxa) then lvl=lvl-1 if(lvl.ge.1) iflag=0 go to 20 endif call snfilu(nf,ja(japtr),a(iaptr),ja(juptr),a(iuptr), + z(i1),z(i2),z(i3),z(i4),z(i5),ispd) c else if(method.eq.2) then juptr=japtr iuptr=iaptr ka(5,lvl)=juptr ka(6,lvl)=iuptr ka(7,lvl)=iqptr+nf ka(8,lvl)=iuptr+lena endif c ka(1,lvl+1)=0 ka(2,lvl+1)=ka(2,lvl)+nf ka(3,lvl+1)=0 ka(4,lvl+1)=0 ka(5,lvl+1)=0 ka(6,lvl+1)=0 ka(7,lvl+1)=0 ka(8,lvl+1)=0 ka(9,lvl+1)=0 ka(10,lvl+1)=0 if(lvl.ge.maxlvl.or.nf.le.1.or.lenu0.le.lena0) go to 20 c jvptr=ka(7,lvl) ivptr=ka(8,lvl) lenjv=maxja-jvptr+1 lenwt=maxa-ivptr+1 cc call ja2jc(nf,ja(japtr),z(jc)) rdtol=dmin1(1.d-3,dtol) call ja2jf(nf,ispd,ja(japtr),a(iaptr),rdtol,z(jc),ja(ibptr)) call crsncm(nf,nc,z(i1),z(i2),z(i3),z(jc),maxjc,z(i4),z(i0), + ncfact,iflag) call crsncr(nf,nc,z(i1),z(i2),z(jc),z(i4),z(i0),ncfact,ispd, + ja(japtr),a(iaptr),ja(juptr),a(iuptr),z(i1),z(i2), 1 z(i3),z(i0),z(i5),nblock,ja(ibptr),iflag) if(iflag.ne.0) then if(iflag.eq.1) iflag=0 go to 20 endif call cvf(nf,nc,ispd,z(jc),lenjv,ja(jvptr),lenwt, + z(i3),z(i4),z(i0),iflag) if(iflag.ne.0) then if(iflag.eq.20) iflag=0 go to 20 endif if(nc.le.0) go to 20 call ceig(nf,ispd,ja(japtr),a(iaptr),ja(juptr),a(iuptr), + z(i2),z(i3),z(i4),z(i5),0,z(i1),coeff) call cwt(nf,nc,ispd,ja(jvptr),a(ivptr),z(i1), + ja(japtr),a(iaptr),z(i0),z(i2),z(i3)) ka(1,lvl+1)=nc jacptr=ka(7,lvl)+lenjv iacptr=ka(8,lvl)+lenwt ka(3,lvl+1)=jacptr ka(4,lvl+1)=iacptr c jvc=jc+2*lenja-(nf+1) if(jvc+lenjv.gt.lenz) then go to 20 endif lenja=maxja-jacptr+1 call ja2jac(nf,ja(japtr),z(jc),nc,ja(jacptr),ja(jvptr), + z(jvc),lenja,z(i1),z(i2),iflag) if(iflag.ne.0) then if(iflag.eq.20) iflag=0 go to 20 endif if(ispd.eq.1) then lena=lenja else lena=2*lenja-(nc+1) endif if(iacptr+lena-1.gt.maxa) then go to 20 endif call a2ac(nf,ispd,ja(japtr),a(iaptr),nc,ja(jacptr), + a(iacptr),ja(jvptr),a(ivptr)) rdtol=dmin1(1.d-3,dtol) call sfac(nc,ja(jacptr),a(iacptr),lenja,lena,ispd, + rdtol,maxfil,minfil) ibcptr=jacptr+lenja iqcptr=ibcptr+nc ka(9,lvl+1)=iqcptr ka(10,lvl+1)=ibcptr if(iqcptr+nc.gt.maxja) go to 20 call mkib(nc,z(i0),ja(ibptr),ja(ibcptr)) c lvl=lvl+1 go to 10 c 20 ka(1,lvl+1)=ispd return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function canorm(n,ispd,ja,a) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + a(*) data ibit/0/ c c compute anorm c canorm=0.0d0 eps=ceps(ibit) c do i=1,n canorm=dmax1(canorm,dabs(a(i))) enddo canorm=canorm*eps if(canorm.gt.0.0d0) return c c if diag is zero, try off diagonals c nnz=ja(n+1)-ja(1) if(ispd.ne.1) nnz=2*nnz do i=1,nnz canorm=dmax1(canorm,dabs(a(ja(1)+i-1))) enddo canorm=canorm*eps if(canorm.gt.0.0d0) return c c if the matrix is zero c canorm=eps return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja2ja(n,ja,q,link,ispd,a,bindx) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),q(*),link(*),amtx,bindx(*) double precision + a(*) c c compute linked list of new column indices c if(ispd.ne.1) then amtx=ja(n+1)-ja(1) else amtx=0 endif c do i=1,n link(i)=0 enddo do ii=1,n i=q(ii) do jj=ja(ii),ja(ii+1)-1 j=q(ja(jj)) if(i.gt.j) then irow=j icol=i aa=a(jj) a(jj)=a(jj+amtx) a(jj+amtx)=aa else irow=i icol=j endif ja(jj)=icol last=irow 10 next=link(last) if(next.eq.0) then link(last)=jj link(jj)=0 else if(icol.lt.ja(next)) then link(last)=jj link(jj)=next else last=next go to 10 endif endif enddo enddo c ja(1)=n+2 do i=1,n len=ja(i) last=i next=link(last) 20 if(next.gt.0) then last=next next=link(last) link(last)=len len=len+1 go to 20 endif ja(i+1)=len link(i)=q(i) enddo c c reorder upper triangle c do i=ja(1),ja(n+1)-1 30 if(link(i).ne.i) then ii=link(i) link(i)=link(ii) link(ii)=ii jj=ja(i) ja(i)=ja(ii) ja(ii)=jj a1=a(i) a2=a(i+amtx) a(i)=a(ii) a(i+amtx)=a(ii+amtx) a(ii)=a1 a(ii+amtx)=a2 go to 30 endif enddo c c diagonal of a c do i=1,n 40 if(link(i).ne.i) then ii=link(i) link(i)=link(ii) link(ii)=ii kk=bindx(i) bindx(i)=bindx(ii) bindx(ii)=kk aa=a(i) a(i)=a(ii) a(ii)=aa go to 40 endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ihp(list,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(*) c c reorder entries in list small to large c if(len.le.1) return n=len/2 do m=n,1,-1 k=m 10 kson=2*k if(kson.le.len) then if(kson.lt.len) then if(list(kson).lt.list(kson+1)) kson=kson+1 endif if(list(k).lt.list(kson)) then itemp=list(k) list(k)=list(kson) list(kson)=itemp k=kson go to 10 endif endif enddo c c do n=len,2,-1 itemp=list(1) list(1)=list(n) list(n)=itemp k=1 20 kson=2*k if(kson.le.n-1) then if(kson.lt.n-1) then if(list(kson).lt.list(kson+1)) kson=kson+1 endif if(list(k).lt.list(kson)) then itemp=list(k) list(k)=list(kson) list(kson)=itemp k=kson go to 20 endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja2jc(n,ja,jc) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),jc(*) c c make jc data structure from ja data structure c do i=1,n jc(i+1)=ja(i+1)-ja(i) enddo c c compute new lengths c do i=ja(1),ja(n+1)-1 k=ja(i)+1 jc(k)=jc(k)+1 enddo c jc(1)=n+2 do i=2,n+1 jc(i)=jc(i)+jc(i-1) enddo c do i=1,n do jj=ja(i),ja(i+1)-1 j=ja(jj) jc(jc(i))=j jc(i)=jc(i)+1 jc(jc(j))=i jc(j)=jc(j)+1 enddo enddo c do i=n+1,2,-1 jc(i)=jc(i-1) enddo jc(1)=n+2 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja2jcb(n,ispd,ja,a,dtol,maxjc,jc,mark,list, + lenjc,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),jc(*),mark(*),list(*) double precision + a(*) c c make jc data structure from ja data structure c iflag=0 lenjc=0 if(ispd.eq.1) then ishift=0 else ishift=ja(n+1)-ja(1) endif do i=1,n list(i)=0 mark(i)=0 jc(i+1)=0 enddo anorm=a(n+1) c c compute new lengths c do i=1,n do 30 jj=ja(i),ja(i+1)-1 j=ja(jj) ee=eltest(a(i),a(jj),a(jj+ishift),a(j)) if(ee.lt.dtol) go to 30 jc(i+1)=jc(i+1)+1 jc(j+1)=jc(j+1)+1 30 enddo enddo c jc(1)=n+2 do i=2,n+1 jc(i)=jc(i)+jc(i-1) enddo c do i=1,n do 20 jj=ja(i),ja(i+1)-1 j=ja(jj) ee=eltest(a(i),a(jj),a(jj+ishift),a(j)) if(ee.lt.dtol) go to 20 jc(jc(i))=j jc(i)=jc(i)+1 jc(jc(j))=i jc(j)=jc(j)+1 20 enddo enddo c do i=n+1,2,-1 jc(i)=jc(i-1) enddo jc(1)=n+2 c num=0 do 10 i=1,n c if(mark(i).ne.0) go to 10 if(dabs(a(i)).ge.anorm) go to 10 if(jc(i).eq.jc(i+1)) go to 10 c c scan for zero diag entries, increase their degree relative to c largest connected entry with non-zero diag c jx=jc(jc(i)) ax=0.0d0 do k=jc(i),jc(i+1)-1 j=jc(k) if(a(j).ne.0.0d0.and.mark(j).eq.0) then call jamap(i,j,ij,ji,ja,ishift) aa=dabs(a(ij)*a(ji)/a(j)) if(aa.gt.ax) then jx=j ax=aa endif endif enddo if(ax.gt.dabs(a(i))) then mark(i)=jx mark(jx)=-i num=num+1 endif 10 continue lenjc=(jc(n+1)-jc(1))/2+n+1 if(num.eq.0) return c c merge rows c next=maxjc+1 do i=n,1,-1 i1=jc(i) i2=jc(i+1)-1 jc(i+1)=next c c shift row i c list(i)=i len=0 do k=i1,i2 j=jc(k) if(list(j).eq.0) then len=len+1 list(j)=list(i) list(i)=j endif if(mark(j).lt.0) then mj=-mark(j) if(list(mj).eq.0) then len=len+1 list(mj)=list(i) list(i)=mj endif endif enddo if(mark(i).gt.0) then mi=mark(i) do k=jc(mi),jc(mi+1)-1 j=jc(k) if(list(j).eq.0) then len=len+1 list(j)=list(i) list(i)=j endif if(mark(j).lt.0) then mj=-mark(j) if(list(mj).eq.0) then len=len+1 list(mj)=list(i) list(i)=mj endif endif enddo endif if(next-len.lt.i1) then iflag=20 return endif do j=1,len next=next-1 jc(next)=list(i) list(i)=list(jc(next)) list(jc(next))=0 enddo list(i)=0 enddo jc(1)=next len=jc(n+1)-jc(1) ishift=next-(n+2) do i=1,len jc(n+1+i)=jc(next+i-1) enddo do i=1,n+1 jc(i)=jc(i)-next+(n+2) enddo c lenjc=(jc(n+1)-jc(1))/2+n+1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja2jf(n,ispd,ja,a,dtol,jf,bindx) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),jf(*),bindx(*) double precision + a(*) c c make blockdiagonal jf data structure from ja data structure c if(ispd.eq.1) then ishift=0 else ishift=ja(n+1)-ja(1) endif do i=1,n jf(i+1)=0 enddo c c compute new lengths c do i=1,n do 10 jj=ja(i),ja(i+1)-1 j=ja(jj) if(bindx(i).ne.bindx(j)) go to 10 ee=eltest(a(i),a(jj),a(jj+ishift),a(j)) if(ee.lt.dtol) go to 10 jf(i+1)=jf(i+1)+1 jf(j+1)=jf(j+1)+1 10 enddo enddo c jf(1)=n+2 do i=2,n+1 jf(i)=jf(i)+jf(i-1) enddo c do i=1,n do 20 jj=ja(i),ja(i+1)-1 j=ja(jj) if(bindx(i).ne.bindx(j)) go to 20 ee=eltest(a(i),a(jj),a(jj+ishift),a(j)) if(ee.lt.dtol) go to 20 jf(jf(i))=j jf(i)=jf(i)+1 jf(jf(j))=i jf(j)=jf(j)+1 20 enddo enddo c do i=n+1,2,-1 jf(i)=jf(i-1) enddo jf(1)=n+2 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja2jc1(n,mark,p,q) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + mark(*),p(*),q(*) do i=1,n if(mark(i).gt.0) then j=mark(i) if(q(i).lt.q(j)) then k=q(i) q(i)=q(j) q(j)=k p(q(i))=i p(q(j))=j endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine vf2vf(nf,nc,vf,q,qc,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),q(*),qc(*),list(*) c c do i=1,nf do j=vf(i),vf(i+1)-1 vf(j)=q(vf(j)) enddo enddo c c save the fine to coarse mapping in q (md ordering not needed) c do i=1,nc list(q(i))=qc(i) enddo do i=1,nc q(i)=list(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine vf2vfc(n,nc,vf,vfc) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),vfc(*) c c make linked list of entries c do i=1,nc+1 vfc(i)=0 enddo do i=1,n do jj=vf(i),vf(i+1)-1 j=vf(jj) vfc(j+1)=vfc(j+1)+1 enddo enddo vfc(1)=nc+2 do i=2,nc+1 vfc(i)=vfc(i)+vfc(i-1) enddo c do i=1,n do jj=vf(i),vf(i+1)-1 j=vf(jj) k=vfc(j) vfc(j)=k+1 vfc(k)=i enddo enddo do i=nc+1,2,-1 vfc(i)=vfc(i-1) enddo vfc(1)=nc+2 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja2jac(n,ja,jc,nc,jac,vf,vfc,maxjac,list,mark,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),ja(*),jac(*),list(*),vfc(*),jc(*),mark(*) c c make linked list of entries c if(nc+1.gt.maxjac) then iflag=20 return endif iflag=0 call ja2jc(n,ja,jc) call vf2vfc(n,nc,vf,vfc) do i=1,n mark(i)=0 enddo jac(1)=nc+2 do i=1,nc len=0 do jj=vfc(i),vfc(i+1)-1 j=vfc(jj) if(mark(j).ne.-i) then len=len+1 mark(j)=-i list(len)=j endif do kk=jc(j),jc(j+1)-1 k=jc(kk) if(mark(k).ne.-i) then len=len+1 mark(k)=-i list(len)=k endif enddo enddo next=jac(i) do jj=1,len j=list(jj) do kk=vf(j),vf(j+1)-1 k=vf(kk) if(mark(k).ne.i) then if(next.gt.maxjac) then iflag=20 return endif jac(next)=k next=next+1 mark(k)=i endif enddo enddo jac(i+1)=next len=jac(i+1)-jac(i) if(len.gt.1) call ihp(jac(jac(i)),len) enddo maxjac=jac(nc+1)-1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkib(nc,qc,bindx,bindxc) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qc(*),bindx(*),bindxc(*) c c update ib data structure for coarse graph c do i=1,nc bindxc(i)=bindx(qc(i)) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine a2ac(n,ispd,ja,a,nc,jac,ac,vf,wt) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),ja(*),jac(*),amtx,acmtx,vmtx,wmtx double precision + a(*),ac(*),wt(*) c c if(ispd.eq.1) then wmtx=1-vf(1) vmtx=wmtx amtx=0 acmtx=0 else wmtx=1-vf(1) vmtx=wmtx+vf(n+1)-vf(1) amtx=ja(n+1)-ja(1) acmtx=jac(nc+1)-jac(1) endif c c initialize c do i=1,jac(nc+1)-1+acmtx ac(i)=0.0d0 enddo c c the main loop c do i=1,n c c diagonal entry c aii=a(i) do kk=vf(i),vf(i+1)-1 k=vf(kk) wtik=wt(kk+wmtx) wtki=wt(kk+vmtx) ac(k)=ac(k)+wtki*aii*wtik do mm=kk+1,vf(i+1)-1 m=vf(mm) wtim=wt(mm+wmtx) wtmi=wt(mm+vmtx) call jacmap(m,k,mk,km,jac,acmtx) if(mk.gt.0) then aa=ac(mk)+wtmi*aii*wtik ac(km)=ac(km)+wtki*aii*wtim ac(mk)=aa endif enddo enddo c c off diagonal entries c do j=ja(i),ja(i+1)-1 aij=a(j) aji=a(j+amtx) do kk=vf(ja(j)),vf(ja(j)+1)-1 k=vf(kk) wtjk=wt(kk+wmtx) wtkj=wt(kk+vmtx) do mm=vf(i),vf(i+1)-1 m=vf(mm) wtim=wt(mm+wmtx) wtmi=wt(mm+vmtx) if(k.eq.m) then ac(k)=ac(k)+wtkj*aji*wtim+wtmi*aij*wtjk else call jacmap(m,k,mk,km,jac,acmtx) if(mk.gt.0) then aa=ac(mk)+wtmi*aij*wtjk ac(km)=ac(km)+wtkj*aji*wtim ac(mk)=aa endif endif enddo enddo enddo enddo c c compute anorm c ac(nc+1)=canorm(nc,ispd,jac,ac) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine jacmap(i,j,ij,ji,ja,amtx) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx c c compute location of a(i,j) and a(j,i) c if(i.lt.j) then imin=ja(i) imax=ja(i+1)-1 10 imid=(imin+imax)/2 if(ja(imid).eq.j) then ij=imid ji=ij+amtx return else if(imid.eq.imax) then ij=0 ji=0 return else if(ja(imid).lt.j) then if(imid.eq.imin) imid=imax imin=imid go to 10 else imax=imid go to 10 endif c else jmin=ja(j) jmax=ja(j+1)-1 20 jmid=(jmin+jmax)/2 if(ja(jmid).eq.i) then ji=jmid ij=ji+amtx return else if(jmid.eq.jmax) then ij=0 ji=0 return else if(ja(jmid).lt.i) then if(jmid.eq.jmin) jmid=jmax jmin=jmid go to 20 else jmax=jmid go to 20 endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sfac(n,ja,a,lenja,lena,ispd,dtol,maxfil,minfil) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx,ibin(400) double precision + a(*) data ibit/0/ c c sparse numeric factorization c nbin=400 if(ispd.ne.1) then amtx=ja(n+1)-ja(1) else amtx=0 endif fact=1.0d4**(1.0d0/dfloat(nbin)) alf=dlog(fact) eps=ceps(ibit) rtol=dmax1(eps,dtol) lenja0=ja(n+1)-1 qn=dfloat(max0(0,maxfil))*dfloat(n)+dfloat(n+1) if(qn.ge.dfloat(lenja0)) go to 30 c c figure out drop tolerance in case of violation of maxfil c jatrgt=idint(qn+0.5d0) do i=1,nbin ibin(i)=0 enddo do i=1,n do j=ja(i),ja(i+1)-1 tt=eltest(a(i),a(j),a(j+amtx),a(ja(j)))/rtol if(tt.ge.1.0d0) then it=min0(nbin,1+idint(dlog(tt)/alf)) ibin(it)=ibin(it)+1 endif enddo enddo ibin(nbin)=ibin(nbin)+n+1 do i=nbin-1,1,-1 ibin(i)=ibin(i+1)+ibin(i) enddo if(ibin(1).lt.jatrgt) go to 50 do i=1,nbin-1 if(ibin(i+1).le.jatrgt.and.ibin(i).gt.jatrgt) go to 20 enddo i=nbin 20 rtol=rtol*fact**i cc write(6,*) 'sfac0',n,i,rtol go to 50 c c figure out drop tolerance in case of violation of minfil c 30 jatrgt=minfil*n+n+1 if(jatrgt.lt.lenja0) go to 50 kount=n+1 stol=rtol*1.0d-2 do i=1,nbin ibin(i)=0 enddo do i=1,n do j=ja(i),ja(i+1)-1 tx=eltest(a(i),a(j),a(j+amtx),a(ja(j))) if(tx/rtol.ge.1.0d0) kount=kount+1 tt=tx/stol if(tt.ge.1.0d0) then it=min0(nbin,1+idint(dlog(tt)/alf)) ibin(it)=ibin(it)+1 endif enddo enddo if(kount.ge.jatrgt) go to 50 ibin(nbin)=ibin(nbin)+n+1 do i=nbin-1,1,-1 ibin(i)=ibin(i+1)+ibin(i) enddo if(ibin(1).lt.jatrgt) go to 50 do i=1,nbin-1 if(ibin(i+1).le.jatrgt.and.ibin(i).gt.jatrgt) go to 40 enddo i=nbin 40 rtol=stol*fact**i cc write(6,*) 'sfac1',n,i,rtol c c now do it for real c 50 jai=ja(1) do i=1,n next=ja(i) do j=jai,ja(i+1)-1 tt=eltest(a(i),a(j),a(j+amtx),a(ja(j)))/rtol if(tt.ge.1.0d0) then ja(next)=ja(j) a(next)=a(j) a(next+amtx)=a(j+amtx) next=next+1 endif enddo jai=ja(i+1) ja(i+1)=next enddo lenja=ja(n+1)-1 if(ispd.ne.1) then nnz=lenja-(n+1) do i=1,nnz a(lenja+i)=a(lenja0+i) enddo lena=lenja+nnz else lena=lenja endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine crsncr(n,nc,p,q,jf,vtype,qc,ncfact, + ispd,ja,a,ju,u,dv,dw,z,z0,az,nblock,bindx,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),jf(*),vtype(*),qc(*),bindx(*),ja(*),ju(*) double precision + a(*),u(*),dv(*),dw(*),z(*),az(*),coef0(2), 1 coeff(2),z0(*) c iflag=0 nswap=-1 itmax=2 thresh=0.1d0 eps=1.0d-10 bias=1.0d1 itnum=0 nctrgt=max0(idint(dfloat(n)/dfloat(ncfact)),1) c call ceig(n,ispd,ja,a,ju,u,dv,dw,z,az,0,z0,coef0) do i=1,n z0(i)=dabs(dv(i))+dabs(dw(i)) if(vtype(i).ne.1) then vtype(i)=0 if(jf(i).eq.jf(i+1)) vtype(i)=-1 endif enddo c c 10 itnum=itnum+1 if(itnum.gt.itmax.or.nswap.eq.0) go to 30 call ceig(n,ispd,ja,a,ju,u,dv,dw,z,az,nc,vtype,coeff) c do i=1,nblock az(i)=0.0d0 enddo cw=10.0d0**(coef0(1)-coeff(1)) cv=10.0d0**(coef0(2)-coeff(2)) do i=1,n z(i)=dabs(dw(i))*cw+dabs(dv(i))*cv az(bindx(i))=dmax1(az(bindx(i)),z0(i)) enddo do i=1,n if(vtype(i).eq.1) then ss=z0(i) do jj=jf(i),jf(i+1)-1 ss=dmax1(ss,z0(jf(jj))) enddo z(i)=bias*dmax1(ss/az(bindx(i)),eps) else if(vtype(i).eq.-1) then z(i)=0.0d0 else z(i)=-z(i)/az(bindx(i)) endif c c p/q share space with dv/dw c p(i)=i q(i)=i enddo c nn=n/2 do k=nn,1,-1 call updhp(k,n,p,q,z,0) enddo do k=n,2,-1 kk=p(1) p(1)=p(k) p(k)=kk q(p(1))=1 q(p(k))=k call updhp(1,k-1,p,q,z,0) enddo c c 1 -- (nf) are fine grid ordered by decreasing size c (nf+1) -- n are coarse grid ordered by increasing size c c too many coarse points c nf=n-nc if(nc.gt.nctrgt) then do ii=nf+1,n-nctrgt i=p(ii) vtype(i)=0 nc=nc-1 enddo go to 10 c c too few coarse points c else if(nc.lt.nctrgt) then do ii=nf+1,n i=p(ii) if(dabs(z(i)).gt.thresh) go to 15 vtype(i)=0 nc=nc-1 enddo 15 do ii=1,nctrgt-nc i=p(ii) if(dabs(z(i)).le.thresh) go to 10 vtype(i)=1 nc=nc+1 enddo else c c simple swaps c nn=min0(nf,nc) nswap=0 do i=1,nn kc=p(nf+i) kf=p(i) if(z(kc).ge.dabs(z(kf))) go to 10 if(vtype(kf).eq.-1) go to 10 nswap=nswap+1 vtype(kf)=1 vtype(kc)=0 enddo endif c 30 ncc=nc nc=0 do i=1,n if(vtype(i).gt.0) then nc=nc+1 qc(nc)=i endif enddo if(nc.ne.ncc) stop 9551 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine crsncm(n,nc,p,q,jr,jf,maxjf,vtype,qc,ncfact,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),jf(*),vtype(*),jr(*),qc(*) c iflag=0 jtmax=1 jtnum=0 nctrgt=max0(idint(dfloat(n)/dfloat(ncfact)),1) ncmax=(nctrgt*3)/2 c 10 do i=1,n p(i)=i q(i)=i vtype(i)=0 if(jf(i).eq.jf(i+1)) vtype(i)=-1 enddo c c sort out regions c itmax=2 nr=0 iptr=1 next=1 20 k=p(next) if(next.ge.iptr) then nr=nr+1 jr(nr)=next iptr=iptr+1 endif next=next+1 do j=jf(k),jf(k+1)-1 m=q(jf(j)) if(m.ge.iptr.and.m.le.n) then p(m)=p(iptr) p(iptr)=jf(j) q(p(m))=m q(p(iptr))=iptr iptr=iptr+1 endif enddo if(next.le.n) go to 20 if(nr.ge.n) then iflag=1 return endif jr(nr+1)=n+1 c c order more or less lengthwise using rcm c do itnum=1,itmax do j=1,nr i1=jr(j) i2=jr(j+1)-1 iseed=p(i2) p(i2)=p(i1) p(i1)=iseed q(p(i1))=i1 q(p(i2))=i2 enddo iptr=1 next=1 30 k=p(next) if(next.ge.iptr) iptr=iptr+1 next=next+1 do j=jf(k),jf(k+1)-1 m=q(jf(j)) if(m.ge.iptr.and.m.le.n) then p(m)=p(iptr) p(iptr)=jf(j) q(p(m))=m q(p(iptr))=iptr iptr=iptr+1 endif enddo if(next.le.n) go to 30 enddo c c mark coarse graph vertices c nc=0 do k=1,n i=p(k) if(vtype(i).eq.0) then nc=nc+1 qc(nc)=i vtype(i)=1 do j=jf(i),jf(i+1)-1 vtype(jf(j))=-1 enddo endif enddo c jtnum=jtnum+1 if(jtnum.gt.jtmax.or.nc.le.ncmax) return c c compute length of new jf array c do i=1,n q(i)=0 enddo num=0 iptr=jf(n+1) jf(iptr)=iptr+n+1 next=jf(iptr) do i=1,n call cp2(i,jf,len,p,q) if(next+len+jf(i+1)-jf(i).gt.maxjf) return num=num+len do j=jf(i),jf(i+1)-1 jf(next)=jf(j) next=next+1 enddo do j=1,len jf(next)=p(j) next=next+1 enddo iptr=iptr+1 jf(iptr)=next enddo ishift=jf(n+1)-1 do i=1,jf(iptr)-1 jf(i)=jf(i+ishift) enddo do i=1,n+1 jf(i)=jf(i)-ishift enddo go to 10 c end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cp2(i,jf,len,list,q) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jf(*),list(*),q(*) c c compute lenght two paths from vertex i (assume q init to 0) c do k=jf(i),jf(i+1)-1 q(jf(k))=-k enddo q(i)=-i len=0 do jj=jf(i),jf(i+1)-1 j=jf(jj) do kk=jf(j),jf(j+1)-1 k=jf(kk) if(q(k).eq.0) then c c first length 2 path to k c len=len+1 list(len)=-k q(k)=len c c subsequent length 2 paths to k c else if(q(k).gt.0) then list(q(k))=k endif enddo enddo c c do k=jf(i),jf(i+1)-1 q(jf(k))=0 enddo q(i)=0 do k=1,len q(iabs(list(k)))=0 enddo c c shorten list c len0=len len=0 do k=1,len0 if(list(k).gt.0) then len=len+1 list(len)=list(k) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cvf(nf,nc,ispd,jf,maxvf,vf,maxwt,vtype,q,qc,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),jf(*),vtype(*),qc(*),q(*) c iflag=0 if(nf+2.gt.maxvf) then iflag=20 return endif do i=1,nf vtype(i)=-1 vf(i+1)=0 enddo do i=1,nc q(qc(i))=i vtype(qc(i))=1 enddo c c compute pointers c vf(1)=nf+2 do i=1,nf if(vtype(i).ge.0) then len=1 else len=0 do jj=jf(i),jf(i+1)-1 j=jf(jj) if(vtype(j).ge.0) len=len+1 enddo endif vf(i+1)=vf(i)+len enddo c if(vf(nf+1)-1.gt.maxvf) then iflag=20 return endif c c fill out c do i=1,nf k=vf(i) if(vtype(i).ge.0) then vf(k)=q(i) else do jj=jf(i),jf(i+1)-1 j=jf(jj) if(vtype(j).ge.0) then vf(k)=q(j) k=k+1 endif enddo endif enddo c maxvf=vf(nf+1)-1 if(ispd.eq.1) then lenwt=vf(nf+1)-vf(1) else lenwt=2*(vf(nf+1)-vf(1)) endif c if(lenwt.gt.maxwt) then iflag=20 return endif maxwt=lenwt c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cwt(nf,nc,ispd,vf,wt,vtype,ja,a,qc,dv,dw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),vtype(*),vmtx,wmtx,ja(*),amtx,qc(*) double precision + wt(*),a(*),dv(*),dw(*) c c anorm=a(nf+1) if(ispd.eq.1) then wmtx=1-vf(1) vmtx=wmtx amtx=0 else wmtx=1-vf(1) vmtx=wmtx+vf(nf+1)-vf(1) amtx=ja(nf+1)-ja(1) endif do i=1,nf vtype(i)=-1 enddo do i=1,nc vtype(qc(i))=1 enddo c do i=1,nf if(vtype(i).ge.0) then wt(vf(i)+vmtx)=1.0d0 wt(vf(i)+wmtx)=1.0d0 else if(vtype(i).lt.0) then if(dabs(a(i)).le.anorm) then ainv=(a(i)/anorm)/anorm else ainv=1.0d0/a(i) endif do jj=vf(i),vf(i+1)-1 j=qc(vf(jj)) call jacmap(i,j,ij,ji,ja,amtx) if(ij.gt.0) then wt(jj+wmtx)=-a(ij)*ainv wt(jj+vmtx)=-a(ji)*ainv else wt(jj+wmtx)=0.0d0 wt(jj+vmtx)=0.0d0 endif enddo call crw(i,wmtx,vf,wt,qc,dw) if(ispd.ne.1) call crw(i,vmtx,vf,wt,qc,dv) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine crw(i,wmtx,vf,wt,qc,dw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),wmtx,qc(*) double precision + wt(*),dw(*) c c if(vf(i+1).eq.vf(i)) return eps=1.0d-4 eps1=1.0d-1 c c check simple scaling option c aa=0.0d0 do jj=vf(i),vf(i+1)-1 aa=aa+dabs(wt(jj+wmtx)) enddo c c make row exact for constant c if(aa.le.eps) then c=1.0d0/dfloat(vf(i+1)-vf(i)) do jj=vf(i),vf(i+1)-1 wt(jj+wmtx)=c enddo aa=1.0d0 else do jj=vf(i),vf(i+1)-1 wt(jj+wmtx)=wt(jj+wmtx)/aa enddo endif c c check smooth vector c a11=dfloat(vf(i+1)-vf(i)) a12=0.0d0 a22=0.0d0 b2=0.0d0 do jj=vf(i),vf(i+1)-1 j=qc(vf(jj)) a22=a22+dw(j)**2 b2=b2+wt(jj+wmtx)*dw(j) if(wt(jj+wmtx).gt.0.0d0) then a12=a12+dw(j) else a12=a12-dw(j) endif enddo b2=dw(i)-b2 det=a11*a22-a12**2 if(det.le.(a11+a22)*eps1) return c c chose to interpolate two vectors correctly c x1=-a12*b2/det x2=a11*b2/det do jj=vf(i),vf(i+1)-1 j=qc(vf(jj)) if(wt(jj+wmtx).gt.0.0d0) then wt(jj+wmtx)=wt(jj+wmtx)+x1+x2*dw(j) else wt(jj+wmtx)=wt(jj+wmtx)-x1+x2*dw(j) endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ceig(n,ispd,ja,a,ju,u,dv,dw,z,az,nc,vtype,coeff) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),vtype(*) double precision + a(*),u(*),dv(*),dw(*),z(*),az(*),coeff(2) c c coeff(1)=0.0d0 coeff(2)=0.0d0 itmax=3 eps=1.0d-3 if(nc.ge.n) return if(nc.le.0) then do i=1,n vtype(i)=0 enddo endif do i=1,n if(vtype(i).gt.0) then dv(i)=0.0d0 dw(i)=0.0d0 else dv(i)=1.0d0 dw(i)=1.0d0 endif enddo do itnum=1,itmax call mtxmlt(n,ja,a,dw,az,ispd) call snsilu(n,ju,u,z,az,ispd) wnorm=0.0d0 do i=1,n if(vtype(i).gt.0) then az(i)=0.0d0 else az(i)=dw(i)-z(i) wnorm=dmax1(az(i),wnorm) endif enddo if(wnorm.lt.eps) go to 50 coeff(1)=coeff(1)-dlog10(wnorm) do i=1,n dw(i)=az(i)/wnorm enddo enddo 50 if(ispd.eq.1) then do i=1,n dv(i)=dw(i) enddo coeff(2)=coeff(1) return endif jspd=-(1+ispd) do itnum=1,itmax call mtxmlt(n,ja,a,dv,az,jspd) call snsilu(n,ju,u,z,az,jspd) vnorm=0.0d0 do i=1,n if(vtype(i).gt.0) then az(i)=0.0d0 else az(i)=dv(i)-z(i) vnorm=dmax1(az(i),vnorm) endif enddo if(vnorm.lt.eps) return coeff(2)=coeff(2)-dlog10(vnorm) do i=1,n dv(i)=az(i)/vnorm enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mg(ispd,lvl,mxcg,eps1,ja,a,dr,br,ka,iequv, + relerr,iflag,z,hist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ka(10,*),ja(*),iequv(*) double precision + a(*),dr(*),br(*),z(*),hist(*) data ibit/0/ c c lenz=6*n+2*ns (ispd.eq.1) c lenz=11*n+2*ns (ispd.ne.1) c c compute initial norm of b c iflag=0 eps2=ceps(ibit)*8.0d0 eps=dmax1(eps1,eps2) epsi=1.0d0/dmin1(eps,eps2) n=ka(1,1) ns=ka(2,lvl+1)-1 i1=1 i2=i1+n i3=i2+n i4=i3+n if(ispd.eq.1) then j1=i1 j2=i2 j3=i3 j4=i4 j5=i4 else j1=i4+n j2=j1+n j3=j2+n j4=j3+n j5=j4+n endif iz=j5+n call getptr(lvl,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) c c do i=1,n if(iequv(i).eq.i) then dr(ja(iqptr+i-1))=br(i) else dr(ja(iqptr+i-1))=0.0d0 endif enddo c if(ispd.eq.1) then call cscg(n,ispd,lvl,mxcg,eps,epsi,ja,a,br,dr, + z(i1),z(i2),z(i3),z(i4),hist,ka,z(iz),relerr,iflag) c else call csbcg(n,ispd,lvl,mxcg,eps,epsi,ja,a,br,dr, + z(j5),z(i1),z(i2),z(i3),z(i4),z(j1),z(j2), 1 z(j3),z(j4),hist,ka,z(iz),relerr,iflag) endif c if(iflag.eq.0) then do i=1,n dr(i)=br(ja(iqptr+iequv(i)-1)) enddo else do i=1,n dr(i)=0.0d0 enddo endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine perm(n,x,z,ja,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + x(*),z(*) c c reorder x c iqptr=ja(n+1)+n if(isw.eq.1) then do i=1,n z(ja(iqptr+i-1))=x(i) enddo else do i=1,n z(i)=x(ja(iqptr+i-1)) enddo endif do i=1,n x(i)=z(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cycle(ispd,lvl,ja,a,x,b,ka,z) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ka(10,*),kount(101),ja(*) double precision + x(*),a(*),b(*),z(*) c c compute initial norm of b c ivwcy=1 n=ka(1,1) ns=ka(2,lvl+1)-1 id=0 ir=id+ns i1=ir+ns+1 i2=i1+n level=lvl call getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) do i=1,nf z(ir+i+nptr-1)=b(i) z(id+i+nptr-1)=0.0d0 enddo kount(lvl)=-1 c c c the smoothing iterations c 10 if(level.eq.1) then kount(level)=ivwcy+1 else kount(level)=kount(level)+1 endif call snsilu(nf,ja(juptr),a(iuptr),z(i1),z(ir+nptr),ispd) call resid(nf,ispd,ja(japtr),a(iaptr),z(id+nptr), + z(ir+nptr),z(i1),z(i2)) c c if(level.eq.lvl.and.kount(lvl).ge.1) then do i=1,nf x(i)=z(id+i+nptr-1) enddo return endif c if(kount(level).gt.ivwcy) then c c increase level, go to finer grid c level=level+1 call getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) call cr2fn(nf,nc,ispd,z(i1),z(id+ncptr), + ja(jvptr),a(ivptr)) call resid(nf,ispd,ja(japtr),a(iaptr),z(id+nptr), + z(ir+nptr),z(i1),z(i2)) else c c decrease level, go to coarse grid c call fn2cr(nf,nc,ispd,z(ir+nptr),z(ir+ncptr), + ja(jvptr),a(ivptr)) do i=1,nc z(id+i+ncptr-1)=0.0d0 enddo level=level-1 kount(level)=0 call getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) endif go to 10 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cscg(n,ispd,lvl,mxcg,eps,epsi,ja,a,dr,br, + pr,apr,zr,azr,hist,ka,z,relerr,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(10,*) double precision + a(*),hist(*),dr(*),br(*),pr(*),apr(*), 1 zr(*),azr(*),z(*) c c initialize c iflag=0 epsmin=0.5d0 relerr=0.0d0 c c compute initial norm of b c do i=1,n dr(i)=0.0d0 enddo brnorm=rl2nrm(n,br) call hist1(hist,0,brnorm) if(brnorm.le.0.0d0) return rrnorm=brnorm c c compute initial pr and apr c call cycle(ispd,lvl,ja,a,pr,br,ka,z) call mtxmlt(n,ja,a,pr,apr,ispd) bp=rl2ip(n,pr,br) if(bp.eq.0.0d0) return c c the main loop c do 100 itnum=1,mxcg c c compute sigma, the next 'psuedo residual' and precondition c pap=rl2ip(n,pr,apr) do i=1,n azr(i)=pap*br(i)-bp*apr(i) enddo zscale=rl2nrm(n,azr) if(zscale.gt.0.0d0) then do i=1,n azr(i)=azr(i)/zscale enddo endif call cycle(ispd,lvl,ja,a,zr,azr,ka,z) c c compute alphas c bz=rl2ip(n,zr,azr)*zscale/pap zap=-bz/bp do i=1,n zr(i)=zr(i)-zap*pr(i) enddo call mtxmlt(n,ja,a,zr,azr,ispd) zaz=rl2ip(n,zr,azr) c c decide on pivoting strategy c if(dabs(pap)*rrnorm.lt.zscale) then qscale=tstpiv(n,bp,bz,pap,zaz,br,apr,azr) if(qscale.lt.dabs(zscale*zaz)) go to 50 endif c c the case of a 1 x 1 pivot c alpha=bp/pap bp=bz do i=1,n dr(i)=dr(i)+alpha*pr(i) br(i)=br(i)-alpha*apr(i) pr(i)=zr(i) apr(i)=azr(i) enddo c c convergence test c rrnorm=rl2nrm(n,br) call hist1(hist,itnum,rrnorm) relerr=rrnorm/brnorm cc write(6,*) itnum,relerr if(relerr.le.eps.or.bp.eq.0.0d0) return if(relerr.gt.epsi) go to 200 go to 100 c c the case of a 2 x 2 pivot c 50 alphap=bp/pap alphaz=bz/zaz do i=1,n dr(i)=dr(i)+(alphap*pr(i)+alphaz*zr(i)) br(i)=br(i)-(alphap*apr(i)+alphaz*azr(i)) enddo c c convergence test c rrnorm=rl2nrm(n,br) call hist1(hist,itnum,-rrnorm) relerr=rrnorm/brnorm cc write(6,*) -itnum,relerr if(relerr.le.eps) return if(relerr.gt.epsi) go to 200 c c compute next direction c call cycle(ispd,lvl,ja,a,apr,br,ka,z) bp=rl2ip(n,apr,br) betaz=bp/bz do i=1,n pr(i)=apr(i)+betaz*zr(i) enddo call mtxmlt(n,ja,a,pr,apr,ispd) 100 continue if(relerr.gt.epsmin) iflag=12 c return 200 iflag=-12 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine csbcg(n,ispd,lvl,mxcg,eps,epsi,ja,a,dr,br,bl, + pr,apr,zr,azr,pl,apl,zl,azl,hist,ka,z,relerr,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(10,*) double precision + a(*),hist(*),dr(*),br(*),pr(*),apr(*),zr(*),azr(*), 1 bl(*),pl(*),apl(*),zl(*),azl(*),z(*) c c initialize c iflag=0 epsmin=0.5d0 relerr=0.0d0 c c compute initial norm of b c do i=1,n dr(i)=0.0d0 bl(i)=br(i) enddo jspd=-(1+ispd) brnorm=rl2nrm(n,br) blnorm=rl2nrm(n,bl) call hist1(hist,0,brnorm) if(dmin1(brnorm,blnorm).le.0.0d0) return rrnorm=brnorm c c compute initial pr and apr c call cycle(ispd,lvl,ja,a,pr,br,ka,z) call cycle(jspd,lvl,ja,a,pl,bl,ka,z) call mtxmlt(n,ja,a,pr,apr,ispd) call mtxmlt(n,ja,a,pl,apl,jspd) bp=rl2ip(n,pl,br) if(bp.eq.0.0d0) return c c the main loop c do 100 itnum=1,mxcg c c compute sigma, the next 'psuedo residual' and precondition c pap=rl2ip(n,pl,apr) do i=1,n azr(i)=pap*br(i)-bp*apr(i) azl(i)=pap*bl(i)-bp*apl(i) enddo zscale=rl2nrm(n,azr) if(zscale.gt.0.0d0) then do i=1,n azr(i)=azr(i)/zscale azl(i)=azl(i)/zscale enddo endif call cycle(ispd,lvl,ja,a,zr,azr,ka,z) call cycle(jspd,lvl,ja,a,zl,azl,ka,z) c c compute alphas c bz=rl2ip(n,zl,azr)*zscale/pap zap=-bz/bp do i=1,n zr(i)=zr(i)-zap*pr(i) zl(i)=zl(i)-zap*pl(i) enddo call mtxmlt(n,ja,a,zr,azr,ispd) call mtxmlt(n,ja,a,zl,azl,jspd) zaz=rl2ip(n,zl,azr) c c decide on pivoting strategy c if(dabs(pap)*rrnorm.lt.zscale) then qscale=tstpiv(n,bp,bz,pap,zaz,br,apr,azr) if(qscale.lt.dabs(zscale*zaz)) go to 50 endif c c the case of a 1 x 1 pivot c alpha=bp/pap bp=bz do i=1,n dr(i)=dr(i)+alpha*pr(i) br(i)=br(i)-alpha*apr(i) bl(i)=bl(i)-alpha*apl(i) pr(i)=zr(i) pl(i)=zl(i) apr(i)=azr(i) apl(i)=azl(i) enddo c c convergence test c rrnorm=rl2nrm(n,br) cc rlnorm=rl2nrm(n,bl) call hist1(hist,itnum,rrnorm) relerr=rrnorm/brnorm cc write(6,*) itnum,relerr if(relerr.le.eps) return if(relerr.gt.epsi) go to 200 go to 100 c c the case of a 2 x 2 pivot c 50 alphap=bp/pap alphaz=bz/zaz do i=1,n dr(i)=dr(i)+(alphap*pr(i)+alphaz*zr(i)) br(i)=br(i)-(alphap*apr(i)+alphaz*azr(i)) bl(i)=bl(i)-(alphap*apl(i)+alphaz*azl(i)) enddo c c convergence test c rrnorm=rl2nrm(n,br) cc rlnorm=rl2nrm(n,bl) call hist1(hist,itnum,-rrnorm) relerr=rrnorm/brnorm cc write(6,*) -itnum,relerr if(relerr.le.eps) return if(relerr.gt.epsi) go to 200 c c compute next direction c call cycle(ispd,lvl,ja,a,apr,br,ka,z) call cycle(jspd,lvl,ja,a,apl,bl,ka,z) bp=rl2ip(n,apl,br) betaz=bp/bz do i=1,n pr(i)=apr(i)+betaz*zr(i) pl(i)=apl(i)+betaz*zl(i) enddo call mtxmlt(n,ja,a,pr,apr,ispd) call mtxmlt(n,ja,a,pl,apl,jspd) 100 continue if(relerr.gt.epsmin) iflag=12 c return 200 iflag=-12 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function tstpiv(n,bp,bz,pap,zaz,br,apr,azr) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + br(*),apr(*),azr(*) c c compute norm to decide between 1x1 and 2x2 pivoting c alphap=bp*zaz alphaz=bz*pap alpha=zaz*pap qscale=0.0d0 qmax=0.0d0 do i=1,n dq=alpha*br(i)-(alphap*apr(i)+alphaz*azr(i)) if(dabs(dq).lt.qmax) then qscale=qscale+(dq/qmax)**2 else if(dq.ne.0.0d0) then qscale=1.0d0+qscale*(qmax/dq)**2 qmax=dabs(dq) endif enddo tstpiv=dsqrt(qscale)*qmax return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine resid(n,ispd,ja,a,x,b,p,ap) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + a(*),x(*),b(*),p(*),ap(*) c c residual update c call mtxmlt(n,ja,a,p,ap,ispd) do i=1,n x(i)=x(i)+p(i) b(i)=b(i)-ap(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) c implicit double precision (a-h,o-z) implicit integer (i-n) c integer + ka(10,*) c c get pointers for level c k=lvl+1-level nf =ka(1,k) nptr =ka(2,k) japtr=ka(3,k) iaptr=ka(4,k) juptr=ka(5,k) iuptr=ka(6,k) jvptr=ka(7,k) ivptr=ka(8,k) iqptr=ka(9,k) ibptr=ka(10,k) if(level.gt.1) then nc=ka(1,k+1) ncptr=ka(2,k+1) else nc=0 ncptr=0 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fn2cr(nf,nc,ispd,rf,rc,vf,wt) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),vmtx double precision + rf(*),rc(*),wt(*) c c fine to coarse transfer c vmtx=1-vf(1) if(ispd.eq.0) vmtx=vmtx+vf(nf+1)-vf(1) do i=1,nc rc(i)=0.0d0 enddo c do i=1,nf do j=vf(i),vf(i+1)-1 rc(vf(j))=rc(vf(j))+wt(j+vmtx)*rf(i) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cr2fn(nf,nc,ispd,xf,xc,vf,wt) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vf(*),wmtx double precision + xf(*),xc(*),wt(*) c c coarse to fine transfer c wmtx=1-vf(1) if(ispd.eq.-1) wmtx=wmtx+vf(nf+1)-vf(1) do i=1,nf xf(i)=0.0d0 do j=vf(i),vf(i+1)-1 xf(i)=xf(i)+wt(j+wmtx)*xc(vf(j)) enddo enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxmlt(n,ja,a,x,b,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),umtx,lmtx double precision + a(*),x(*),b(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c c compute b=a*x c lmtx=0 umtx=0 if(ispd.eq.0) lmtx=ja(n+1)-ja(1) if(ispd.eq.-1) umtx=ja(n+1)-ja(1) c do i=1,n b(i)=a(i)*x(i) enddo c do i=1,n do jj=ja(i),ja(i+1)-1 j=ja(jj) b(i)=b(i)+a(jj+umtx)*x(j) b(j)=b(j)+a(jj+lmtx)*x(i) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxml0(n,ja,a,x,b,iequv,p,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),iequv(*),p(*),qi,umtx,lmtx double precision + a(*),x(*),b(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c c compute b=a*x c lmtx=0 umtx=0 if(ispd.eq.0) lmtx=ja(n+1)-ja(1) if(ispd.eq.-1) umtx=ja(n+1)-ja(1) iqptr=ja(n+1)-1+n c do i=1,n qi=ja(iqptr+i) b(i)=a(qi)*x(i) p(qi)=i enddo c do i=1,n qi=ja(iqptr+i) do jj=ja(qi),ja(qi+1)-1 j=p(ja(jj)) b(i)=b(i)+a(jj+umtx)*x(j) b(j)=b(j)+a(jj+lmtx)*x(i) enddo enddo c do i=1,n if(iequv(i).ne.i) b(i)=0.0d0 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sfilu(n,ja,a,maxju,ju,maxu,u,tu,tl,list,mark, + indx,ispd,dtol,maxfil,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),list(*),mark(*),indx(*),amtx,umtx, 1 ibin(400) double precision + a(*),u(*),tu(*),tl(*) data ibit/0/ c c sparse numeric factorization c nbin=400 if(min0(maxju,maxu).lt.n+1) then iflag=20 return endif if(ispd.ne.1) then lenju=min0(maxju,(maxu+n+1)/2) else lenju=min0(maxju,maxu) endif qn=dfloat(max0(0,maxfil))*dfloat(n)+dfloat(n+1) if(qn.lt.dfloat(lenju)) lenju=idint(qn+0.5d0) if(ispd.ne.1) then amtx=ja(n+1)-ja(1) umtx=lenju-(n+1) else amtx=0 umtx=0 endif fact=1.0d4**(1.0d0/dfloat(nbin)) alf=dlog(fact) eps=ceps(ibit) rtol=dmax1(eps,dtol) u(n+1)=a(n+1) c 5 ju(1)=n+2 unorm=u(n+1) do i=1,n mark(i)=0 list(i)=0 indx(i)=0 enddo c num=0 do i=1,nbin ibin(i)=0 enddo c do i=1,n c c initialize row i and col i in tu and tl c mark(i)=i len=0 tu(i)=a(i) tl(i)=a(i) do jj=ja(i),ja(i+1)-1 j=ja(jj) tu(j)=a(jj) tl(j)=a(jj+amtx) mark(j)=mark(i) mark(i)=j len=len+1 enddo c c do outer product updates c lk=list(i) 10 if(lk.gt.0) then k=lk lk=list(k) j1=indx(k) j2=ju(k+1)-1 if(dabs(u(k)).le.unorm) then uinv=(u(k)/unorm)/unorm else uinv=1.0d0/u(k) endif su=u(j1)*uinv sl=u(j1+umtx)*uinv c do jj=j1,j2 j=ju(jj) if(mark(j).ne.0) then tu(j)=tu(j)-sl*u(jj) tl(j)=tl(j)-su*u(jj+umtx) else tu(j)=-sl*u(jj) tl(j)=-su*u(jj+umtx) mark(j)=mark(i) mark(i)=j len=len+1 endif enddo if(j1.lt.j2) then j=ju(j1+1) list(k)=list(j) list(j)=k indx(k)=j1+1 endif go to 10 endif c c check diagonal entry c u(i)=tu(i) c c make ju for this row c next=ju(i) do j=1,len k=mark(i) tt=eltest(u(i),tu(k),tl(k),a(k))/rtol if(tt.ge.1.0d0) then it=min0(nbin,1+idint(dlog(tt)/alf)) ibin(it)=ibin(it)+1 if(next.lt.lenju) then ju(next)=k next=next+1 else num=num+1 endif endif mark(i)=mark(k) mark(k)=0 enddo mark(i)=0 ju(i+1)=next len=next-ju(i) if(len.gt.1) call ihp(ju(ju(i)),len) c c move tl, tu to u c do jj=ju(i),ju(i+1)-1 j=ju(jj) u(jj)=tu(j) u(jj+umtx)=tl(j) enddo c if(ju(i).lt.ju(i+1)) then j=ju(ju(i)) list(i)=list(j) list(j)=i indx(i)=ju(i) endif enddo if(num.gt.0) then do i=nbin-1,1,-1 ibin(i)=ibin(i+1)+ibin(i) enddo theta=1.01d0+0.4d0*dfloat(num)/dfloat(num+lenju-(n+1)) nnz=idint(dfloat(lenju-(n+1))/theta) do i=1,nbin-1 if(ibin(i+1).le.nnz.and.ibin(i).gt.nnz) go to 20 enddo i=nbin 20 rtol=rtol*fact**i cc write(6,*) 'sfilu',n,i,num, cc + float(num)/float(num+lenju-(n+1)),rtol go to 5 endif iflag=0 c c shift u for non symmetric case c maxju=ju(n+1)-1 if(ispd.ne.1) then nnz=maxju-(n+1) do i=1,nnz u(maxju+i)=u(lenju+i) enddo maxu=maxju+nnz else maxu=maxju endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function eltest(a11,a12,a21,a22) c implicit double precision (a-h,o-z) implicit integer (i-n) c eltest=1.0d0 aa=dmax1(dabs(a11),dabs(a22),dabs(a12),dabs(a21)) if(aa.eq.0.0d0) return bd=(dabs(a11)/aa)*(dabs(a22)/aa) if(bd.eq.0.0d0) return cc bn=(abs(a21)/aa)*(abs(a12)/aa) cc eltest=sqrt(bn/bd) eltest=dmax1(dabs(a21),dabs(a12))/(aa*dsqrt(bd)) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine snfilu(n,ja,a,ju,u,tu,tl,list,mark,indx,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),list(*),mark(*),indx(*),amtx,umtx double precision + a(*),u(*),tu(*),tl(*) c c sparse numeric factorization c if(ispd.ne.1) then amtx=ja(n+1)-ja(1) umtx=ju(n+1)-ju(1) else amtx=0 umtx=0 endif u(n+1)=a(n+1) unorm=u(n+1) do i=1,n mark(i)=0 list(i)=0 indx(i)=0 enddo c do i=1,n c c initialize row i and col i in tu and tl c mark(i)=1 do jj=ju(i),ju(i+1)-1 j=ju(jj) tu(j)=0.0d0 tl(j)=0.0d0 mark(j)=1 enddo tu(i)=a(i) tl(i)=a(i) do jj=ja(i),ja(i+1)-1 j=ja(jj) tu(j)=a(jj) tl(j)=a(jj+amtx) enddo c c do outer product updates c lk=list(i) 10 if(lk.gt.0) then k=lk lk=list(k) j1=indx(k) j2=ju(k+1)-1 if(dabs(u(k)).le.unorm) then uinv=(u(k)/unorm)/unorm else uinv=1.0d0/u(k) endif su=u(j1)*uinv sl=u(j1+umtx)*uinv c do jj=j1,j2 j=ju(jj) if(mark(j).ne.0) then tu(j)=tu(j)-sl*u(jj) tl(j)=tl(j)-su*u(jj+umtx) endif enddo if(j1.lt.j2) then j=ju(j1+1) list(k)=list(j) list(j)=k indx(k)=j1+1 endif go to 10 endif c c move tl, tu to u c u(i)=tu(i) mark(i)=0 do jj=ju(i),ju(i+1)-1 j=ju(jj) u(jj)=tu(j) u(jj+umtx)=tl(j) mark(j)=0 enddo c if(ju(i).lt.ju(i+1)) then j=ju(ju(i)) list(i)=list(j) list(j)=i indx(i)=ju(i) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine snsilu(n,ju,u,x,b,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ju(*),lmtx,umtx double precision + u(*),x(*),b(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c c solve a*x=b c lmtx=0 umtx=0 if(ispd.eq.0) lmtx=ju(n+1)-ju(1) if(ispd.eq.-1) umtx=ju(n+1)-ju(1) c unorm=u(n+1) do i=1,n x(i)=b(i) enddo c c lower triangular system c do i=1,n if(dabs(u(i)).le.unorm) then x(i)=(u(i)/unorm)*(x(i)/unorm) else x(i)=x(i)/u(i) endif do jj=ju(i),ju(i+1)-1 j=ju(jj) x(j)=x(j)-u(jj+lmtx)*x(i) enddo enddo c c upper triangular system c do i=n,1,-1 s=0.0d0 do jj=ju(i),ju(i+1)-1 j=ju(jj) s=s+u(jj+umtx)*x(j) enddo if(dabs(u(i)).le.unorm) then x(i)=x(i)-(u(i)/unorm)*(s/unorm) else x(i)=x(i)-s/u(i) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine md(n,jc,p,mark,lenu,list,equiv,befor,after) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jc(*),p(*),mark(*),equiv(*),befor(*),after(*),list(*) c c minimum degree algorithm c c list = linked list of equivalent vertices (v,e) c = (temp) ptr to equiv vertex with clique imin (c) c equiv = number of equivalent vertices (v) c = ptr to equivant vertex (e) c = size of clique (c) c befor/after = doubly linked list of verts. by degree (v) c (temp) nvert/ncliq for verts in imin c (temp) marker for outmatched verts in imin c = (temp) switch/intersection size with imin (c) c mark = temp linked list c p = order (tail is head ptrs into befor/after) c lenu=n+1 mndeg=n+1 iempty=0 next=1 do i=1,n p(i)=0 equiv(i)=1 list(i)=i befor(i)=0 after(i)=0 mark(i)=0 enddo do i=1,n ideg=jc(i+1)-jc(i) if(ideg.le.0) then p(next)=i next=next+1 else id=n+1-ideg if(p(id).ne.0) befor(p(id))=i after(i)=p(id) p(id)=i befor(i)=-id mndeg=min0(mndeg,ideg) endif enddo if(next.gt.n) go to 100 c c order vertex of min degree c 10 id=n+1-mndeg if(p(id).eq.0) then mndeg=mndeg+1 go to 10 endif imin=p(id) if(after(imin).gt.0) befor(after(imin))=-id p(id)=after(imin) befor(imin)=0 after(imin)=0 c c build the current clique (imin) c call mkcliq(imin,jc,mark,equiv,ilen,imndeg,iempty) c numequ=equiv(imin) i=imin do ii=1,numequ p(next)=i next=next+1 equiv(i)=0 lenu=lenu+imndeg+numequ-ii i=list(i) enddo if(next.gt.n) go to 100 c c if the fillin will create a dense matrix.... c if(next+imndeg.gt.n) then i=imin numequ=0 do ii=1,ilen i=mark(i) inum=equiv(i) m=i do mm=1,inum p(next)=m next=next+1 equiv(m)=0 numequ=numequ+1 lenu=lenu+imndeg-numequ m=list(m) enddo enddo go to 100 endif c c eliminate redundant vertices from adjacency lists of clique c members...this allows simple elimination of equivalent vertices c i=imin numequ=0 jx=imin jlen=0 do ii=1,ilen i=mark(i) if(after(i).gt.0) befor(after(i))=befor(i) if(befor(i).lt.0) then id=-befor(i) if(id.ge.next) p(id)=after(i) else after(befor(i))=after(i) endif befor(i)=0 after(i)=0 c c update adjacency list c call jcupdt(imin,i,jc,mark,equiv,befor,after, + nvert,ncliq,ideg) c c test for equivalence c if(nvert.eq.0.and.ncliq.eq.1) then inum=equiv(i) m=i do mm=1,inum p(next)=m next=next+1 equiv(m)=0 numequ=numequ+1 lenu=lenu+imndeg-numequ m=list(m) enddo endif c c look for equivalent vertices c if(nvert.eq.0.and.ncliq.eq.2) then jcj=-jc(jc(i)) if(mark(jcj).eq.0) then mark(jcj)=jx jx=jcj jlen=jlen+1 list(jcj)=i else ieq=list(jcj) inum=equiv(i) equiv(ieq)=equiv(ieq)+inum m=list(i) do mm=1,inum mnext=list(m) list(m)=list(ieq) list(ieq)=m equiv(m)=-ieq m=mnext enddo endif endif c c save partial degree (imin is not counted yet) c if(equiv(i).gt.0) after(i)=ideg enddo if(next.gt.n) go to 100 c c update degrees c equiv(imin)=imndeg-numequ i=imin do ii=1,ilen i=mark(i) if(equiv(i).gt.0) then c c overcounting with three cliques requires this c id=n+1-min0(after(i)+equiv(imin)-1,n-next) if(p(id).ne.0) befor(p(id))=i after(i)=p(id) p(id)=i befor(i)=-id endif enddo c c clean up mark, move clique to jc c call svcliq(imin,jc,mark,equiv,ilen,iempty) c c update cliques c do jj=1,jlen jnext=mark(jx) call clqupd(jx,jc,mark,equiv,iempty) jx=jnext enddo c mndeg=max0(1,equiv(imin)) if(next.le.n) go to 10 c c reversing order is specific to bank/smith bordering algorithm c 100 nn=n/2 cc do i=1,nn cc ii=p(i) cc p(i)=p(n+1-i) cc p(n+1-i)=ii cc enddo c c compute inverse permutation c do i=1,n mark(p(i))=i enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkcliq(imin,jc,mark,equiv,ilen,imndeg,iempty) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jc(*),mark(*),equiv(*) c mark(imin)=imin imndeg=0 ilen=0 do 20 j=jc(imin),jc(imin+1)-1 jcj=iabs(jc(j)) if(jcj.eq.0) return if(jc(j).gt.0) then c c merge a normal vertex c if(mark(jcj).eq.0) then mark(jcj)=mark(imin) mark(imin)=jcj imndeg=imndeg+equiv(jcj) ilen=ilen+1 endif c c merge a clique c else 10 equiv(jcj)=0 mark(jcj)=iempty iempty=jcj do m=jc(jcj),jc(jcj+1)-1 jcj=iabs(jc(m)) if(jc(m).lt.0) go to 10 if(jc(m).eq.0) go to 20 if(mark(jcj).eq.0) then mark(jcj)=mark(imin) mark(imin)=jcj imndeg=imndeg+equiv(jcj) ilen=ilen+1 endif enddo endif 20 continue end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine jcupdt(imin,i,jc,mark,equiv,befor,after,nvert, + ncliq,ideg) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jc(*),mark(*),equiv(*),befor(*),after(*) c c update jc for vertex i c iptr=jc(i) nvert=0 ncliq=1 ideg=0 do 30 j=jc(i),jc(i+1)-1 jcj=iabs(jc(j)) if(jcj.eq.0) go to 40 if(jc(j).gt.0) then c c check a normal vertex c if(mark(jcj).eq.0) then jc(iptr)=jcj iptr=iptr+1 nvert=nvert+1 ideg=ideg+equiv(jcj) endif else c c this loop overestimates degrees for vertices c connected to three or more cliques c on the first encounter, compute the intersection c if(equiv(jcj).le.0) go to 30 if(befor(jcj).ne.-imin) then befor(jcj)=-imin after(jcj)=0 jck=jcj 10 do k=jc(jck),jc(jck+1)-1 jck=iabs(jc(k)) if(jc(k).lt.0) go to 10 if(jc(k).eq.0) go to 20 if(mark(jck).le.0) + after(jcj)=after(jcj)+equiv(jck) enddo endif 20 if(after(jcj).gt.0) then jc(iptr)=-jcj ncliq=ncliq+1 iptr=iptr+1 ideg=ideg+after(jcj) endif endif 30 continue 40 jc(iptr)=-imin if(iptr+1.lt.jc(i+1)) jc(iptr+1)=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clqupd(imin,jc,mark,equiv,iempty) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jc(*),mark(*),equiv(*) c c delete equivalent vertices from clique list c jcj=imin jcnext=jc(jcj) jclast=jc(jcj+1)-1 10 jcur=jc(jcj) jend=jc(jcj+1)-1 20 jcj=iabs(jc(jcur)) if(jcj.eq.0) go to 40 if(jc(jcur).lt.0) then equiv(jcj)=0 mark(jcj)=iempty iempty=jcj go to 10 endif if(equiv(jcj).gt.0) then if(jcnext.gt.jclast) then locsv=jclast 30 if(mark(iempty).eq.0) then next=iempty iempty=mark(next) else next=mark(iempty) mark(iempty)=mark(next) endif jcnext=jc(next)+1 jclast=jc(next+1)-1 if(jcnext.gt.jclast) go to 30 jc(jcnext-1)=jc(locsv) jc(locsv)=-next endif c jc(jcnext)=jcj jcnext=jcnext+1 endif jcur=jcur+1 if(jcur.le.jend) go to 20 40 if(jcnext.le.jclast) jc(jcnext)=0 mark(imin)=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine svcliq(imin,jc,mark,equiv,ilen,iempty) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jc(*),mark(*),equiv(*) c c save clique imin in jc c jcnext=jc(imin) jclast=jc(imin+1)-1 i=imin do 20 ii=1,ilen is=i i=mark(i) mark(is)=0 if(equiv(i).le.0) go to 20 c c pop the stack if necessary c if(jcnext.gt.jclast) then locsv=jclast 10 next=iempty iempty=mark(next) jcnext=jc(next)+1 jclast=jc(next+1)-1 if(jcnext.gt.jclast) go to 10 jc(jcnext-1)=jc(locsv) jc(locsv)=-next endif c jc(jcnext)=i jcnext=jcnext+1 c 20 continue mark(i)=0 if(jcnext.le.jclast) jc(jcnext)=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cev1(ip,ja,a,ka,evl,evr,rp,iequv,ibndry, + br,bl,devr,devl,z,hist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),iequv(*),ibndry(6,*),ka(10,*) double precision + a(*),evl(*),evr(*),rp(100),bl(*),br(*), 1 devr(*),devl(*),z(*),hist(22,*) c c compute approximate left and right eigenvectors c this routine should work when evl is allocated and ispd=1 c and also when evl=evr but ispd=0 c isw=1 nvf=ip(2) nbf=ip(4) idbcpt=ip(7) ispd=ip(8) mxcg=ip(10) lvl=ip(75) jspd=1 if(ispd.ne.1) jspd=-1 i1=1 i2=i1+nvf iqptr=ja(nvf+1)+nvf c eps=1.0d-5 itmax=max0(10,mxcg) c c check for null vectors c evrn=rl2nrm(nvf,evr) evln=rl2nrm(nvf,evl) if(evrn.eq.0.0d0.or.evln.eq.0.0d0) then do i=1,nvf evr(i)=1.0d0 evl(i)=1.0d0 enddo endif c c boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then evr(ibndry(1,i))=0.0d0 evr(ibndry(2,i))=0.0d0 evl(ibndry(1,i))=0.0d0 evl(ibndry(2,i))=0.0d0 endif enddo if(idbcpt.gt.0) then evr(idbcpt)=0.0d0 evl(idbcpt)=0.0d0 endif do i=1,nvf evr(i)=evr(iequv(i)) evl(i)=evl(iequv(i)) devr(i)=0.0d0 devl(i)=0.0d0 enddo c c c normalize initial vectors c evrn=rl2nrm(nvf,evr) evln=rl2nrm(nvf,evl) do i=1,nvf ee=evr(i)/evrn evl(i)=evl(i)/evln evr(i)=ee enddo do i=1,nvf ii=ja(iqptr+i-1) z(i1+ii-1)=evr(i) z(i2+ii-1)=evl(i) enddo do i=1,nvf evr(i)=z(i1+i-1) evl(i)=z(i2+i-1) enddo c c power method loop c call getptr(lvl,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) evrn0=1.0d0 evln0=1.0d0 call hist1(hist(1,18),0,1.0d0) do itnum=1,itmax c call mtxmlt(nvf,ja,a,evr,br,ispd) if(isw.eq.1) then call cycle(ispd,lvl,ja,a,devr,br,ka,z) else call snsilu(nvf,ja(juptr),a(iuptr),devr,br,ispd) endif do i=1,nvf evr(i)=evr(i)-devr(i) enddo evrn=rl2nrm(nvf,evr) dr=dabs(evrn0-evrn)/(evrn0+evrn) evrn0=evrn do i=1,nvf evr(i)=evr(i)/evrn enddo if(ispd.ne.1) then call mtxmlt(nvf,ja,a,evl,bl,jspd) if(isw.eq.1) then call cycle(jspd,lvl,ja,a,devl,bl,ka,z) else call snsilu(nvf,ja(juptr),a(iuptr),devl,bl,jspd) endif do i=1,nvf evl(i)=evl(i)-devl(i) enddo evln=rl2nrm(nvf,evl) dl=dabs(evln0-evln)/(evln0+evln) evln0=evln do i=1,nvf evl(i)=evl(i)/evln enddo dr=dmax1(dr,dl) else do i=1,nvf evl(i)=evr(i) enddo evln=evrn endif call hist1(hist(1,18),itnum,dr) c if(dr.lt.eps.and.itnum.gt.1) go to 100 enddo itnum=itmax c c final computation of singular value c sign determined such that evl * evr is positive c 100 do i=1,nvf ii=ja(iqptr+i-1) z(i1+i-1)=evr(ii) z(i2+i-1)=evl(ii) enddo do i=1,nvf evr(i)=z(i1+i-1) evl(i)=z(i2+i-1) enddo do i=1,nvf evr(i)=evr(iequv(i)) evl(i)=evl(iequv(i)) enddo if(ispd.eq.1) then write(6,*) itnum,nvf,dr,evrn else write(6,*) itnum,nvf,dr,evrn,evln endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blk3(ntf,nvf,itnode,vx,vy,rp,du,del,d,udot,u0dot, + p,gm,ispd,lvl,mxcg,epsmg,ja,a,ka,iequv,z,hist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ka(10,*),iequv(*),ja(*) double precision + vx(*),vy(*),udot(*),u0dot(*),p(*),del(*),du(*), 1 rp(100),gm(*),d(*),z(*),hist(*),a(*) c c set ups rhs as a residual c m1=nvf+1 call mtxml0(nvf,ja,a,udot,z,iequv,z(m1),ispd) daad=rl2ip(nvf,z,z) dad=rl2ip(nvf,d,z) if(daad.gt.0.0d0) then rldinv=dad/daad else rldinv=0.0d0 endif do i=1,nvf d(i)=d(i)-rldinv*z(i) enddo c c solve equations c call mg(ispd,lvl,mxcg,epsmg,ja,a,del,d, + ka,iequv,relerr,jflag,z,hist) c c compute the change in lamda (gm and z are the same vector) c call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) rl0dot=rp(33) scleqn=rp(67) thetal=rp(69) thetar=rp(70) drdrl=rp(73) c c scaling factor for udot c rldot=rp(23) ud2=dsqrt(dmax1(0.0d0,1.0d0-rldot**2)) ci=1.0d0/dmax1(1.0d0,dabs(rldinv*ud2)) do i=1,nvf udot(i)=(del(i)+rldinv*udot(i))*ci enddo c pdu=rl2ip(nvf,p,du) pudot=rl2ip(nvf,p,udot) udnorm=dl2nrm(nvf,udot,gm,1) u0dud=dl2ip(nvf,u0dot,udot,gm,1) c c compute change in scalar c h1=scleqn+thetar*pdu h2=thetal+thetar*(drdrl+pudot/ci) if(h2.ne.0.0d0) h2=1.0d0/h2 delta=-h1*h2 c c compute proposed lamda-dot, rho-dot c zmax=dmax1(dabs(ci),udnorm) rldot=(ci/zmax)/dsqrt((udnorm/zmax)**2+(ci/zmax)**2) ang=u0dud+ci*rl0dot if(ang.lt.0.0d0) rldot=-rldot if(ang*rldot.lt.ci*0.95d0) then sval=rp(25) sval0=rp(35) s1=sval*sval0 s2=rl0dot*rldot if(s1*s2.lt.0.0d0) rldot=-rldot endif h4=rldot/ci h3=delta/ci rdot=drdrl*rldot+pudot*h4 rp(72)=delta rp(23)=rldot rp(24)=rdot c c compute proposed udot,rdot c du contains the proposed change in u c do i=1,nvf du(i)=du(i)+h3*udot(i) udot(i)=udot(i)*h4 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blk4(nvf,rp,du,del,d,p,dl,ispd,lvl,mxcg,epsmg, + ja,a,h,ka,iequv,z,hist1,hist2) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ka(10,*),iequv(*),ja(*) double precision + h(*),dl(*),p(*),del(*),du(*),hist1(*),hist2(*), 1 rp(100),d(*),z(*),a(*) c c set ups rhs as a residual c m1=1 m2=m1+nvf m3=m2+nvf isv=m1 img=m2 ihdl=m1 ihdu=m2 c c solve equations c do i=1,nvf z(isv+i-1)=d(i) enddo call mg(ispd,lvl,mxcg,epsmg,ja,a,del,z(isv), + ka,iequv,reler1,jflag,z(img),hist1) call mtxml0(nvf,ja,h,du,z(ihdu),iequv,z(m3),1) call mtxml0(nvf,ja,h,del,z(ihdl),iequv,z(m3),1) do i=1,nvf z(ihdu+i-1)=p(i)-z(ihdu+i-1) z(ihdl+i-1)=dl(i)-z(ihdl+i-1) enddo c c compute the change in lamda c scleqn=rp(67) seqdot=rp(74) c1=scleqn+rl2ip(nvf,dl,du)+rl2ip(nvf,del,z(ihdu)) c2=seqdot+rl2ip(nvf,dl,del)+rl2ip(nvf,del,z(ihdl)) if(c2.ne.0.0d0) then delta=-c1/c2 else delta=0.0d0 endif rp(72)=delta c c right hand sides c do i=1,nvf du(i)=du(i)+delta*del(i) z(isv+i-1)=z(ihdu+i-1)+delta*z(ihdl+i-1) enddo c c lagrange multiplier update c jspd=1 if(ispd.ne.1) jspd=-1 call mg(jspd,lvl,mxcg,epsmg,ja,a,del,z(isv), + ka,iequv,reler2,jflag,z(img),hist2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blk5(ip,du,delm,delc,b,p,dl,epsmg,ja,a,h,g,su,sm, + ka,iequv,r,z,hist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ka(10,*),iequv(*),ja(*),ip(100) double precision + h(*),delc(*),p(*),delm(*),du(*),b(*),sm(*), 1 z(*),a(*),hist(22,*),g(*),dl(*),r(*),su(*) c c nvf=ip(2) ispd=ip(8) mxcg=ip(10) lvl=ip(75) c m1=1 m2=m1+nvf m3=m2+nvf c jspd=1 if(ispd.ne.1) jspd=-1 c c first computation for lagrange multiplier c call mtxml0(nvf,ja,h,du,r,iequv,z,1) do i=1,nvf r(i)=p(i)-r(i) enddo call mg(jspd,lvl,mxcg,epsmg,ja,a,delm,r, + ka,iequv,reler1,jflag,z,hist(1,8)) c c compute update for control variables c call mtxml0(nvf,ja,sm,delm,r,iequv,z,-1) call mtxml0(nvf,ja,su,du,z,iequv,z(m2),-1) iqptr=ja(nvf+1)-1+nvf do i=1,nvf delc(ja(iqptr+i))=dl(i)-r(i)-z(i) enddo c c save diagonal in delm (which gets recomputed later) c do i=1,nvf delm(i)=g(i) cc g(i)=g(i)+h(i)*(sm(i)/a(i))**2 r(i)=delc(i)/g(i) enddo eps=1.d-4 call sgscg(nvf,ja,g,r,delc,mxcg,z(m1),z(m2),z(m3),eps) do i=1,nvf delc(i)=r(ja(iqptr+i)) g(i)=delm(i) enddo c c final computation for solution variables c call mtxml0(nvf,ja,sm,delc,r,iequv,z,0) c do i=1,nvf r(i)=b(i)-r(i) enddo call mg(ispd,lvl,mxcg,epsmg,ja,a,du,r, + ka,iequv,reler2,jflag,z,hist(1,9)) c c final computation for lagrange multiplier c call mtxml0(nvf,ja,h,du,r,iequv,z,1) call mtxml0(nvf,ja,su,delc,z,iequv,z(m2),0) do i=1,nvf r(i)=p(i)-r(i)-z(i) enddo call mg(jspd,lvl,mxcg,epsmg,ja,a,delm,r, + ka,iequv,reler3,jflag,z,hist(1,10)) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blk3dd(ip,rp,itnode,vx,vy,du,del,d,udot,u0dot, + p,epsmg,ja,a,ka,iequv,z,hist,nn,gf,ipath, 1 ja0,a0,jequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ka(10,*),iequv(*),ja(*),ipath(4,*),ja0(*), 1 jequv(*),ip(100) double precision + vx(*),vy(*),udot(*),u0dot(*),p(*),del(*),du(*),t(10), 1 rp(100),d(*),z(*),hist(*),a(*), 2 gf(nn,*),a0(*) c c set ups rhs as a residual c ntf=ip(1) nvf=ip(2) newnvf=ip(32) nvv=ip(34) nvi=ip(36) ispd=ip(8) mxcg=ip(10) lvl=ip(75) nproc=ip(49) irgn=ip(50) c m1=nvf+1 iin=nvf+1 iout=iin+2*nn icnt=iout+2*nn ioff=icnt+nproc c call blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath,ja0,a0, + udot,z,z(m1),ispd) c t(1)=rl2ip(newnvf,z,z) t(2)=rl2ip(newnvf,d,z) c call pl2ip(t,2) c daad=t(1) dad=t(2) if(daad.gt.0.0d0) then rldinv=dad/daad else rldinv=0.0d0 endif do i=1,newnvf d(i)=d(i)-rldinv*z(i) enddo ii=ipath(1,irgn)-1 do i=1,nvv gf(ii+i,1)=d(i) gf(ii+i,2)=rldinv*udot(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),d,z,ispd,1) c c solve equations c call mg(ispd,lvl,mxcg,epsmg,ja,a,del,d, + ka,iequv,relerr,jflag,z,hist) c c compute the change in lamda c call mkgm(nvf,ntf,vx,vy,z,itnode,iequv) rl0dot=rp(33) scleqn=rp(67) thetal=rp(69) thetar=rp(70) drdrl=rp(73) c c scaling factor for udot c rldot=rp(23) ud2=dsqrt(dmax1(0.0d0,1.0d0-rldot**2)) ci=1.0d0/dmax1(1.0d0,dabs(rldinv*ud2)) do i=1,nvf udot(i)=(del(i)+rldinv*udot(i))*ci enddo c t(1)=rl2ip(newnvf,p,du) t(2)=rl2ip(newnvf,p,udot) t(3)=dl2ip(newnvf,udot,udot,z,1) t(4)=dl2ip(newnvf,u0dot,udot,z,1) c call pl2ip(t,4) c pdu=t(1) pudot=t(2) udnorm=dsqrt(t(3)) u0dud=t(4) c c compute change in scalar c h1=scleqn+thetar*pdu h2=thetal+thetar*(drdrl+pudot/ci) if(h2.ne.0.0d0) h2=1.0d0/h2 delta=-h1*h2 c c compute proposed lamda-dot, rho-dot c zmax=dmax1(dabs(ci),udnorm) rldot=(ci/zmax)/dsqrt((udnorm/zmax)**2+(ci/zmax)**2) ang=u0dud+ci*rl0dot if(ang.lt.0.0d0) rldot=-rldot if(ang*rldot.lt.ci*0.95d0) then sval=rp(25) sval0=rp(35) s1=sval*sval0 s2=rl0dot*rldot if(s1*s2.lt.0.0d0) rldot=-rldot endif h4=rldot/ci h3=delta/ci rdot=drdrl*rldot+pudot*h4 rp(72)=delta rp(23)=rldot rp(24)=rdot c c compute proposed udot,rdot c du contains the proposed change in u c do i=1,nvf du(i)=du(i)+h3*udot(i) udot(i)=udot(i)*h4 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blk4dd(ip,rp,du,del,d,p,dl,epsmg, + ja,a,h,ka,iequv,z,hist1,hist2) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ka(10,*),iequv(*),ja(*),ip(100) double precision + h(*),dl(*),p(*),del(*),du(*),hist1(*),hist2(*), 1 rp(100),d(*),z(*),a(*),t(5) c c compute norms -- iprob=-4 c nvf=ip(2) newnvf=ip(32) nvv=ip(34) nvi=ip(36) ispd=ip(8) mxcg=ip(10) lvl=ip(75) nproc=ip(49) irgn=ip(50) c m1=1 m2=m1+nvf m3=m2+nvf isv=m1 img=m2 ihdl=m1 ihdu=m2 c c set up rhs for lagrange multiplier c do i=1,nvv z(isv+i-1)=d(i)+d(i+nvf) enddo do i=nvv+1,nvf z(isv+i-1)=d(i) enddo call mg(ispd,lvl,mxcg,epsmg,ja,a,del,z(isv), + ka,iequv,reler1,jflag,z(img),hist1) call mtxml0(nvf,ja,h,du,z(ihdu),iequv,z(m3),1) call mtxml0(nvf,ja,h,del,z(ihdl),iequv,z(m3),1) do i=1,nvf z(ihdu+i-1)=p(i)-z(ihdu+i-1) enddo do i=1,nvv z(ihdl+i-1)=dl(i)+dl(i+nvf)-z(ihdl+i-1) enddo do i=nvv+1,nvf z(ihdl+i-1)=dl(i)-z(ihdl+i-1) enddo c c compute the change in lamda c c t(1)=rl2ip(newnvf,dl,du) t(2)=rl2ip(newnvf,del,z(ihdu)) t(3)=rl2ip(newnvf,dl,del) t(4)=rl2ip(newnvf,del,z(ihdl)) c call pl2ip(t,4) c scleqn=rp(67) seqdot=rp(74) c1=scleqn+t(1)+t(2) c2=seqdot+t(3)+t(4) if(c2.ne.0.0d0) then delta=-c1/c2 else delta=0.0d0 endif rp(72)=delta c c right hand sides c do i=1,nvf du(i)=du(i)+delta*del(i) z(isv+i-1)=z(ihdu+i-1)+delta*z(ihdl+i-1) enddo c c lagrange multiplier update c jspd=1 if(ispd.ne.1) jspd=-1 call mg(jspd,lvl,mxcg,epsmg,ja,a,del,z(isv), + ka,iequv,reler2,jflag,z(img),hist2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine swbrch(nvf,ntf,nbf,itnode,ibndry,iequv,vx,vy,xm,ym, + evl,evr,udot,u,u0dot,p,zr,zp,phi,gm,rp,ibedge,ispd, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),iequv(*) double precision + vx(*),vy(*),u(*),udot(*),evr(*),evl(*),p(*),zr(*), 1 rp(100),phi(*),zp(*),xm(*),ym(*),u0dot(*),gm(*) double precision + a(6,6),azr(6,6),atm(6,6),azp(6,6),f(6),fzr(6),frl(6), 1 fzp(6),ptm(12),pzr(12),pzp(12),btm(6),htm(6,6),utm(6), 2 dtm(6),gtm(6,6),ucm(6) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy c c initialize c rl=rp(21) rldot=rp(23) delta=1.0d-4 sh=rp(45) ifirst=3 iprob=3 call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) c c compute phi to be orthogonal to evl c evlr=dl2ip(nvf,evl,evr,gm,1) evld=dl2ip(nvf,evl,udot,gm,1) c c zr = u + delta * evr c zp = u + delta * phi c if(rldot.ne.0) then c0=1.0d0/rldot a1=evld/evlr else c0=1.0d0 a1=0.0d0 endif do i=1,nvf phi(i)=c0*(udot(i)-a1*evr(i)) p(i)=0.0d0 zr(i)=u(i)+delta*evr(i) zp(i)=u(i)+delta*phi(i) enddo c c compute coefficients of quadratic c a111=0.0d0 b11=0.0d0 c1=0.0d0 drdrl=0.0d0 rrl=rl+delta do i=1,ntf c c compute element stiffness matrix c call eleasm(i,itnode,vx,vy,u,utm,utm,utm,utm,vx,vy,u, + rl,sh,a,htm,gtm,gtm,gtm,btm,f,ptm,dtm, 1 0,ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) ifirst=0 call eleasm(i,itnode,vx,vy,zr,utm,utm,utm,utm,vx,vy,zr, + rl,sh,azr,htm,gtm,gtm,gtm,btm,fzr,pzr,dtm, 1 0,ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) call eleasm(i,itnode,vx,vy,zp,utm,utm,utm,utm,vx,vy,zp, + rl,sh,azp,htm,gtm,gtm,gtm,btm,fzp,pzp,dtm, 1 0,ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) call eleasm(i,itnode,vx,vy,u,utm,utm,utm,utm,vx,vy,u, + rrl,sh,atm,htm,gtm,gtm,gtm,btm,frl,ptm,dtm, 1 0,ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) c c form element inner products c drdrl=drdrl+pzp(7)+pzr(7) do j=1,3 ivj=itnode(j,i) p(ivj)=p(ivj)+pzp(j)+pzr(j) s=0.0d0 ss=0.0d0 do k=1,3 ivk=itnode(k,i) s=s+evl(ivk)*(azr(k,j)-a(k,j)) ss=ss+evl(ivk)*(azp(k,j)-a(k,j)) enddo a111=a111+s*evr(ivj) b11=b11+s*phi(ivj)+evl(ivj)*(fzr(j)-f(j)) c1=c1+ss*phi(ivj)+evl(ivj)* + (2.0d0*(fzp(j)-f(j))+(frl(j)-f(j))) enddo enddo c c compute contribution from boundary c do i=1,nbf if(ibndry(5,i).le.0) then do j=1,2 if(ibedge(j,i).gt.0) then call elebdi(i,j,itnode,ibndry,ibedge, + vx,vy,xm,ym,zr,ucm,rl,htm,gtm, 1 gtm,pzr,dtm,iprob,0,p2xy) call elebdi(i,j,itnode,ibndry,ibedge, + vx,vy,xm,ym,zp,ucm,rl,htm,gtm, 1 gtm,pzp,dtm,iprob,0,p2xy) drdrl=drdrl+pzp(7)+pzr(7) it=ibedge(j,i)/4 do k=1,3 ivk=itnode(k,it) p(ivk)=p(ivk)+pzp(k)+pzr(k) enddo endif enddo endif c c neumann edge c if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,utm,ucm,rl,a,htm,gtm,gtm,gtm,btm,f,ptm, 1 dtm,iprob,0,gnxy) call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + zr,utm,ucm,rl,azr,htm,gtm,gtm,gtm,btm,fzr,ptm, 1 dtm,iprob,0,gnxy) call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + zp,utm,ucm,rl,azp,htm,gtm,gtm,gtm,btm,fzp,ptm, 1 dtm,iprob,0,gnxy) call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,utm,ucm,rrl,atm,htm,gtm,gtm,gtm,btm,frl,ptm, 1 dtm,iprob,0,gnxy) do j=1,3 ivj=itnode(j,it) s=0.0d0 ss=0.0d0 do k=1,3 ivk=itnode(k,it) s=s+evl(ivk)*(azr(k,j)-a(k,j)) ss=ss+evl(ivk)*(azp(k,j)-a(k,j)) enddo a111=a111+s*evr(ivj) b11=b11+s*phi(ivj)+evl(ivj)*(fzr(j)-f(j)) c1=c1+ss*phi(ivj)+evl(ivj)* + (2.0d0*(fzp(j)-f(j))+(frl(j)-f(j))) enddo endif enddo c c compute both roots of the quadratic c zr and zp are the two possible directions c discr=b11*b11-a111*c1 if(a111.ne.0.0d0) then if(b11.gt.0) then ss=b11+dsqrt(dabs(discr)) q1=-c1/ss q2=-ss/a111 else ss=b11-dsqrt(dabs(discr)) q1=-ss/a111 q2=-c1/ss endif do i=1,nvf zp(i)=q1*evr(i)+phi(i) zr(i)=q2*evr(i)+phi(i) enddo else do i=1,nvf zp(i)=phi(i) zr(i)=evr(i)*100.0d0 enddo endif zrnorm=dl2nrm(nvf,zr,gm,1) zpnorm=dl2nrm(nvf,zp,gm,1) ibrch=0 c c here we are trying to stay on current branch c if(isw.eq.1) then udnorm=dl2nrm(nvf,u0dot,gm,1) if(udnorm.gt.1.0d-2) then zrd=dl2ip(nvf,zr,u0dot,gm,1) zpd=dl2ip(nvf,zp,u0dot,gm,1) if(dabs(zpd)*zrnorm.gt.dabs(zrd)*zpnorm) ibrch=1 else if(zrnorm.gt.zpnorm) ibrch=1 endif else c c here we are trying to switch branches c udnorm=dl2nrm(nvf,udot,gm,1) if(udnorm.gt.1.0d-2) then zrd=dl2ip(nvf,zr,udot,gm,1) zpd=dl2ip(nvf,zp,udot,gm,1) if(dabs(zpd)*zrnorm.lt.dabs(zrd)*zpnorm) ibrch=1 else if(zrnorm.lt.zpnorm) ibrch=1 endif endif c c compute udot and lambda dot c if(ibrch.eq.1) then rldot=1.0d0/dsqrt(zpnorm**2+1.0d0) do i=1,nvf udot(i)=rldot*zp(i) enddo else rldot=1.0d0/dsqrt(zrnorm**2+1.0d0) do i=1,nvf udot(i)=rldot*zr(i) enddo endif undot=dsqrt(dmax1(0.0d0,1.0d0-rldot*rldot)) rdot=(drdrl*rldot+rl2ip(nvf,p,udot))/2.0d0 im=0 if(isw.eq.1) then if(rp(33)*rldot.lt.0) im=1 else if(rp(33)*rdot-rp(34)*rldot.lt.0.0d0) im=1 endif if(im.eq.1) then undot=-undot rldot=-rldot rdot=-rdot do i=1,nvf udot(i)=-udot(i) enddo endif rp(23)=rldot rp(24)=rdot return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bdinit(ip,rp,iequv,u,vx,vy,itnode,ibndry, + bdlwr,bdupr,gm,ibc,gdxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + iequv(*),ibndry(6,*),ip(100),itnode(5,*) double precision + u(*),d(15),bdlwr(*),bdupr(*),rp(100),vx(*),vy(*),gm(*) external gdxy data ibit/0/ c c compute bdupr, bdlwr c ntf=ip(1) nvf=ip(2) nbf=ip(4) idbcpt=ip(7) rl=rp(21) rmu=rp(63) eps=100.0d0*ceps(ibit) tol=dmax1(1.0d-2*rmu,eps) c** tol=eps c do i=1,nvf bdupr(i)=0.0d0 bdlwr(i)=0.0d0 gm(i)=0.0d0 enddo do i=1,ntf area=dabs((vx(itnode(2,i))-vx(itnode(1,i)))* + (vy(itnode(3,i))-vy(itnode(1,i)))- 1 (vx(itnode(3,i))-vx(itnode(1,i)))* 2 (vy(itnode(2,i))-vy(itnode(1,i)))) itag=itnode(5,i) do j=1,3 ivj=itnode(j,i) do m=1,6 d(m)=0.0d0 enddo call gdxy(vx(ivj),vy(ivj),rl,itag,d) gm(ivj)=gm(ivj)+area bdlwr(ivj)=bdlwr(ivj)+area*d(4) bdupr(ivj)=bdupr(ivj)+area*d(5) enddo enddo c do i=1,nvf bdupr(i)=bdupr(i)/gm(i) bdlwr(i)=bdlwr(i)/gm(i) rr=tol*(bdupr(i)-bdlwr(i)) u(i)=dmax1(u(i),bdlwr(i)+rr) u(i)=dmin1(u(i),bdupr(i)-rr) enddo c c dirichlet boundary conditions c if(ibc.eq.1) then do i=1,nbf if(ibndry(4,i).eq.2) then itag=ibndry(6,i) do j=1,2 ivj=ibndry(j,i) do m=1,6 d(m)=0.0d0 enddo call gdxy(vx(ivj),vy(ivj),rl,itag,d) ivj=iequv(ivj) u(ivj)=d(1) bdlwr(ivj)=dmin1(bdlwr(ivj),d(1)) bdupr(ivj)=dmax1(bdupr(ivj),d(1)) enddo endif enddo c c special dirichlet point c if(idbcpt.gt.0) then itag=ip(78) do m=1,6 d(m)=0.0d0 enddo call gdxy(vx(idbcpt),vy(idbcpt),rl,itag,d) ivj=iequv(idbcpt) u(ivj)=d(1) bdlwr(ivj)=dmin1(bdlwr(ivj),d(1)) bdupr(ivj)=dmax1(bdupr(ivj),d(1)) endif endif c do i=1,nvf u(i)=u(iequv(i)) bdlwr(i)=bdlwr(iequv(i)) bdupr(i)=bdupr(iequv(i)) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setbd(ip,rp,isw,vx,vy,gm,itnode,iequv,bdlwr,bdupr, + q,a,u,b) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),q(*),iequv(*),ip(100) double precision + vx(*),vy(*),u(*),b(*),a(*),bdlwr(*),bdupr(*),rp(100), 1 gm(*) c c compute new diagonal and rhs for schur complement system c ntf=ip(1) nvf=ip(2) rmu=rp(63) rmu0=rmu if(isw.eq.1) rmu0=rp(64) call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) do i=1,nvf ru=0.0d0 uu=0.0d0 if(u(i).gt.bdlwr(i)) then ru=ru+rmu/(u(i)-bdlwr(i)) uu=uu+rmu0/(u(i)-bdlwr(i))**2 endif if(u(i).lt.bdupr(i)) then ru=ru+rmu/(u(i)-bdupr(i)) uu=uu+rmu0/(u(i)-bdupr(i))**2 endif if(iequv(i).eq.i) then b(i)=b(i)+ru*gm(i) a(q(i))=a(q(i))+uu*gm(i) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setbdl(rp,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100) c c compute new diagonal and rhs for schur complement system c rmu=rp(63) rmu0=rmu if(isw.eq.1) rmu0=rp(64) scleqn=rp(67) seqdot=rp(74) area=rp(80) rllwr=rp(4) rlupr=rp(5) rl=rp(21) c ru=0.0d0 uu=0.0d0 if(rl.gt.rllwr) then ru=ru+rmu/(rl-rllwr) uu=uu+rmu0/(rl-rllwr)**2 endif if(rl.lt.rlupr) then ru=ru+rmu/(rl-rlupr) uu=uu+rmu0/(rl-rlupr)**2 endif rp(67)=scleqn+ru*area rp(74)=seqdot-uu*area return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setbdp(ip,rp,isw,vx,vy,gm,gmd,itnode,iequv,jequv, + ipath,bdlwr,bdupr,q,a,a0,u,b) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),q(*),iequv(*),jequv(*),ipath(4,*),ip(100) double precision + vx(*),vy(*),u(*),b(*),a(*),bdlwr(*),bdupr(*),rp(100), 1 gm(*),a0(*),gmd(*) c c compute new diagonal and rhs for schur complement system c ntf=ip(1) nvf=ip(2) irgn=ip(50) nvv=ip(34) rmu=rp(63) rmu0=rmu if(isw.eq.1) rmu0=rp(64) c c compute new diagonal and rhs for schur complement system c call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) do i=1,nvf ru=0.0d0 uu=0.0d0 if(u(i).gt.bdlwr(i)) then ru=ru+rmu/(u(i)-bdlwr(i)) uu=uu+rmu0/(u(i)-bdlwr(i))**2 endif if(u(i).lt.bdupr(i)) then ru=ru+rmu/(u(i)-bdupr(i)) uu=uu+rmu0/(u(i)-bdupr(i))**2 endif if(iequv(i).eq.i) then if(i.gt.nvv) b(i)=b(i)+ru*gm(i) a(q(i))=a(q(i))+uu*gm(i) endif enddo c c now do interface points c call mkgmd(ip,itnode,vx,vy,iequv,ipath,gmd) do i=1,nvv ru=0.0d0 uu=0.0d0 if(u(i).gt.bdlwr(i)) then ru=ru+rmu/(u(i)-bdlwr(i)) uu=uu+rmu0/(u(i)-bdlwr(i))**2 endif if(u(i).lt.bdupr(i)) then ru=ru+rmu/(u(i)-bdupr(i)) uu=uu+rmu0/(u(i)-bdupr(i))**2 endif ii=i+ipath(1,irgn)-1 b(i)=b(i)+ru*gmd(ii) jj=ii 10 a0(jj)=a0(jj)+uu*gmd(jj) jj=jequv(jj) if(jj.ne.ii) go to 10 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine gfinit(ip,maxv,gf,e) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100) double precision + gf(maxv,*),e(*) c c initialize grid functions c ntf=ip(1) nvf=ip(2) ngf=ip(77) do j=1,ngf do i=1,nvf gf(i,j)=0.0d0 enddo enddo do i=1,ntf e(i)=0.0d0 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine uinit(ip,rp,itnode,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,z,iequv,gdxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),iequv(*) double precision + vx(*),vy(*),u(*),udot(*),u0(*),u0dot(*),um(*),uc(*), 1 z(*),rp(100),g(15) external gdxy c c initialize u c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=ip(6) itask=ip(9) idbcpt=ip(7) c rl=rp(21) if(iabs(iprob).eq.3) then rldot=rp(23) rlmin=1.0d-2 if(rldot.ge.0.0d0) then rldinv=1.0d0/dmax1(rlmin,rldot) else rldinv=1.0d0/dmin1(-rlmin,rldot) endif else if(iprob.eq.6) then rl=rp(46) if(itask.eq.9) rl=rl+dmax1(rp(47),rp(48)) endif c c check status of u initialization c umax=0.0d0 do i=1,nvf umax=dmax1(umax,dabs(u(i))) enddo if(umax.eq.0.0d0) then do i=1,nvf u(i)=0.0d0 z(i)=0.0d0 enddo do i=1,ntf m1=itnode(1,i) m2=itnode(2,i) m3=itnode(3,i) itag=itnode(5,i) aa=dabs((vx(m2)-vx(m1))*(vy(m3)-vy(m1)) + -(vx(m3)-vx(m1))*(vy(m2)-vy(m1))) do j=1,3 ivj=itnode(j,i) do m=1,6 g(m)=0.0d0 enddo call gdxy(vx(ivj),vy(ivj),rl,itag,g) z(ivj)=z(ivj)+aa u(ivj)=u(ivj)+aa*g(6) enddo enddo do i=1,nvf u(i)=u(i)/z(i) enddo c c find tag for special dirichlet point c if(idbcpt.gt.0) then do i=1,ntf do j=1,3 if(itnode(j,i).eq.idbcpt) go to 10 enddo enddo stop 9613 10 itag=itnode(5,i) ip(78)=itag endif endif c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then itag=ibndry(6,i) do k=1,2 ivk=ibndry(k,i) do m=1,6 g(m)=0.0d0 enddo if(iabs(iprob).eq.5) then rr=uc(ivk) else rr=rl endif call gdxy(vx(ivk),vy(ivk),rr,itag,g) ivk=iequv(ivk) u(ivk)=g(1) if(iabs(iprob).eq.3) udot(ivk)=g(2)/rldinv if(iabs(iprob).eq.4) um(ivk)=0.0d0 if(iabs(iprob).eq.5) um(ivk)=0.0d0 enddo endif enddo c c special dirichlet point c if(idbcpt.gt.0) then itag=ip(78) do m=1,6 g(m)=0.0d0 enddo if(iabs(iprob).eq.5) then rr=uc(idbcpt) else rr=rl endif call gdxy(vx(idbcpt),vy(idbcpt),rr,itag,g) ivk=iequv(idbcpt) u(ivk)=g(1) if(iabs(iprob).eq.3) udot(ivk)=g(2)/rldinv if(iabs(iprob).eq.4) um(ivk)=0.0d0 if(iabs(iprob).eq.5) um(ivk)=0.0d0 endif c c c do i=1,nvf u(i)=u(iequv(i)) enddo if(iabs(iprob).eq.3) then do i=1,nvf u0(i)=u0(iequv(i)) udot(i)=udot(iequv(i)) u0dot(i)=u0dot(iequv(i)) enddo else if(iabs(iprob).eq.4) then do i=1,nvf um(i)=um(iequv(i)) enddo else if(iabs(iprob).eq.5) then do i=1,nvf um(i)=um(iequv(i)) uc(i)=uc(iequv(i)) enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bcinit(ip,rp,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,d1u,d2u,iequv,gdxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),ip(100),iequv(*) double precision + vx(*),vy(*),u(*),udot(*),um(*),d1u(*),d2u(*),uc(*), 1 rp(100),g(15),u0(*),u0dot(*) external gdxy c c initialize u c nvf=ip(2) nbf=ip(4) iprob=ip(6) itask=ip(9) idbcpt=ip(7) c rl=rp(21) if(iabs(iprob).eq.3) then rldot=rp(23) rlmin=1.0d-2 if(rldot.ge.0.0d0) then rldinv=1.0d0/dmax1(rlmin,rldot) else rldinv=1.0d0/dmin1(-rlmin,rldot) endif else if(iabs(iprob).eq.6) then rl=rp(46) if(itask.eq.9) rl=rl+dmax1(rp(47),rp(48)) endif c c if(iabs(iprob).eq.4.or.iabs(iprob).eq.5) then do i=1,nvf d1u(i)=0.0d0 d2u(i)=0.0d0 enddo endif c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then itag=ibndry(6,i) do k=1,2 ivk=ibndry(k,i) do m=1,6 g(m)=0.0d0 enddo if(iabs(iprob).eq.5) then rr=uc(ivk) else rr=rl endif call gdxy(vx(ivk),vy(ivk),rr,itag,g) ivk=iequv(ivk) u(ivk)=g(1) if(iabs(iprob).eq.3) udot(ivk)=g(2)/rldinv if(iabs(iprob).eq.4.or.iabs(iprob).eq.5) then um(ivk)=0.0d0 d1u(ivk)=g(2) d2u(ivk)=g(3) endif enddo endif enddo c c special dirichlet point c if(idbcpt.gt.0) then itag=ip(78) do m=1,6 g(m)=0.0d0 enddo if(iabs(iprob).eq.5) then rr=uc(idbcpt) else rr=rl endif call gdxy(vx(idbcpt),vy(idbcpt),rr,itag,g) ivk=iequv(idbcpt) u(ivk)=g(1) if(iabs(iprob).eq.3) udot(ivk)=g(2)/rldinv if(iabs(iprob).eq.4.or.iabs(iprob).eq.5) then um(ivk)=0.0d0 d1u(ivk)=g(2) d2u(ivk)=g(3) endif endif c c do i=1,nvf u(i)=u(iequv(i)) enddo if(iabs(iprob).eq.3) then do i=1,nvf u0(i)=u0(iequv(i)) udot(i)=udot(iequv(i)) u0dot(i)=u0dot(iequv(i)) enddo else if(iabs(iprob).eq.4) then do i=1,nvf um(i)=um(iequv(i)) d1u(i)=d1u(iequv(i)) d2u(i)=d2u(iequv(i)) enddo else if(iabs(iprob).eq.5) then do i=1,nvf um(i)=um(iequv(i)) uc(i)=uc(iequv(i)) d1u(i)=d1u(iequv(i)) d2u(i)=d2u(iequv(i)) enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rgnsys(ip,itnode,ibndry,vx,vy,xm,ym,b,d,p,dl,q, + ja,a,h,g,su,sm,ja0,a0,h0,g0,su0,sm0,u,udot,um,uc,d1u,d2u, 1 vx0,vy0,u0,u0dot,rp,mark,ibedge,iequv,jequv,ipath,bdlwr, 2 bdupr,z,zp,isw,nn,gf,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ja0(*),mark(*),jequv(*), 1 ibedge(2,*),iequv(*),ip(100),ipath(4,*), 2 q(*),ja(*),amtx,amtx0,smtx,smtx0 double precision + vx(*),vy(*),u(*),u0(*),vx0(*),vy0(*),a0(*),b(*),d(*), 1 xm(*),ym(*),rp(100),p(*),a(*),udot(*),u0dot(*),su(*), 2 h(*),dl(*),h0(*),um(*),bdlwr(*),bdupr(*),z(*),su0(*), 3 gf(nn,*),d1u(*),d2u(*),uc(*),g(*),g0(*),sm(*),sm0(*), 4 zp(*) double precision + fa(6,6),fh(6,6),fg(6,6),fsm(6,6),fsu(6,6), 1 fb(6),fd(6),fp(12),fdl(12),fz(36),t(6) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy c c compute stiffness matrix, right hand side, and c the derivative of the rhs with respect to lamda c c initialize c ntf=ip(1) nvf=ip(2) nbf=ip(4) nproc=ip(49) irgn=ip(50) nvf=ip(2) newnvf=ip(32) nvv=ip(34) nvi=ip(36) iprob=iabs(ip(6)) idbcpt=ip(7) ispd=ip(8) nn=ipath(2,nproc+2) c call bcinit(ip,rp,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,d1u,d2u,iequv,gdxy) c do i=1,36 fz(i)=0.0d0 enddo if(ispd.eq.1) then amtx=0 amtx0=0 else amtx=ja(nvf+1)-ja(1) amtx0=ja0(nn+1)-ja0(1) endif smtx=ja(nvf+1)-ja(1) smtx0=ja0(nn+1)-ja0(1) c c initialize c do i=1,ja(nvf+1)-1+amtx a(i)=0.0d0 enddo do i=1,ja0(nn+1)-1+amtx0 a0(i)=0.0d0 enddo c rl=rp(21) sh=rp(45) do i=1,nvf b(i)=0.0d0 mark(i)=0 enddo if(iprob.eq.4) then do i=1,nvf+nvv d(i)=0.0d0 dl(i)=0.0d0 enddo do i=1,nvf p(i)=0.0d0 enddo do i=1,ja(nvf+1)-1 h(i)=0.0d0 enddo do i=1,ja0(nn+1)-1 h0(i)=0.0d0 enddo else if(iprob.eq.5) then do i=1,nvf dl(i)=0.0d0 p(i)=0.0d0 enddo do i=1,ja(nvf+1)-1 g(i)=0.0d0 h(i)=0.0d0 enddo do i=1,ja(nvf+1)-1+smtx su(i)=0.0d0 sm(i)=0.0d0 enddo do i=1,ja0(nn+1)-1 g0(i)=0.0d0 h0(i)=0.0d0 enddo do i=1,ja0(nn+1)-1+smtx0 su0(i)=0.0d0 sm0(i)=0.0d0 enddo else if(iprob.eq.3) then do i=1,nvf p(i)=0.0d0 d(i)=0.0d0 enddo endif c r=0.0d0 drdrl=0.0d0 scleqn=0.0d0 seqdot=0.0d0 ifirst=3 c c assemble and update elements c do i=1,ntf call eleasm(i,itnode,vx,vy,u,um,uc,d1u,d2u,vx0,vy0,u0, + rl,sh,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,0, 1 ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) ifirst=0 call l2gd(i,iprob,irgn,itnode,iequv,q,amtx,smtx,ja,a,h,g, + su,sm,amtx0,smtx0,ja0,a0,h0,g0,su0,sm0,b,d,p,dl, 1 fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn, 2 seqdot,nvf,nvv,newnvf,nvi,nproc,ipath,jequv) enddo c c boundary edges c do i=1,nbf c c functional rho c if(ibndry(5,i).le.0) then do j=1,2 if(ibedge(j,i).gt.0) then it=ibedge(j,i)/4 jrgn=itnode(4,it) if(irgn.eq.jrgn) then call elebdi(i,j,itnode,ibndry,ibedge, + vx,vy,xm,ym,u,uc,rl,fh,fg, 1 fsu,fp,fdl,iprob,0,p2xy) call l2gd(it,iprob,irgn,itnode,iequv,q, + amtx,smtx,ja,a,h,g,su,sm,amtx0,smtx0, 1 ja0,a0,h0,g0,su0,sm0,b,d,p,dl,fz,fh, 2 fg,fz,fsu,fz,fz,fp,fdl,r,drdrl,scleqn, 3 seqdot,nvf,nvv,newnvf,nvi,nproc, 4 ipath,jequv) endif endif enddo endif c c neumann edge c if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 iprob,0,gnxy) call l2gd(it,iprob,irgn,itnode,iequv,q,amtx,smtx, + ja,a,h,g,su,sm,amtx0,smtx0,ja0,a0,h0,g0,su0,sm0, 1 b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl, 2 scleqn,seqdot,nvf,nvv,newnvf,nvi,nproc,ipath,jequv) else if(ibndry(4,i).eq.2) then mark(q(iequv(ibndry(1,i))))=1 mark(q(iequv(ibndry(2,i))))=1 endif enddo if(idbcpt.gt.0) mark(q(iequv(idbcpt)))=1 c c modifications for obstacle problem c if(iprob.eq.2) call setbdp(ip,rp,isw,vx,vy,z,zp,itnode, + iequv,jequv,ipath,bdlwr,bdupr,q,a,a0,u,b) if(iprob.eq.5) call setbdp(ip,rp,isw,vx,vy,z,zp,itnode, + iequv,jequv,ipath,bdlwr,bdupr,q,g,g0,uc,dl) c c set dirichlet boundary conditions c anorm=0.0d0 do i=1,nvf if(mark(q(i)).eq.1) b(i)=0.0d0 anorm=dmax1(dabs(a(i)),anorm) enddo if(anorm.le.0.0d0) anorm=1.0d0 c c scalar function c if(iprob.eq.4) then t(1)=r t(2)=drdrl t(3)=scleqn t(4)=seqdot call pl2ip(t,4) r=t(1) drdrl=t(2) scleqn=t(3) seqdot=t(4) else if(iprob.eq.3) then t(1)=r t(2)=drdrl call pl2ip(t,2) r=t(1) drdrl=t(2) else t(1)=r call pl2ip(t,1) r=t(1) endif rp(22)=r rp(55)=anorm c call mtxdbc(nvf,ja,a,amtx,anorm,mark,1) call mt0dbc(ja0,a0,0,0.0d0,mark,zp,nproc,irgn, + nvv,newnvf,nvi,nvf,ipath,jequv,q,1) do i=1,nvf if(iequv(i).ne.i) a(q(i))=anorm enddo c c scalar function c if(iprob.eq.4) then do i=1,nvf if(mark(q(i)).eq.1) then d(i)=0.0d0 dl(i)=0.0d0 p(i)=0.0d0 if(i.le.nvv) then d(i+nvf)=0.0d0 dl(i+nvf)=0.0d0 endif endif enddo rp(67)=scleqn rp(74)=seqdot call setbdl(rp,isw) call mtxdbc(nvf,ja,h,0,0.0d0,mark,1) call mt0dbc(ja0,h0,0,0.0d0,mark,zp,nproc,irgn, + nvv,newnvf,nvi,nvf,ipath,jequv,q,1) else if(iprob.eq.5) then do i=1,nvf if(mark(q(i)).eq.1) p(i)=0.0d0 enddo call mtxdbc(nvf,ja,h,0,0.0d0,mark,1) call mtxdbc(nvf,ja,sm,smtx,0.0d0,mark,0) call mtxdbc(nvf,ja,su,smtx,0.0d0,mark,0) call mt0dbc(ja0,h0,0,0.0d0,mark,zp,nproc,irgn, + nvv,newnvf,nvi,nvf,ipath,jequv,q,1) call mt0dbc(ja0,sm0,0,0.0d0,mark,zp,nproc,irgn, + nvv,newnvf,nvi,nvf,ipath,jequv,q,0) call mt0dbc(ja0,su0,0,0.0d0,mark,zp,nproc,irgn, + nvv,newnvf,nvi,nvf,ipath,jequv,q,0) else if(iprob.eq.3) then do i=1,nvf if(mark(q(i)).eq.1) then d(i)=0.0d0 p(i)=0.0d0 endif enddo rl0=rp(31) r0=rp(32) thetal=rp(69) thetar=rp(70) sigma=rp(71) scleqn=thetar*(r-r0)+thetal*(rl-rl0)-sigma rp(67)=scleqn rp(73)=drdrl endif c c finish rhs c ii=ipath(1,irgn)-1 if(iprob.eq.4) then do i=1,nvv gf(ii+i,1)=b(i) gf(ii+i,2)=u(i) gf(ii+i,3)=p(i) gf(ii+i,4)=um(i) enddo num=4 else if(iprob.eq.5) then do i=1,nvv gf(ii+i,1)=b(i) gf(ii+i,2)=u(i) gf(ii+i,3)=p(i) gf(ii+i,4)=um(i) gf(ii+i,5)=dl(i) gf(ii+i,6)=uc(i) enddo num=6 else do i=1,nvv gf(ii+i,1)=b(i) gf(ii+i,2)=u(i) enddo num=2 endif iin=1 iout=iin+num*nn icnt=iout+num*nn ioff=icnt+nproc call exbdy(ipath,gf,nn,num,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),b,z,ispd,1) jspd=1 if(ispd.ne.1) jspd=-1 if(iprob.eq.4) then call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,3),p,z,1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,1),p,z,jspd,0) else if(iprob.eq.5) then call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,sm0,gf(1,6),gf(1,1),b,z,0,0) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,g0,gf(1,6),gf(1,5),dl,z,1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,sm0,gf(1,4),gf(1,1),dl,z,-1,0) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,su0,gf(1,2),gf(1,1),dl,z,-1,0) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,3),p,z,1,1) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,1),p,z,jspd,0) call jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,su0,gf(1,6),gf(1,1),p,z,0,0) endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine l2gd(it,iprob,irgn,itnode,iequv,q,amtx,smtx,ja,a, + h,g,su,sm,amtx0,smtx0,ja0,a0,h0,g0,su0,sm0,b,d,p,dl, 1 fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn,seqdot, 2 nvf,nvv,newnvf,nvi,nproc,ipath,jequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ja(*),q(*),iequv(*),amtx,amtx0, 1 ja0(*),ipath(4,*),jequv(*),smtx,smtx0 double precision 1 a(*),h(*),b(*),d(*),p(*),dl(*),fa(6,6),fb(6),fd(6), 2 fp(12),fh(6,6),fdl(12),a0(*),h0(*),g(*),fg(6,6),g0(*), 3 su(*),su0(*),sm(*),sm0(*),fsm(6,6),fsu(6,6) c c update global matrices/vectors from element matrices/vectors c jrgn=itnode(4,it) if(irgn.eq.jrgn) then r=r+fp(8) if(iprob.eq.4) then scleqn=scleqn-fp(7) seqdot=seqdot-fdl(7) do k=1,3 ivk=iequv(itnode(k,it)) dl(ivk)=dl(ivk)-fdl(k) d(ivk)=d(ivk)-fd(k) p(ivk)=p(ivk)-fp(k) b(ivk)=b(ivk)-fb(k) enddo else if(iprob.eq.5) then do k=1,3 ivk=iequv(itnode(k,it)) p(ivk)=p(ivk)-fp(k) dl(ivk)=dl(ivk)-fdl(k) b(ivk)=b(ivk)-fb(k) enddo else if(iprob.eq.3) then drdrl=drdrl+fp(7) do k=1,3 ivk=iequv(itnode(k,it)) d(ivk)=d(ivk)-fd(k) p(ivk)=p(ivk)+fp(k) b(ivk)=b(ivk)-fb(k) enddo else if(iprob.eq.2) then do k=1,3 ivk=iequv(itnode(k,it)) b(ivk)=b(ivk)-fp(k) enddo else do k=1,3 ivk=iequv(itnode(k,it)) b(ivk)=b(ivk)-fb(k) enddo endif else if(iprob.eq.4) then do k=1,3 ivk=iequv(itnode(k,it)) if(ivk.le.nvv) then dl(ivk+nvf)=dl(ivk+nvf)-fdl(k) d(ivk+nvf)=d(ivk+nvf)-fd(k) else dl(ivk)=dl(ivk)-fdl(k) d(ivk)=d(ivk)-fd(k) endif enddo endif endif do k=1,3 ivk=q(iequv(itnode(k,it))) if(iprob.eq.2) then a(ivk)=a(ivk)+fh(k,k) else a(ivk)=a(ivk)+fa(k,k) endif if(iprob.eq.4) then h(ivk)=h(ivk)+fh(k,k) else if(iprob.eq.5) then h(ivk)=h(ivk)+fh(k,k) g(ivk)=g(ivk)+fg(k,k) sm(ivk)=sm(ivk)+fsm(k,k) su(ivk)=su(ivk)+fsu(k,k) endif do j=k+1,3 ivj=q(iequv(itnode(j,it))) call jamap(ivk,ivj,kj,jk,ja,amtx) if(iprob.eq.2) then akj=a(kj)+fh(k,j) a(jk)=a(jk)+fh(j,k) a(kj)=akj else akj=a(kj)+fa(k,j) a(jk)=a(jk)+fa(j,k) a(kj)=akj endif if(iprob.eq.4) then jk=min0(kj,jk) h(jk)=h(jk)+fh(j,k) else if(iprob.eq.5) then call jamap(ivk,ivj,kj,jk,ja,smtx) sm(jk)=sm(jk)+fsm(j,k) sm(kj)=sm(kj)+fsm(k,j) su(jk)=su(jk)+fsu(j,k) su(kj)=su(kj)+fsu(k,j) jk=min0(kj,jk) h(jk)=h(jk)+fh(j,k) g(jk)=g(jk)+fg(j,k) endif enddo c c interface matrices c ivk=iequv(itnode(k,it)) if(ivk.le.nvv) then ivkb=i2j(ivk,irgn,jrgn,1,0,ipath,jequv) else if(ivk.le.newnvf) then ivkb=-ivk else if(ivk.le.nvi) then ii=ivk-newnvf ivkb=i2j(ii,nproc+1,jrgn,1,0,ipath,jequv) else ivkb=-ivk endif if(ivkb.gt.0) then if(iprob.eq.2) then a0(ivkb)=a0(ivkb)+fh(k,k) else a0(ivkb)=a0(ivkb)+fa(k,k) endif if(iprob.eq.4) then h0(ivkb)=h0(ivkb)+fh(k,k) else if(iprob.eq.5) then h0(ivkb)=h0(ivkb)+fh(k,k) g0(ivkb)=g0(ivkb)+fg(k,k) sm0(ivkb)=sm0(ivkb)+fsm(k,k) su0(ivkb)=su0(ivkb)+fsu(k,k) endif endif c do j=k+1,3 ivj=iequv(itnode(j,it)) if(ivj.le.nvv) then ivjb=i2j(ivj,irgn,jrgn,1,0,ipath,jequv) else if(ivj.le.newnvf) then ivjb=-ivj else if(ivj.le.nvi) then ii=ivj-newnvf ivjb=i2j(ii,nproc+1,jrgn,1,0,ipath,jequv) else ivjb=-ivj endif if(max0(ivjb,ivkb).gt.0) then call ja0map(ivk,ivj,ivkb,ivjb,kj,jk,ja0,amtx0) if(iprob.eq.2) then akj=a0(kj)+fh(k,j) a0(jk)=a0(jk)+fh(j,k) a0(kj)=akj else akj=a0(kj)+fa(k,j) a0(jk)=a0(jk)+fa(j,k) a0(kj)=akj endif if(iprob.eq.4) then jk=min0(kj,jk) h0(jk)=h0(jk)+fh(j,k) elseif(iprob.eq.5) then call ja0map(ivk,ivj,ivkb,ivjb,kj,jk, + ja0,smtx0) sm0(jk)=sm0(jk)+fsm(j,k) sm0(kj)=sm0(kj)+fsm(k,j) su0(jk)=su0(jk)+fsu(j,k) su0(kj)=su0(kj)+fsu(k,j) jk=min0(kj,jk) h0(jk)=h0(jk)+fh(j,k) g0(jk)=g0(jk)+fg(j,k) endif endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine linsys(ip,itnode,ibndry,vx,vy,xm,ym,b,d,p,dl,q,ja,a, + h,g,su,sm,u,um,uc,d1u,d2u,udot,vx0,vy0,u0,u0dot,rp,mark, 1 ibedge,iequv,bdlwr,bdupr,gm,isw,a1xy,a2xy,fxy,gnxy,gdxy, 2 p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ja(*),q(*),mark(*), 1 ibedge(2,*),iequv(*),amtx,ip(100),smtx double precision + vx(*),vy(*),u(*),u0(*),vx0(*),vy0(*),udot(*),rp(100), 1 a(*),b(*),d(*),p(*),xm(*),ym(*),um(*),u0dot(*), 2 dl(*),h(*),bdlwr(*),bdupr(*),gm(*),d1u(*),d2u(*), 3 uc(*),g(*),su(*),sm(*) double precision + fa(6,6),fh(6,6),fg(6,6),fsm(6,6),fsu(6,6), 1 fb(6),fd(6),fp(12),fdl(12),fz(36) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy c c compute stiffness matrix, right hand side, and c the derivative of the rhs with respect to lamda c c initialize c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=ip(6) idbcpt=ip(7) ispd=ip(8) c call bcinit(ip,rp,ibndry,vx,vy,u,udot,u0,u0dot, + um,uc,d1u,d2u,iequv,gdxy) c do i=1,36 fz(i)=0.0d0 enddo smtx=ja(nvf+1)-ja(1) if(ispd.eq.1) then amtx=0 else amtx=ja(nvf+1)-ja(1) endif c c initialize c do i=1,ja(nvf+1)-1+amtx a(i)=0.0d0 enddo c rl=rp(21) sh=rp(45) do i=1,nvf b(i)=0.0d0 mark(i)=0 enddo if(iprob.eq.4) then do i=1,nvf p(i)=0.0d0 d(i)=0.0d0 dl(i)=0.0d0 enddo do i=1,ja(nvf+1)-1 h(i)=0.0d0 enddo elseif(iprob.eq.5) then do i=1,nvf dl(i)=0.0d0 p(i)=0.0d0 enddo do i=1,ja(nvf+1)-1 h(i)=0.0d0 g(i)=0.0d0 enddo do i=1,ja(nvf+1)-1+smtx su(i)=0.0d0 sm(i)=0.0d0 enddo elseif(iprob.eq.3) then do i=1,nvf p(i)=0.0d0 d(i)=0.0d0 enddo endif c r=0.0d0 drdrl=0.0d0 scleqn=0.0d0 seqdot=0.0d0 ifirst=3 c c assemble and update elements c do i=1,ntf call eleasm(i,itnode,vx,vy,u,um,uc,d1u,d2u,vx0,vy0,u0, + rl,sh,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,0, 1 ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) ifirst=0 call l2g(i,iprob,itnode,iequv,q,amtx,ja,a,h,g,smtx, + su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r, 1 drdrl,scleqn,seqdot) enddo c c boundary edges c do i=1,nbf c c functional rho c if(ibndry(5,i).le.0) then do j=1,2 if(ibedge(j,i).gt.0) then call elebdi(i,j,itnode,ibndry,ibedge, + vx,vy,xm,ym,u,uc,rl,fh,fg,fsu, 1 fp,fdl,iprob,0,p2xy) it=ibedge(j,i)/4 call l2g(it,iprob,itnode,iequv,q,amtx,ja, + a,h,g,smtx,su,sm,b,d,p,dl,fz,fh,fg, 1 fz,fsu,fz,fz,fp,fdl,r,drdrl,scleqn, 2 seqdot) endif enddo endif c c neumann edge c if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 iprob,0,gnxy) call l2g(it,iprob,itnode,iequv,q,amtx,ja,a,h,g, + smtx,su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd, 1 fp,fdl,r,drdrl,scleqn,seqdot) c c dirichlet edge c else if(ibndry(4,i).eq.2) then mark(q(iequv(ibndry(1,i))))=1 mark(q(iequv(ibndry(2,i))))=1 endif enddo if(idbcpt.gt.0) mark(q(iequv(idbcpt)))=1 c c modifications for obstacle problem c if(iprob.eq.2) call setbd(ip,rp,isw,vx,vy,gm,itnode, + iequv,bdlwr,bdupr,q,a,u,b) if(iprob.eq.5) call setbd(ip,rp,isw,vx,vy,gm,itnode, + iequv,bdlwr,bdupr,q,g,uc,dl) c c set dirichlet boundary conditions c anorm=0.0d0 do i=1,nvf if(mark(q(i)).eq.1) b(i)=0.0d0 anorm=dmax1(dabs(a(i)),anorm) enddo if(anorm.le.0.0d0) anorm=1.0d0 rp(22)=r rp(55)=anorm c call mtxdbc(nvf,ja,a,amtx,anorm,mark,1) do i=1,nvf if(iequv(i).ne.i) a(q(i))=anorm enddo c c scalar function c if(iprob.eq.4) then do i=1,nvf if(mark(q(i)).eq.1) then d(i)=0.0d0 dl(i)=0.0d0 p(i)=0.0d0 endif enddo call mtxdbc(nvf,ja,h,0,0.0d0,mark,1) rp(67)=scleqn rp(74)=seqdot call setbdl(rp,isw) elseif(iprob.eq.5) then do i=1,nvf if(mark(q(i)).eq.1) then p(i)=0.0d0 endif enddo call mtxdbc(nvf,ja,h,0,0.0d0,mark,1) call mtxdbc(nvf,ja,sm,smtx,0.0d0,mark,0) call mtxdbc(nvf,ja,su,smtx,0.0d0,mark,0) elseif(iprob.eq.3) then do i=1,nvf if(mark(q(i)).eq.1) then d(i)=0.0d0 p(i)=0.0d0 endif enddo rl0=rp(31) r0=rp(32) thetal=rp(69) thetar=rp(70) sigma=rp(71) scleqn=thetar*(r-r0)+thetal*(rl-rl0)-sigma rp(67)=scleqn rp(73)=drdrl endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine reord(n,ja,a,ja0,a0,q,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ja0(*),q(*),amtx double precision + a(*),a0(*) c amtx=0 if(ispd.ne.1) amtx=ja(n+1)-ja(1) do i=1,ja(n+1)-1+amtx a0(i)=a(i) enddo do i=1,n ii=q(i) a(ii)=a0(i) do j=ja0(i),ja0(i+1)-1 jj=q(ja0(j)) call jamap(ii,jj,ij,ji,ja,amtx) a(ij)=a0(j) a(ji)=a0(j+amtx) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxdbc(n,ja,a,amtx,anorm,mark,isym) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx,mark(*) double precision + a(*) c c set matrix dirichlet boundary conditions c c set dirichlet boundary conditions symmetrically c if(isym.eq.1) then do i=1,n if(mark(i).eq.1) a(i)=anorm do jj=ja(i),ja(i+1)-1 if(mark(i).eq.1.or.mark(ja(jj)).eq.1) then a(jj)=0.0d0 a(jj+amtx)=0.0d0 endif enddo enddo else if(isym.eq.0) then c c set dirichlet boundary conditions only for rows c do i=1,n if(mark(i).eq.1) then a(i)=0.0d0 do jj=ja(i),ja(i+1)-1 a(jj)=0.0d0 if(mark(ja(jj)).eq.1) a(jj+amtx)=0.0d0 enddo else do jj=ja(i),ja(i+1)-1 if(mark(ja(jj)).eq.1) a(jj+amtx)=0.0d0 enddo endif enddo else if(isym.eq.-1) then c c set dirichlet boundary conditions only for columns c do i=1,n if(mark(i).eq.1) then a(i)=0.0d0 do jj=ja(i),ja(i+1)-1 a(jj+amtx)=0.0d0 if(mark(ja(jj)).eq.1) a(jj)=0.0d0 enddo else do jj=ja(i),ja(i+1)-1 if(mark(ja(jj)).eq.1) a(jj)=0.0d0 enddo endif enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mt0dbc(ja,a,amtx,anorm,mark,imark,nproc, + irgn,nvv,newnvf,nvi,nvf,ipath,jequv,q,isym) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx,mark(*),jequv(*),q(*),ipath(4,*),imark(*) double precision + a(*) c c set matrix dirichlet boundary conditions for interface matrix c n=ipath(2,nproc+2) do i=1,n imark(i)=0 enddo do ii=1,nvv if(mark(q(ii)).eq.1) then i=ii+ipath(1,irgn)-1 it=i 20 imark(it)=1 it=jequv(it) if(it.ne.i) go to 20 endif enddo do ii=newnvf+1,nvi if(mark(q(ii)).eq.1) then i=ii-newnvf+ipath(1,nproc+1)-1 it=i 30 imark(it)=1 it=jequv(it) if(it.ne.i) go to 30 endif enddo c if(isym.eq.1) then do i=1,n mi=imark(i) if(mi.eq.1) a(i)=anorm do jj=ja(i),ja(i+1)-1 if(ja(jj).gt.0) then mj=imark(ja(jj)) else mj=mark(q(-ja(jj))) endif if(mi.eq.1.or.mj.eq.1) then a(jj)=0.0d0 a(jj+amtx)=0.0d0 endif enddo enddo else if(isym.eq.0) then c c set dirichlet boundary conditions only for rows c do i=1,n mi=imark(i) if(mi.eq.1) then a(i)=0.0d0 do jj=ja(i),ja(i+1)-1 if(ja(jj).gt.0) then mj=imark(ja(jj)) else mj=mark(q(-ja(jj))) endif a(jj)=0.0d0 if(mj.eq.1) a(jj+amtx)=0.0d0 enddo else do jj=ja(i),ja(i+1)-1 if(ja(jj).gt.0) then mj=imark(ja(jj)) else mj=mark(q(-ja(jj))) endif if(mj.eq.1) a(jj+amtx)=0.0d0 enddo endif enddo else if(isym.eq.-1) then c c set dirichlet boundary conditions only for columns c do i=1,n mi=imark(i) if(mi.eq.1) then a(i)=0.0d0 do jj=ja(i),ja(i+1)-1 if(ja(jj).gt.0) then mj=imark(ja(jj)) else mj=mark(q(-ja(jj))) endif a(jj+amtx)=0.0d0 if(mj.eq.1) a(jj)=0.0d0 enddo else do jj=ja(i),ja(i+1)-1 if(ja(jj).gt.0) then mj=imark(ja(jj)) else mj=mark(q(-ja(jj))) endif if(mj.eq.1) a(jj)=0.0d0 enddo endif enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine l2g(it,iprob,itnode,iequv,q,amtx,ja,a,h,g,smtx, + su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl, 1 scleqn,seqdot) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ja(*),q(*),iequv(*),amtx,smtx double precision 1 a(*),h(*),b(*),d(*),p(*),dl(*),fa(6,6),fb(6),fd(6), 2 fp(12),fh(6,6),fdl(12),g(*),fg(6,6),su(*),sm(*), 3 fsm(6,6),fsu(6,6) c c update global matrices/vectors from element matrices/vectors c r=r+fp(8) if(iprob.eq.4) then scleqn=scleqn-fp(7) seqdot=seqdot-fdl(7) do k=1,3 ivk=iequv(itnode(k,it)) dl(ivk)=dl(ivk)-fdl(k) d(ivk)=d(ivk)-fd(k) p(ivk)=p(ivk)-fp(k) ivk=q(ivk) h(ivk)=h(ivk)+fh(k,k) do j=k+1,3 ivj=q(iequv(itnode(j,it))) call jamap(ivk,ivj,kj,jk,ja,amtx) jk=min0(kj,jk) h(jk)=h(jk)+fh(j,k) enddo enddo else if(iprob.eq.5) then do k=1,3 ivk=iequv(itnode(k,it)) dl(ivk)=dl(ivk)-fdl(k) p(ivk)=p(ivk)-fp(k) ivk=q(ivk) h(ivk)=h(ivk)+fh(k,k) g(ivk)=g(ivk)+fg(k,k) sm(ivk)=sm(ivk)+fsm(k,k) su(ivk)=su(ivk)+fsu(k,k) do j=k+1,3 ivj=q(iequv(itnode(j,it))) call jamap(ivk,ivj,kj,jk,ja,smtx) sm(jk)=sm(jk)+fsm(j,k) sm(kj)=sm(kj)+fsm(k,j) su(jk)=su(jk)+fsu(j,k) su(kj)=su(kj)+fsu(k,j) jk=min0(kj,jk) h(jk)=h(jk)+fh(j,k) g(jk)=g(jk)+fg(j,k) enddo enddo else if(iprob.eq.3) then drdrl=drdrl+fp(7) do k=1,3 ivk=iequv(itnode(k,it)) d(ivk)=d(ivk)-fd(k) p(ivk)=p(ivk)+fp(k) enddo endif if(iprob.eq.2) then do k=1,3 ivk=iequv(itnode(k,it)) b(ivk)=b(ivk)-fp(k) ivk=q(ivk) a(ivk)=a(ivk)+fh(k,k) do j=k+1,3 ivj=q(iequv(itnode(j,it))) call jamap(ivk,ivj,kj,jk,ja,amtx) akj=a(kj)+fh(k,j) a(jk)=a(jk)+fh(j,k) a(kj)=akj enddo enddo else do k=1,3 ivk=iequv(itnode(k,it)) b(ivk)=b(ivk)-fb(k) ivk=q(ivk) a(ivk)=a(ivk)+fa(k,k) do j=k+1,3 ivj=q(iequv(itnode(j,it))) call jamap(ivk,ivj,kj,jk,ja,amtx) akj=a(kj)+fa(k,j) a(jk)=a(jk)+fa(j,k) a(kj)=akj enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eleasm(itri,itnode,vx,vy,u,um,uc,d1u,d2u,vx0,vy0,u0, + rl,sh,a,h,g,sm,su,b,d,p,dl,isw,ispd,iprob,ifirst, 1 a1xy,a2xy,fxy,p1xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),map(5,5) double precision + vx(*),vy(*),u(*),u0(*),a(6,6),b(6),d(6),p(12),c(3,12), 1 gv(6),gx(6),gy(6),ca1(15),ca2(15),cf(15),cp1(15),tx(3), 2 ty(3),x(3),y(3),wt(12),bx1(5),by1(5),bx2(5),h(6,6),s(5), 3 dl(12),vx0(*),vy0(*),um(*),r(5),by2(5),d11(5),d12(5), 4 d21(5),d22(5),a10(5),a11(5),a12(5),a20(5),a21(5),a22(5), 5 b1(5),b2(5),d1u(*),d2u(*),uc(*),g(6,6),sm(6,6),su(6,6) external a1xy,a2xy,fxy,p1xy save npts,wt,c,index,map data index/1,2,3,2,3,1,3,1,2/ data map/1,2,3,4,5,2,6,9,10,12,3,9,7,11,13, + 4,10,11,8,14,5,12,13,14,15/ c c this routine computes the element stiffness matrix and c right hand side c c isw = 0 - piecewise linear basis functions c 1 - piecewise quadratic bump functions c 2 - piecewise quadratic functions c c f( 1) = f c c f( 2) = df/du c f( 3) = df/dux c f( 4) = df/duy c f( 5) = df/drl c c f( 6) = d2f/du du c f( 7) = d2f/dux dux c f( 8) = d2f/duy duy c f( 9) = d2f/du dux c f(10) = d2f/du duy c f(11) = d2f/dux duy c f(12) = d2f/du drl c f(13) = d2f/dux drl c f(14) = d2f/duy drl c f(15) = d2f/drl drl c c the block matrix/rhs c c | h a^t dl | | du | | p | c | a 0 d | | dum | = - | b | c | dl^t d^t dl_7| | drl | | p_7| c c | h a^t su | | du | | p | c | a 0 sm | | dum | = - | b | c | su^t sm^t g | | duc | | dl | c c if(ifirst.gt.0) then npts=ifirst ifirst=0 call cquad2(npts,wt,c) endif c c read vertex numbers c iv1=itnode(1,itri) iv2=itnode(2,itri) iv3=itnode(3,itri) itag=itnode(5,itri) c c compute tangent vectors c do j=1,3 j2=itnode(index(2,j),itri) j3=itnode(index(3,j),itri) tx(j)=vx(j3)-vx(j2) ty(j)=vy(j3)-vy(j2) enddo det=tx(2)*ty(3)-tx(3)*ty(2) c c compute normal directions c do j=1,3 x(j)=-ty(j)/det y(j)=tx(j)/det enddo ux=u(iv1)*x(1)+u(iv2)*x(2)+u(iv3)*x(3) uy=u(iv1)*y(1)+u(iv2)*y(2)+u(iv3)*y(3) if(iprob.eq.4) then umx=um(iv1)*x(1)+um(iv2)*x(2)+um(iv3)*x(3) umy=um(iv1)*y(1)+um(iv2)*y(2)+um(iv3)*y(3) d1x=d1u(iv1)*x(1)+d1u(iv2)*x(2)+d1u(iv3)*x(3) d1y=d1u(iv1)*y(1)+d1u(iv2)*y(2)+d1u(iv3)*y(3) d2x=d2u(iv1)*x(1)+d2u(iv2)*x(2)+d2u(iv3)*x(3) d2y=d2u(iv1)*y(1)+d2u(iv2)*y(2)+d2u(iv3)*y(3) else if(iprob.eq.5) then umx=um(iv1)*x(1)+um(iv2)*x(2)+um(iv3)*x(3) umy=um(iv1)*y(1)+um(iv2)*y(2)+um(iv3)*y(3) d1x=0.0d0 d1y=0.0d0 d2x=0.0d0 d2y=0.0d0 else umx=0.0d0 umy=0.0d0 d1x=0.0d0 d1y=0.0d0 d2x=0.0d0 d2y=0.0d0 endif c istart=1 if(isw.eq.1) istart=4 istop=6 if(isw.eq.0) istop=3 c c do i=istart,istop b(i)=0.0d0 d(i)=0.0d0 p(i)=0.0d0 dl(i)=0.0d0 do j=istart,istop a(i,j)=0.0d0 h(i,j)=0.0d0 g(i,j)=0.0d0 sm(i,j)=0.0d0 su(i,j)=0.0d0 enddo enddo p(7)=0.0d0 p(8)=0.0d0 dl(7)=0.0d0 dl(8)=0.0d0 c det=dabs(det)/2.0d0 c do i=1,npts c c evaluate basis functions c if(istart.eq.1) then do j=1,3 gv(j)=c(j,i) gx(j)=x(j) gy(j)=y(j) enddo endif if(istop.eq.6) then do j=1,3 j2=index(2,j) j3=index(3,j) gv(j+3)=c(j2,i)*c(j3,i)*4.0d0 gx(j+3)=(x(j2)*c(j3,i)+x(j3)*c(j2,i))*4.0d0 gy(j+3)=(y(j2)*c(j3,i)+y(j3)*c(j2,i))*4.0d0 enddo endif c c function evaluations c we=wt(i)*det xx=c(1,i)*vx(iv1)+c(2,i)*vx(iv2)+c(3,i)*vx(iv3) yy=c(1,i)*vy(iv1)+c(2,i)*vy(iv2)+c(3,i)*vy(iv3) uu=c(1,i)* u(iv1)+c(2,i)* u(iv2)+c(3,i)* u(iv3) do k=1,15 ca1(k)=0.0d0 ca2(k)=0.0d0 cp1(k)=0.0d0 cf(k)=0.0d0 enddo if(iprob.eq.5) then rr=c(1,i)*uc(iv1)+c(2,i)*uc(iv2)+c(3,i)*uc(iv3) else rr=rl endif call a1xy(xx,yy,uu,ux,uy,rr,itag,ca1) call a2xy(xx,yy,uu,ux,uy,rr,itag,ca2) call p1xy(xx,yy,uu,ux,uy,rr,itag,cp1) call fxy(xx,yy,uu,ux,uy,rr,itag,cf) c c space-time derivatives c if(iprob.eq.6) then xx0=c(1,i)*vx0(iv1)+c(2,i)*vx0(iv2)+c(3,i)*vx0(iv3) yy0=c(1,i)*vy0(iv1)+c(2,i)*vy0(iv2)+c(3,i)*vy0(iv3) uu0=c(1,i)* u0(iv1)+c(2,i)* u0(iv2)+c(3,i)* u0(iv3) uut=(uu-uu0)*sh xxt=(xx-xx0)*sh yyt=(yy-yy0)*sh cf(1)=cf(1)+uut-xxt*ux-yyt*uy cf(2)=cf(2)+sh cf(3)=cf(3)-xxt cf(4)=cf(4)-yyt endif c c divergence free upwinding c if(ispd.eq.0) then do k=1,5 bx1(k)=ca1(map(2,k)) by1(k)=ca2(map(2,k)) bx2(k)=cf(map(3,k)) by2(k)=cf(map(4,k)) d11(k)=ca1(map(3,k)) d12(k)=ca1(map(4,k)) d21(k)=ca2(map(3,k)) d22(k)=ca2(map(4,k)) a10(k)=0.0d0 a11(k)=0.0d0 a12(k)=0.0d0 a20(k)=0.0d0 a21(k)=0.0d0 a22(k)=0.0d0 b1(k)=0.0d0 b2(k)=0.0d0 enddo call upwind(bx1,by1,d11,d12,d21,d22, 1 tx,ty,x,y,c(1,i),a10,a11,a12,a20,a21,a22) call upwind(bx2,by2,d11,d21,d12,d22, 1 tx,ty,x,y,c(1,i),b1, a11,a21,b2, a12,a22) c do k=1,5 ca1(k)=ca1(k)+a11(k)*ux+a12(k)*uy+a10(k)*uu ca2(k)=ca2(k)+a21(k)*ux+a22(k)*uy+a20(k)*uu cf(k)=cf(k)+b1(k)*ux+b2(k)*uy enddo ca1(2)=ca1(2)+a10(1) ca1(3)=ca1(3)+a11(1) ca1(4)=ca1(4)+a12(1) ca2(2)=ca2(2)+a20(1) ca2(3)=ca2(3)+a21(1) ca2(4)=ca2(4)+a22(1) cf(3)=cf(3)+b1(1) cf(4)=cf(4)+b2(1) c endif c c update rho y c p(8)=p(8)+cp1(1)*we c c adjust derivatives for the case iprob = 4 c if(iprob.eq.4.or.iprob.eq.5) then umu=c(1,i)*um(iv1)+c(2,i)*um(iv2)+c(3,i)*um(iv3) d1=c(1,i)*d1u(iv1)+c(2,i)*d1u(iv2)+c(3,i)*d1u(iv3) d2=c(1,i)*d2u(iv1)+c(2,i)*d2u(iv2)+c(3,i)*d2u(iv3) do j=1,15 cp1(j)=cp1(j)+umu*cf(j)+umx*ca1(j)+umy*ca2(j) enddo do j=1,5 cp1(map(j,5))=cp1(map(j,5))+cp1(map(j,2))*d1 + +cp1(map(j,3))*d1x+cp1(map(j,4))*d1y ca1(map(j,5))=ca1(map(j,5))+ca1(map(j,2))*d1 + +ca1(map(j,3))*d1x+ca1(map(j,4))*d1y ca2(map(j,5))=ca2(map(j,5))+ca2(map(j,2))*d1 + +ca2(map(j,3))*d1x+ca2(map(j,4))*d1y cf(map(j,5))=cf(map(j,5))+cf(map(j,2))*d1 + +cf(map(j,3))*d1x+cf(map(j,4))*d1y enddo cp1(map(5,5))=cp1(map(5,5))+cp1(map(1,2))*d2 + +cp1(map(1,3))*d2x+cp1(map(1,4))*d2y ca1(map(5,5))=ca1(map(5,5))+ca1(map(1,2))*d2 + +ca1(map(1,3))*d2x+ca1(map(1,4))*d2y ca2(map(5,5))=ca2(map(5,5))+ca2(map(1,2))*d2 + +ca2(map(1,3))*d2x+ca2(map(1,4))*d2y cf(map(5,5))=cf(map(5,5))+cf(map(1,2))*d2 + +cf(map(1,3))*d2x+cf(map(1,4))*d2y endif c c element assembly c dl(8)=dl(8)+cp1(1)*we p(7)=p(7)+cp1(5)*we dl(7)=dl(7)+cp1(15)*we do k=istart,istop qx=we*gx(k) qy=we*gy(k) qv=we*gv(k) do j=1,5 s(j)=ca1(j)*qx+ca2(j)*qy+cf(j)*qv r(j)=cp1(map(2,j))*qv + +cp1(map(3,j))*qx+cp1(map(4,j))*qy enddo c b(k)=b(k)+s(1) d(k)=d(k)+s(5) p(k)=p(k)+r(1) do j=istart,istop a(k,j)=a(k,j)+s(2)*gv(j)+s(3)*gx(j)+s(4)*gy(j) enddo if(iprob.eq.5) then dl(k)=dl(k)+cp1(5)*qv rr=cp1(15)*qv do j=istart,istop h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j) g(k,j)=g(k,j)+rr*gv(j) sm(k,j)=sm(k,j)+s(5)*gv(j) su(k,j)=su(k,j)+r(5)*gv(j) enddo else if(iprob.eq.4.or.iprob.eq.2) then dl(k)=dl(k)+r(5) do j=istart,istop h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j) enddo endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine upwind(bx,by,d11,d12,d21,d22,tx,ty,x,y,c, + a10,a11,a12,a20,a21,a22) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + index(3,3) double precision + tx(3),ty(3),x(3),y(3),c(3),bp(3),bm(3),g(3),r(3), 1 rm(3),rp(3),s(3),gp(3),bx(5),by(5), 2 d11(5),d12(5),d21(5),d22(5),a10(5),a11(5),a12(5), 3 a20(5),a21(5),a22(5) save index data index/1,2,3,2,3,1,3,1,2/ c c c if(dabs(bx(1))+dabs(by(1)).eq.0.0d0) return dd=(d12(1)+d21(1))/2.0d0 det=d11(1)*d22(1)-dd**2 if(dabs(det).eq.0.0d0) return c bbx=(d22(1)*bx(1)-dd*by(1))/det bby=(d11(1)*by(1)-dd*bx(1))/det c c evaluate laplacian terms c g(1)=-(x(2)*(d11(1)*x(3)+dd*y(3))+y(2)*(dd*x(3)+d22(1)*y(3))) g(2)=-(x(3)*(d11(1)*x(1)+dd*y(1))+y(3)*(dd*x(1)+d22(1)*y(1))) g(3)=-(x(1)*(d11(1)*x(2)+dd*y(2))+y(1)*(dd*x(2)+d22(1)*y(2))) c c evaluate bernoulli functions c kmin=1 do j=1,3 if(g(j).lt.g(kmin)) kmin=j betax=bbx*tx(j)+bby*ty(j) call bexp(betax,betaxp,bep,bem,dbep,dbem) bp(j)=bep*g(j) bm(j)=bem*g(j) enddo c c possible fix-up for obtuse angle c if(g(kmin).lt.0.0d0) then k2=index(2,kmin) k3=index(3,kmin) bmax=dmax1(bp(k2),bp(k3),bm(k2),bm(k3)) do j=1,3 rm(j)=bm(j)/bmax rp(j)=bp(j)/bmax enddo do j=1,3 j2=index(2,j) j3=index(3,j) rr=rm(j2)*rm(j3)+rp(j2)*rp(j3) r(j)=rp(j2)*rm(j3)+rr s(j)=rm(j2)*rp(j3)+rr enddo ratio=dmin1(1.0d0,-r(kmin)/(r(k2)+r(k3)), + -s(kmin)/(s(k2)+s(k3))) bp(kmin)=bp(kmin)*ratio bm(kmin)=bm(kmin)*ratio endif c c compute upwind diffusion matrix c c2=(bm(3)-bp(3)+bp(1)-bm(1))/3.0d0 c3=(bm(1)-bp(1)+bp(2)-bm(2))/3.0d0 c e22=bm(3)+bp(1)-(g(3)+g(1))-c2 e32=-bp(1)+g(1)-c3 e23=-bm(1)+g(1)-c2 e33=bm(1)+bp(2)-(g(1)+g(2))-c3 c e2=e22*tx(3)-e23*tx(2) e3=e32*tx(3)-e33*tx(2) a11(1)=a11(1)+tx(3)*e2-tx(2)*e3 a21(1)=a21(1)+ty(3)*e2-ty(2)*e3 c e2=e22*ty(3)-e23*ty(2) e3=e32*ty(3)-e33*ty(2) a12(1)=a12(1)+tx(3)*e2-tx(2)*e3 a22(1)=a22(1)+ty(3)*e2-ty(2)*e3 c c compute upwind convection term c if(g(kmin).lt.0.0d0) then e2=3.0d0*c2-(bx(1)*x(2)+by(1)*y(2)) e3=3.0d0*c3-(bx(1)*x(3)+by(1)*y(3)) c a10(1)=a10(1)+tx(3)*e2-tx(2)*e3 c a20(1)=a20(1)+ty(3)*e2-ty(2)*e3 endif c c now do derivatives c do 10 k=2,5 aa=dabs(bx(k))+dabs(by(k))+dabs(d11(k)) + +dabs(d12(k))+dabs(d21(k))+dabs(d22(k)) if(aa.le.0.0d0) go to 10 ddp=(d12(k)+d21(k))/2.0d0 detp=d11(k)*d22(1)+d11(1)*d22(k)-2.0d0*dd*ddp bbxp=(d22(k)*bx(1)+d22(1)*bx(k) + -ddp*by(1)-dd*by(k)-bbx*detp)/det bbyp=(d11(k)*by(1)+d11(1)*by(k) + -ddp*bx(1)-dd*bx(k)-bby*detp)/det gp(1)=-(x(2)*(d11(k)*x(3)+ddp*y(3)) + +y(2)*(ddp*x(3)+d22(k)*y(3))) gp(2)=-(x(3)*(d11(k)*x(1)+ddp*y(1)) + +y(3)*(ddp*x(1)+d22(k)*y(1))) gp(3)=-(x(1)*(d11(k)*x(2)+ddp*y(2)) + +y(1)*(ddp*x(2)+d22(k)*y(2))) c c evaluate bernoulli functions c do j=1,3 betax=bbx*tx(j)+bby*ty(j) betaxp=bbxp*tx(j)+bbyp*ty(j) call bexp(betax,betaxp,bep,bem,dbep,dbem) bp(j)=dbep*g(j)+bep*gp(j) bm(j)=dbem*g(j)+bem*gp(j) enddo c if(g(kmin).lt.0.0d0) then bp(kmin)=bp(kmin)*ratio bm(kmin)=bm(kmin)*ratio endif c c compute upwind diffusion matrix c c2=(bm(3)-bp(3)+bp(1)-bm(1))/3.0d0 c3=(bm(1)-bp(1)+bp(2)-bm(2))/3.0d0 c e22=bm(3)+bp(1)-(gp(3)+gp(1))-c2 e32=-bp(1)+gp(1)-c3 e23=-bm(1)+gp(1)-c2 e33=bm(1)+bp(2)-(gp(1)+gp(2))-c3 c e2=e22*tx(3)-e23*tx(2) e3=e32*tx(3)-e33*tx(2) a11(k)=a11(k)+tx(3)*e2-tx(2)*e3 a21(k)=a21(k)+ty(3)*e2-ty(2)*e3 c e2=e22*ty(3)-e23*ty(2) e3=e32*ty(3)-e33*ty(2) a12(k)=a12(k)+tx(3)*e2-tx(2)*e3 a22(k)=a22(k)+ty(3)*e2-ty(2)*e3 c c compute upwind convection term c if(g(kmin).lt.0.0d0) then e2=3.0d0*c2-(bx(k)*x(2)+by(k)*y(2)) e3=3.0d0*c3-(bx(k)*x(3)+by(k)*y(3)) c a10(k)=a10(k)+tx(3)*e2-tx(2)*e3 c a20(k)=a20(k)+ty(3)*e2-ty(2)*e3 endif 10 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bexp(beta,dbeta,bp,bm,dbp,dbm) c implicit double precision (a-h,o-z) implicit integer (i-n) c c careful bernoulli evaluation c if(beta.gt.10.0d0) then ez=dexp(-beta) ezp=-ez*dbeta bm=beta/(1.0d0-ez) dbm=(dbeta+bm*ezp)/(1.0d0-ez) bp=ez*bm dbp=ezp*bm+ez*dbm else if(beta.lt.-10.0d0) then ez=dexp(beta) ezp=ez*dbeta bp=beta/(ez-1.0d0) dbp=(dbeta-bp*ezp)/(ez-1.0d0) bm=ez*bp dbm=ezp*bp+ez*dbp else z=beta/2.0d0 zp=dbeta/2.0d0 ezp=dexp(z) ezpp=ezp*zp ezm=1.0d0/ezp ezmp=-ezm*zp if(dabs(z).le.1.0d-4) then zz=z**2 zzp=2.0d0*z*zp sz=1.0d0+zz/6.0d0*(1.0d0+zz/20.0d0) szp=zzp/6.0d0*(1.0d0+zz/10.0d0) else sz=(ezp-ezm)/beta szp=(ezpp-ezmp-sz*dbeta)/beta end if bp=ezm/sz dbp=(ezmp-bp*szp)/sz bm=ezp/sz dbm=(ezpp-bm*szp)/sz endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine elenbc(iedge,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,rl,a,h,g,sm,su,b,d,p,dl,iprob,isw,gnxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),index(3,3),ibedge(2,*) double precision + vx(*),vy(*),u(*),a(6,6),b(6),d(6),xm(*),ym(*), 1 c(2,3),wt(3),gv(6),gg(6),cc(3),um(*),uc(*),r(6), 2 h(6,6),p(12),dl(12),g(6,6),sm(6,6),su(6,6) external gnxy c save npts,wt,c,index,ifirst data index/1,2,3,2,3,1,3,1,2/ data ifirst/2/ c c c this routine computes the contribution to the element c from the natural boundary conditions. c c isw = 0 - piecewise linear basis functions c 1 - piecewise quadratic bump functions c 2 - piecewise quadratic functions c c gg( 1) = g c c gg( 2) = dg/du c gg( 3) = dg/drl c c gg( 4) = d2g/du du c gg( 5) = d2g/du drl c gg( 6) = d2g/drl drl c if(ifirst.gt.0) then npts=ifirst ifirst=0 call cquad1(npts,wt,c) endif pi=3.141592653589793d0 c c do basis function and gnxy evaluations c ktri=ibedge(1,iedge)/4 kside=ibedge(1,iedge)-4*ktri k1=index(2,kside) k2=index(3,kside) iv1=itnode(k1,ktri) iv2=itnode(k2,ktri) iv3=itnode(kside,ktri) icen=ibndry(3,iedge) itag=ibndry(6,iedge) c istart=1 if(isw.eq.1) istart=4 istop=6 if(isw.eq.0) istop=3 c do i=istart,istop b(i)=0.0d0 d(i)=0.0d0 p(i)=0.0d0 dl(i)=0.0d0 do j=istart,istop a(i,j)=0.0d0 h(i,j)=0.0d0 g(i,j)=0.0d0 sm(i,j)=0.0d0 su(i,j)=0.0d0 enddo enddo p(7)=0.0d0 p(8)=0.0d0 dl(7)=0.0d0 dl(8)=0.0d0 c if(icen.le.0) then hh=dsqrt((vx(iv1)-vx(iv2))**2+(vy(iv1)-vy(iv2))**2) else call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(icen),ym(icen),theta1,theta2,rad,hh) endif c do i=1,npts if(icen.le.0) then x=c(1,i)*vx(iv1)+c(2,i)*vx(iv2) y=c(1,i)*vy(iv1)+c(2,i)*vy(iv2) cc(k1)=c(1,i) cc(k2)=c(2,i) cc(kside)=0.0d0 else tt=(c(1,i)*theta1+c(2,i)*theta2)*pi x=xm(icen)+rad*dcos(tt) y=ym(icen)+rad*dsin(tt) call bari(x,y,vx,vy,itnode(1,ktri),cc) endif gv(k1)=cc(k1) gv(k2)=cc(k2) gv(kside)=cc(kside) gv(3+k1)=4.0d0*cc(k2)*cc(kside) gv(3+k2)=4.0d0*cc(k1)*cc(kside) gv(3+kside)=4.0d0*cc(k1)*cc(k2) uu=cc(k1)*u(iv1)+cc(k2)*u(iv2)+cc(kside)*u(iv3) do k=1,6 gg(k)=0.0d0 r(k)=0.0d0 enddo if(iprob.eq.5) then rr=cc(k1)*uc(iv1)+cc(k2)*uc(iv2)+cc(kside)*uc(iv3) else rr=rl endif call gnxy(x,y,uu,rr,itag,gg) we=wt(i)*hh if(iprob.eq.4.or.iprob.eq.5) then umu=cc(k1)*um(iv1)+cc(k2)*um(iv2)+cc(kside)*um(iv3) do k=1,6 r(k)=umu*gg(k) enddo endif p(7)=p(7)+r(3)*we dl(7)=dl(7)+r(6)*we dl(8)=dl(8)+r(1)*we do k=istart,istop q=we*gv(k) b(k)=b(k)-gg(1)*q d(k)=d(k)-gg(3)*q p(k)=p(k)-r(2)*q do j=istart,istop a(k,j)=a(k,j)-gg(2)*q*gv(j) enddo if(iprob.eq.5) then dl(k)=dl(k)-r(3)*q do j=istart,istop h(k,j)=h(k,j)-r(4)*q*gv(j) g(k,j)=g(k,j)-r(6)*q*gv(j) sm(k,j)=sm(k,j)-gg(3)*q*gv(j) su(k,j)=su(k,j)-r(5)*q*gv(j) enddo else if(iprob.eq.4.or.iprob.eq.2) then dl(k)=dl(k)-r(5)*q do j=istart,istop h(k,j)=h(k,j)-r(4)*q*gv(j) enddo endif enddo enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine elebdi(iedge,iside,itnode,ibndry,ibedge, + vx,vy,xm,ym,u,uc,rl,h,g,su,p,dl,iprob,isw,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),index(3,3),ibedge(2,*),map(5,5) double precision + vx(*),vy(*),u(*),p(12),c(2,3),wt(3),cp(15),r(5),uc(*), 1 gv(6),gx(6),gy(6),xm(*),ym(*),cc(3),h(6,6),dl(12), 2 g(6,6),su(6,6) external p2xy save npts,wt,c,index,ifirst,map data index/1,2,3,2,3,1,3,1,2/ data map/1,2,3,4,5,2,6,9,10,12,3,9,7,11,13, + 4,10,11,8,14,5,12,13,14,15/ data ifirst/2/ c c this routine computes element wise boundary integrals c c cp( 1) = p c c cp( 2) = dp/du c cp( 3) = dp/dux c cp( 4) = dp/duy c cp( 5) = dp/drl c c cp( 6) = d2p/du du c cp( 7) = d2p/dux dux c cp( 8) = d2p/duy duy c cp( 9) = d2p/du dux c cp(10) = d2p/du duy c cp(11) = d2p/dux duy c cp(12) = d2p/du drl c cp(13) = d2p/duy drl c cp(14) = d2p/duy drl c cp(15) = d2p/drl drl c if(ifirst.gt.0) then npts=ifirst ifirst=0 call cquad1(npts,wt,c) endif pi=3.141592653589793d0 c istart=1 istop=6 if(isw.eq.0) istop=3 if(isw.eq.1) istart=4 do k=1,8 p(k)=0.0d0 dl(k)=0.0d0 enddo do i=istart,istop do j=istart,istop h(i,j)=0.0d0 g(i,j)=0.0d0 su(i,j)=0.0d0 enddo enddo c if(ibedge(iside,iedge).le.0) return ktri=ibedge(iside,iedge)/4 kside=ibedge(iside,iedge)-4*ktri k1=index(2,kside) k2=index(3,kside) icen=ibndry(3,iedge) itag=ibndry(6,iedge) ktag=itnode(5,ktri) c c read vertex numbers c iv1=itnode(k1,ktri) iv2=itnode(k2,ktri) iv3=itnode(kside,ktri) c c compute matrix elements for affine transformation c x1=vy(iv2)-vy(iv3) x2=vy(iv3)-vy(iv1) x3=vy(iv1)-vy(iv2) y1=vx(iv3)-vx(iv2) y2=vx(iv1)-vx(iv3) y3=vx(iv2)-vx(iv1) det=x2*y3-x3*y2 hh=dsqrt(x3*x3+y3*y3) dx0=-x3/hh dy0=-y3/hh c x2=x2/det y2=y2/det x3=x3/det y3=y3/det x1=-(x2+x3) y1=-(y2+y3) c c compute gradient c u2=u(iv2)-u(iv1) u3=u(iv3)-u(iv1) ux=u2*x2+u3*x3 uy=u2*y2+u3*y3 c c j4=3+k1 j5=3+k2 j6=3+kside c if(icen.gt.0) then call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(icen),ym(icen),theta1,theta2,rad,hh) endif do i=1,npts c c evaluate linear basis functions c if(icen.gt.0) then tt=(c(1,i)*theta1+c(2,i)*theta2)*pi dx=dcos(tt) dy=dsin(tt) x=xm(icen)+rad*dx y=ym(icen)+rad*dy call bari(x,y,vx,vy,itnode(1,ktri),cc) if(dx*dx0+dy*dy0.lt.0.0d0) then dx=-dx dy=-dy endif else x=c(1,i)*vx(iv1)+c(2,i)*vx(iv2) y=c(1,i)*vy(iv1)+c(2,i)*vy(iv2) cc(k1)=c(1,i) cc(k2)=c(2,i) cc(kside)=0.0d0 dx=dx0 dy=dy0 endif gv(k1)=cc(k1) gv(k2)=cc(k2) gv(kside)=cc(kside) gx(k1)=x1 gy(k1)=y1 gx(k2)=x2 gy(k2)=y2 gx(kside)=x3 gy(kside)=y3 uu=cc(k1)*u(iv1)+cc(k2)*u(iv2)+cc(kside)*u(iv3) c c evaluate quadratic bump functions c if(isw.ne.0) then c1=4.0d0*cc(k1) c2=4.0d0*cc(k2) c3=4.0d0*cc(kside) gv(j4)=c2*cc(kside) gv(j5)=c1*cc(kside) gv(j6)=c1*cc(k2) gx(j4)=c2*x3+c3*x2 gy(j4)=c2*y3+c3*y2 gx(j5)=c1*x3+c3*x1 gy(j5)=c1*y3+c3*y1 gx(j6)=c2*x1+c1*x2 gy(j6)=c2*y1+c1*y2 endif c c function evaluations c we=wt(i)*hh do k=1,15 cp(k)=0.0d0 enddo if(iprob.eq.5) then rr=cc(k1)*uc(iv1)+cc(k2)*uc(iv2)+cc(kside)*uc(iv3) else rr=rl endif call p2xy(x,y,dx,dy,uu,ux,uy,rr,itag,ktag,cp) c p(7)=p(7)+cp(5)*we dl(7)=dl(7)+cp(15)*we p(8)=p(8)+cp(1)*we dl(8)=dl(8)+cp(1)*we c do k=istart,istop qx=we*gx(k) qy=we*gy(k) qv=we*gv(k) do j=1,5 r(j)=cp(map(2,j))*qv + +cp(map(3,j))*qx+cp(map(4,j))*qy enddo c p(k)=p(k)+r(1) if(iprob.eq.5) then dl(k)=dl(k)+cp(5)*qv do j=istart,istop h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j) g(k,j)=g(k,j)+cp(15)*qv*gv(j) su(k,j)=su(k,j)+r(5)*gv(j) enddo else if(iprob.eq.4.or.iprob.eq.2) then dl(k)=dl(k)+r(5) do j=istart,istop h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j) enddo endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cquad2(npts,wt,c) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + index(3,3) double precision + c(3,12),wt(12) save index data index/1,2,3,2,3,1,3,1,2/ c if(npts.eq.3) then ww=1.0d0/3.0d0 cc=2.0d0/3.0d0 ss=0.5d0-cc/2.0d0 do j=1,3 wt(j)=ww c(index(1,j),j)=ss c(index(2,j),j)=ss c(index(3,j),j)=cc enddo else if(npts.eq.1) then cc=1.0d0/3.0d0 wt(1)=1.0d0 c(1,1)=cc c(2,1)=cc c(3,1)=cc else if(npts.eq.6) then ww=0.109951743655322d0 cc=0.816847572980459d0 ss=0.5d0-cc/2.0d0 do j=1,3 wt(j)=ww c(index(1,j),j)=ss c(index(2,j),j)=ss c(index(3,j),j)=cc enddo ww=1.0d0/3.0d0-ww cc=0.108103018168070d0 ss=0.5d0-cc/2.0d0 do j=1,3 wt(j+3)=ww c(index(1,j),j+3)=ss c(index(2,j),j+3)=ss c(index(3,j),j+3)=cc enddo else if(npts.eq.12) then ww=0.050844906370207d0 cc=0.873821971016996d0 ss=0.5d0-cc/2.0d0 do j=1,3 wt(j)=ww c(index(1,j),j)=ss c(index(2,j),j)=ss c(index(3,j),j)=cc enddo ww=0.116786275726379d0 cc=0.501426509658179d0 ss=0.5d0-cc/2.0d0 do j=1,3 wt(j+3)=ww c(index(1,j),j+3)=ss c(index(2,j),j+3)=ss c(index(3,j),j+3)=cc enddo ww=0.082851075618374d0 cc=0.636502499121399d0 ss=0.310352451033785d0 tt=0.053145049844816d0 do j=1,3 wt(j+6)=ww c(index(1,j),j+6)=ss c(index(2,j),j+6)=tt c(index(3,j),j+6)=cc wt(j+9)=ww c(index(1,j),j+9)=ss c(index(2,j),j+9)=cc c(index(3,j),j+9)=tt enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eleufn(itri,itnode,vx,vy,u,ux,uy,rl,qv, + itype,isw,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),u(*),qv(6),ux(*),uy(*),values(15) external qxy save index data index/1,2,3,2,3,1,3,1,2/ c c isw = 0 - vertex values c 1 - midpoint values c 2 - vertex and midpoint values c itag=itnode(5,itri) if(isw.ne.1) then do j=1,3 i1=itnode(j,itri) xx=vx(i1) yy=vy(i1) uu=u(i1) uux=ux(i1) uuy=uy(i1) do m=1,5 values(m)=0.0d0 enddo call qxy(xx,yy,uu,uux,uuy,rl,itag,values) qv(j)=values(itype) enddo endif if(isw.ne.0) then do j=1,3 i2=itnode(index(2,j),itri) i3=itnode(index(3,j),itri) xx=(vx(i2)+vx(i3))/2.0d0 yy=(vy(i2)+vy(i3))/2.0d0 uu=(u(i2)+u(i3))/2.0d0 uux=(ux(i2)+ux(i3))/2.0d0 uuy=(uy(i2)+uy(i3))/2.0d0 do m=1,5 values(m)=0.0d0 enddo call qxy(xx,yy,uu,uux,uuy,rl,itag,values) qv(j+3)=values(itype) enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cquad1(npts,wt,c) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + c(2,3),wt(3) c if(npts.eq.2) then wt(1)=1.0d0/2.0d0 ss=1.0d0/(2.0d0*dsqrt(3.0d0)) c(1,1)=0.5d0+ss c(2,1)=0.5d0-ss wt(2)=wt(1) c(1,2)=c(2,1) c(2,2)=c(1,1) else if(npts.eq.1) then wt(1)=1.0d0 c(1,1)=0.5d0 c(2,1)=0.5d0 else if(npts.eq.3) then wt(1)=5.0d0/18.0d0 ss=dsqrt(3.0d0/5.0d0)/2.0d0 c(1,1)=0.5d0-ss c(2,1)=0.5d0+ss wt(2)=wt(1) c(1,2)=c(2,1) c(2,2)=c(1,1) wt(3)=4.0d0/9.0d0 c(1,3)=0.5d0 c(2,3)=0.5d0 endif return end c***************************** file: mg2.f ***************************** c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine trigen(vx,vy,xm,ym,itnode,ibndry,ja,a,ip,rp,sp, + iu,ru,su,w,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),iu(100),ja(*) double precision + vx(*),vy(*),xm(*),ym(*),w(*),rp(100),ru(100),a(*) character*80 + sp(100),su(100) external qxy c c user specified ip variables c if(ip(6).lt.-5.or.ip(6).gt.5) ip(6)=1 if(ip(7).lt.0.or.ip(7).gt.ip(2)) ip(7)=0 if(ip(8).ne.1) ip(8)=0 if(ip(26).lt.-13.or.ip(26).gt.13) ip(26)=0 iadapt=iabs(ip(26)) nvtrgt=max0(0,ip(28)) ip(28)=nvtrgt ip(25)=0 c if(iadapt.eq.5) then if(itnode(3,1).ne.0) then ip(25)=25 go to 60 endif else if(iadapt.ne.7) then if(itnode(3,1).eq.0) then ip(25)=25 go to 60 endif endif c c storage allocation c if(ip(5).ne.0) then call stor(ip) if(ip(25).ne.0) go to 60 endif c c array pointers...in the order that they c occur in the w array c iuu=ip(83) iux=ip(84) iuy=ip(85) iu0=ip(86) iudot=ip(87) iu0dot=ip(88) iudl=ip(89) ievr=ip(90) ievl=ip(91) jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) c ivx0=iudot ivy0=iu0dot c lenw=ip(20) maxt=ip(21) maxv=ip(22) maxb=ip(24) mpisw=ip(48) nproc=ip(49) irgn=ip(50) maxpth=ip(81) if(ip(5).ne.0) then call timer(w(jtime),-2) call hist2(w(jhist),rp,0,0) call updpth(w(jpath),1,1,rp) call pstat1(ip(1),nproc,w(jstat),itnode,w(iee),0) rp(21)=rp(1) rp(31)=rp(1) rp(33)=1.0d0 if(ip(6).eq.3.and.ip(9).lt.3) ip(9)=3 ip(70)=0 else call timer(w(jtime),-1) endif c ibegin=iz iend=lenw c c generate triangulation c if(iadapt.eq.5) then c c check data c call dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) if(ip(25).ne.0) return c c pointers c ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ipoly,3*maxv,'head',ibegin,iend,iflag) call memptr(itedge,3*maxt,'head',ibegin,iend,iflag) call memptr(jbb,2*maxb+ntf+1,'head',ibegin,iend,iflag) call memptr(ihloc,maxv,'head',ibegin,iend,iflag) call memptr(jrgn,5*ntf,'head',ibegin,iend,iflag) call memptr(itptr,ntf+1,'head',ibegin,iend,iflag) call memptr(ivptr,ntf+1,'head',ibegin,iend,iflag) call memptr(irptr,maxt,'head',ibegin,iend,iflag) llist=3*maxt+maxb+maxv call memptr(list,llist,'head',ibegin,iend,iflag) call memptr(jvx0,maxv,'head',ibegin,iend,iflag) call memptr(jvy0,maxv,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 60 endif c c call tgen c call timer(w(jtime),16) call tgen(ip,rp,vx,vy,xm,ym,itnode,ibndry,w(jbb), + w(ihloc),w(ipoly),w(itedge),w(jrgn),w(itptr), 1 w(ivptr),w(irptr),w(list),llist,w(jvx0),w(jvy0)) call timer(w(jtime),1) call memptr(isv,0,'free',ibegin,iend,iflag) c endif c c ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) lenb=ip(76)*3 c c initialize triangluation c compute user specified triangulations c isw=0 if(ip(5).ne.0.or.iadapt.eq.5) isw=1 if(iadapt.eq.7.and.irgn.ne.1) isw=0 if(isw.eq.1) then call dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) if(ip(25).ne.0) return call gfinit(ip,maxv,w(iuu),w(iee)) ip(5)=0 endif c c compute error estimates c isw=0 if(iadapt.le.4) isw=1 if(iadapt.eq.7.and.irgn.eq.1) isw=1 if(isw.eq.1) then if(mpisw.eq.1.and.iadapt.gt.0.and.iadapt.le.4) then call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibb,nvf,'head',ibegin,iend,iflag) call memptr(mark,nvf,'head',ibegin,iend,iflag) call memptr(iequv,nvf,'head',ibegin,iend,iflag) call memptr(img,15*nvf,'head',ibegin,iend,iflag) call exflag(iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call cdlfn(ip,itnode,ibndry,vx,vy,w(iuu),w(iux), + w(iuy),w(ibb),w(iudl),ja,a,w(ka), 1 w(mark),w(iequv),w(img),w(jhist)) call timer(w(jtime),7) call memptr(isv,0,'free',ibegin,iend,iflag) endif call memptr(ibump,maxt*lenb,'head',ibegin,iend,iflag) call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ipp,nvf,'head',ibegin,iend,iflag) call memptr(idist,nvf,'head',ibegin,iend,iflag) call memptr(iequv,nvf,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call errest(ip,rp,itnode,ibndry,vx,vy,w(iuu),w(iee), + w(ibump),w(iux),w(iuy),w(iudl),ja,a,w(ipp), 1 w(idist),w(iequv),w(jhist),w(jstat),qxy) call timer(w(jtime),6) call memptr(isv,0,'free',ibegin,iend,iflag) c c compute itedge, ibedge c if(iadapt.eq.0) go to 50 call memptr(ibedge,2*maxb,'head',ibegin,iend,iflag) call memptr(itedge,3*maxt,'head',ibegin,iend,iflag) call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(list,nvf+nbf+3*ntf,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call cedge1(nvf,ntf,nbf,itnode,ibndry,w(itedge), + w(ibedge),vx,vy,w(list),jflag) call memptr(isv,0,'free',ibegin,iend,iflag) endif c c refine or unrefine c if(iadapt.eq.1) then call memptr(ivtype,maxv,'head',ibegin,iend,iflag) call memptr(iseed,maxt,'head',ibegin,iend,iflag) if(nvtrgt.ge.nvf) then call memptr(ipp,maxt,'head',ibegin,iend,iflag) call memptr(iqq,maxt,'head',ibegin,iend,iflag) call memptr(ilist,maxt,'head',ibegin,iend,iflag) call memptr(jlist,maxt,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call refine(ip,rp,itnode,ibndry,vx,vy,xm,ym,w(iuu), + w(iee),w(ibump),w(iseed),w(itedge),w(ibedge), 1 w(ivtype),w(ipp),w(iqq),w(ilist),w(jlist)) call timer(w(jtime),2) else call memptr(ipp,maxv,'head',ibegin,iend,iflag) call memptr(iqq,maxv,'head',ibegin,iend,iflag) call memptr(iqual,maxv,'head',ibegin,iend,iflag) call memptr(iequv,maxv,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call unrefn(ip,rp,itnode,ibndry,vx,vy,xm,ym,w(iuu), + w(iee),w(ibump),w(itedge),w(ibedge),w(ivtype), 1 w(ipp),w(iqq),w(iqual),w(iseed),w(iequv)) call timer(w(jtime),3) endif c c unrefine and refine c else if(iadapt.eq.2) then if(nvtrgt.ge.nvf) go to 60 call memptr(ivtype,maxv,'head',ibegin,iend,iflag) call memptr(iseed,maxt,'head',ibegin,iend,iflag) ll=max0(maxv,maxt) call memptr(ipp,ll,'head',ibegin,iend,iflag) call memptr(iqq,ll,'head',ibegin,iend,iflag) call memptr(ilist,ll,'head',ibegin,iend,iflag) call memptr(jlist,ll,'head',ibegin,iend,iflag) iqual=ilist iequv=jlist if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call unrefn(ip,rp,itnode,ibndry,vx,vy,xm,ym,w(iuu), + w(iee),w(ibump),w(itedge),w(ibedge),w(ivtype), 1 w(ipp),w(iqq),w(iqual),w(iseed),w(iequv)) ip(28)=nvf call timer(w(jtime),3) call refine(ip,rp,itnode,ibndry,vx,vy,xm,ym,w(iuu), + w(iee),w(ibump),w(iseed),w(itedge),w(ibedge), 1 w(ivtype),w(ipp),w(iqq),w(ilist),w(jlist)) ip(28)=nvtrgt call timer(w(jtime),2) c c mesh smoothing c else if(iadapt.eq.3) then call memptr(ivtype,maxv,'head',ibegin,iend,iflag) call memptr(iseed,maxv,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call mvemsh(ip,itnode,ibndry,vx,vy,xm,ym,w(ibump), + w(iee),w(itedge),w(ibedge),w(ivtype),w(iseed)) call timer(w(jtime),5) c c uniform refinement c else if(iadapt.eq.4) then irefn=max0(1,ip(27)) ip(27)=irefn call memptr(ija,4*maxv,'head',ibegin,iend,iflag) call memptr(mark,maxt,'head',ibegin,iend,iflag) call memptr(ilist,3*irefn**2,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call unifrm(ip,itnode,ibndry,vx,vy,xm,ym,w(iuu),w(iee), + w(ibump),w(ija),w(ibedge),w(mark),w(ilist)) call timer(w(jtime),4) c c create skeleton c else if(iadapt.eq.6) then lvz=max0(maxv,maxb) call memptr(ivz,lvz,'head',ibegin,iend,iflag) call memptr(ibc,lvz,'head',ibegin,iend,iflag) call memptr(iequv,maxv,'head',ibegin,iend,iflag) call memptr(iarea,maxt,'head',ibegin,iend,iflag) call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) l1=max0(3*ntf,5*maxb) call memptr(itedge,l1,'head',ibegin,iend,iflag) call memptr(itag,maxt,'head',ibegin,iend,iflag) lenjv=9*maxv call memptr(jv,lenjv,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 60 endif c call rinit(ip,rp,itnode,ibndry,vx,vy,w(ivz),xm,ym,w(iuu), + w(iux),w(iuy),w(iarea),w(itedge),w(ibedge),w(iequv), 1 w(jv),qxy) if(ip(25).ne.0) go to 50 c call timer(w(jtime),17) call rgen(ip,vx,vy,xm,ym,itnode,ibndry,w(itedge),w(ibc), + w(iequv),w(ivz),w(jv),w(iarea),lenjv,rp,w(itag)) call timer(w(jtime),8) call dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) c c load balance c else if(iadapt.eq.7) then if(mpisw.ne.1) then ip(25)=48 go to 50 endif if(irgn.eq.1) then call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(jl,nproc+1,'head',ibegin,iend,iflag) call memptr(ipp,ntf,'head',ibegin,iend,iflag) call memptr(iqq,ntf,'head',ibegin,iend,iflag) ljz=max0(19*ntf,8*nproc-4) call memptr(jz,ljz,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 20 endif call timer(w(jtime),17) call ldbal(ip,itnode,w(itedge),w(ibedge),ibndry,vx,vy, + w(iee),w(ipp),w(iqq),ja,a,w(ka),w(jl),w(jz), 1 w(jhist),w(jtime),w(jstat)) call timer(w(jtime),9) call memptr(isv,0,'free',ibegin,iend,iflag) endif 20 call exflag(ip(25)) if(ip(25).ne.0) go to 50 c c broadcast c call timer(w(jtime),17) call bcast(vx,vy,xm,ym,ibndry,itnode,ip,rp,sp,iu,ru,su,w) jtime=ip(92) call timer(w(jtime),14) c c make mesh conforming c else if(iadapt.eq.8) then if(mpisw.ne.1) then ip(25)=48 go to 50 endif do iter=1,2 c c cut c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibedge,2*maxb,'head',ibegin,iend,iflag) call memptr(itedge,3*maxt,'head',ibegin,iend,iflag) lpp=max0(maxt,maxb) call memptr(ipp,lpp,'head',ibegin,iend,iflag) lqq=max0(maxt,maxb) call memptr(iqq,lqq,'head',ibegin,iend,iflag) call memptr(ibef,maxv,'head',ibegin,iend,iflag) lrr=max0(maxv,2*maxv+maxb-lqq) call memptr(iaft,lrr,'head',ibegin,iend,iflag) call exflag(iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call cutr(ip,itnode,ibndry,vx,vy,w(iee),w(ipp),w(iqq), + w(ibef),w(iaft),w(itedge),w(ibedge),maxv,w,1) call timer(w(jtime),11) if(ip(25).ne.0) go to 50 call mkpth(ip,irgn,w(ipath),ibndry,w(itedge),w(ibedge)) if(ip(25).ne.0) go to 50 call memptr(isv,0,'free',ibegin,iend,iflag) c c exchange ipath data c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ipath0,4*maxpth,'head',ibegin,iend,iflag) call memptr(ic,nproc,'head',ibegin,iend,iflag) call memptr(jc,nproc,'head',ibegin,iend,iflag) call exflag(iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call expth(ip,w(ipath),w(ipath0),w(ic),w(jc)) call timer(w(jtime),16) call memptr(isv,0,'free',ibegin,iend,iflag) if(ip(25).ne.0) go to 50 c c paste c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibedge,2*maxb,'head',ibegin,iend,iflag) call memptr(itedge,3*maxt,'head',ibegin,iend,iflag) llist=max0(maxv+maxb+3*maxt,4*maxpth) call memptr(list,llist,'head',ibegin,iend,iflag) call memptr(ivtype,maxv,'head',ibegin,iend,iflag) call memptr(iequv,maxv,'head',ibegin,iend,iflag) call exflag(iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif if(iter.eq.2) then call timer(w(jtime),17) call paste1(ip,itnode,ibndry,vx,vy,xm,ym,w(iuu), + w(itedge),w(ibedge),w(ivtype),w(list), 1 w(iequv),w(ipath)) call timer(w(jtime),13) else call timer(w(jtime),17) call paste(ip,itnode,w(itedge),ibndry,w(ibedge), + w(ipath),vx,vy,xm,ym,maxv,w,w(list),1) call timer(w(jtime),12) endif call memptr(isv,0,'free',ibegin,iend,iflag) if(ip(25).ne.0) go to 50 enddo c c cut and paste c else if(iadapt.eq.9) then if(mpisw.ne.1) then ip(25)=48 go to 50 endif irgn=ip(50) call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) call memptr(itedge,3*ntf,'head',ibegin,iend,iflag) lpp=max0(ntf,maxb) call memptr(ipp,lpp,'head',ibegin,iend,iflag) lqq=max0(ntf,maxb) call memptr(iqq,lqq,'head',ibegin,iend,iflag) call memptr(ibef,nvf,'head',ibegin,iend,iflag) lrr=max0(nvf,2*ntf+nbf-lqq) call memptr(iaft,lrr,'head',ibegin,iend,iflag) call exflag(iflag) if(iflag.ne.0) then ip(25)=20 go to 50 endif call timer(w(jtime),17) call cutr(ip,itnode,ibndry,vx,vy,w(iee),w(ipp),w(iqq), + w(ibef),w(iaft),w(itedge),w(ibedge),maxv,w(iuu),0) call timer(w(jtime),11) call memptr(isv,0,'free',ibegin,iend,iflag) if(ip(25).ne.0) go to 50 c c master process collects the global fine mesh c call timer(w(jtime),17) call collct(vx,vy,ibndry,itnode,ip,sp,w,w(iz)) call timer(w(jtime),15) if(ip(25).ne.0) go to 50 c c paste c if(irgn.eq.1) then call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibedge,2*maxb,'head',ibegin,iend,iflag) call memptr(itedge,3*maxt,'head',ibegin,iend,iflag) llist=max0(maxv+maxb+3*maxt,4*maxpth) call memptr(list,llist,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=20 go to 60 endif call timer(w(jtime),17) call paste(ip,itnode,w(itedge),ibndry,w(ibedge), + w(ipath),vx,vy,xm,ym,maxv,w,w(list),0) call timer(w(jtime),12) call memptr(isv,0,'mark',ibegin,iend,iflag) if(ip(25).ne.0) go to 50 endif endif c c smooth solution c c if(iadapt.ge.1.and.iadapt.le.4) then c ibegin=iz c iend=lenw c ntf=ip(1) c nvf=ip(2) c nbf=ip(4) c call memptr(iequv,nvf,'head',ibegin,iend,iflag) c call memptr(ibb,nvf,'head',ibegin,iend,iflag) c call memptr(izz,3*nvf,'head',ibegin,iend,iflag) c c call smthu(nvf,ntf,nbf,w(iuu),vx,vy,itnode,ibndry, c + ja,a,w(iequv),w(ibb),w(izz)) c endif 50 call timer(w(jtime),17) c 60 iflag=ip(25) c c messages c if(iflag.eq.0) then if(ip(26).eq.9) then write(unit=sp(11),fmt='(a19,i2,2(a6,i7),a6,i6,a1)') + 'trigen: ok (iadapt=',ip(26),', ntg=',ip(38), 1 ', nvg=',ip(39),', nbg=',ip(40),')' else write(unit=sp(11),fmt='(a19,i2,2(a6,i6),a6,i5,a6,i3,a1)') + 'trigen: ok (iadapt=',ip(26),', ntf=',ip(1), 1 ', nvf=',ip(2),', nbf=',ip(4),', ncf=',ip(3),')' endif else if(iflag.ge.18.and.iflag.le.24) then sp(11)='trigen: insufficient storage' else if(iflag.eq.25) then sp(11)='trigen: wrong input data structure' else if(iflag.eq.48) then sp(11)='trigen: mpi is off' else if(iflag.eq.49) then sp(11)='trigen: nproc > ntf in ldbal' else if(iflag.eq.72) then sp(11)='trigen: interface array error' ip(72)=0 else if(iflag.eq.97) then sp(11)='trigen: unmatched interface edges in ipath' else sp(11)='trigen: unknown error' endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine errest(ip,rp,itnode,ibndry,vx,vy,u,e,bump, + ux,uy,udl,jc,link,order,idist,iequv,hist,pstat,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),jc(*),idist(*), 1 link(*),order(*),iequv(*) double precision + u(*),vx(*),vy(*),bump(*),rp(100),e(*),hist(22,*), 1 ux(*),uy(*),pstat(10,*),udl(*) external qxy c c check to see if we have solved problem on current finest grid c ntf=ip(1) nvf=ip(2) nbf=ip(4) iadapt=ip(26) nvtrgt=ip(28) mpisw=ip(48) nproc=ip(49) irgn=ip(50) ibase=ip(70) lenb=ip(76)*3 iprob=ip(6) c c initial error estimates c if(iadapt.ge.0) then call cd2u(ip,rp,u,ux,uy,vx,vy,itnode,lenb,bump,e) else call usrfn(ntf,itnode,iprob,vx,vy,u,ux,uy,e,rp, + lenb,bump,qxy) endif ii=iabs(iadapt) if(ii.eq.1.and.nvtrgt.lt.nvf) then call hist2(hist,rp,-1,nvf) else call hist2(hist,rp,ii,nvf) endif call pstat1(ntf,nproc,pstat,itnode,e,2) if(mpisw.eq.1.and.ii.le.4) then call cequv1(nvf,nbf,ibndry,iequv,0) maxlnk=4*nvf call setgr1(ntf,nvf,itnode,link,jc,iequv,maxlnk,jflag) call ja2jc(nvf,link,jc) call cdlwts(nvf,ntf,nbf,jc,order,idist,irgn,itnode, + ibndry,ibase,lenb,bump,udl) c** do i=1,ntf c** if(itnode(4,i).ne.irgn) then c** k=(i-1)*lenb c** do j=1,lenb c** bump(j+k)=bump(j+k)*1.0e-6 c** enddo c** endif c** enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine refine(ip,rp,itnode,ibndry,vx,vy,xm,ym,gf, + e,bump,iseed,itedge,ibedge,vtype,p,q,rlist,slist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*),p(*),q(*), 1 itedge(3,*),vtype(*),rlist(*),slist(*),ibedge(2,*) double precision + gf(*),rp(100),e(*),xm(*),ym(*),vx(*),vy(*),bump(*) data ibit/0/ c c check to see if we have solved problem on current finest grid c maxt=ip(21) maxv=ip(22) maxb=ip(24) lenb=ip(76)*3 ngf=ip(77) ntf=ip(1) nvf=ip(2) nbf=ip(4) ibase=ip(70) idbcpt=ip(7) nvtrgt=min0(ip(28),4*nvf+20) if(nvf.ge.nvtrgt) return diam=rp(78) eps=ceps(ibit) hmin=eps*diam iflag=0 c c c do i=1,ntf rlist(i)=0 slist(i)=0 iseed(i)=0 p(i)=i q(i)=i enddo nn=ntf*lenb uu=rl2nrm(nn,bump) if(uu.gt.0.0d0) then coeff=uu*eps/dsqrt(dfloat(nn)) else coeff=1.0d0/(diam**2) endif do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) enddo c c initialize heap c nn=ntf/2 do k=nn,1,-1 call updhp(k,ntf,p,q,e,0) enddo c c add interfaces to itedge data structure c call cedge5(nbf,itedge,ibedge,1) c nn=nvf+1 do ii=nn,nvtrgt if(nvf.ge.nvtrgt) go to 60 itri=p(1) if(e(itri).le.0.0d0) go to 60 call mklist(itri,itnode,itedge,vx,vy, + iseed,num,next,rlist,ibedge,ibndry) if(num+nvf.gt.nvtrgt) then if(nvtrgt-nvf.le.num+nvf-nvtrgt) go to 60 endif c c now create new elements c inext=itri slist(itri)=-1 40 if(iseed(next).gt.0) then call adknot(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,xm,ym,lenb,bump,e,maxv,maxt,maxb,iseed,gf,ngf, 1 p,q,slist,inext,rlist,next,hmin,coeff,ibase,iflag) if(iflag.ne.0) go to 60 go to 40 else itemp=next next=rlist(next) rlist(itemp)=0 if(next.gt.0) go to 40 endif c c swap edges c call eswapb(itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,ntf,inext,slist,p,q,e,hmin,coeff) enddo c c degree edge swapping, geometry improvement c 60 call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,1) call cedge5(nbf,itedge,ibedge,0) c c angmin=1.0d-3 arcmax=0.26d0 call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) itmax=2 call mfe2(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge) c c update e c hmin=0.0d0 coeff=0.0d0 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) enddo c ip(25)=iflag ip(1)=ntf ip(2)=nvf ip(4)=nbf c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mvemsh(ip,itnode,ibndry,vx,vy,xm,ym, + bump,e,itedge,ibedge,vtype,iseed) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),itedge(3,*),vtype(*), 1 iseed(*),ibedge(2,*) double precision + vx(*),vy(*),bump(*),xm(*),ym(*),e(*) c c move mesh c ntf=ip(1) nvf=ip(2) nbf=ip(4) idbcpt=ip(7) lenb=ip(76)*3 c c compute triangle tree data structures c angmin=1.0d-3 arcmax=0.26d0 c c initailize iseed, vtype c call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c c move knots according to error c itmax=4 call mfe1(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge,lenb,bump) c c move knots according to geometry c itmax=2 call mfe2(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge) c c update e c hmin=0.0d0 coeff=0.0d0 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine unrefn(ip,rp,itnode,ibndry,vx,vy,xm,ym,gf, + e,bump,itedge,ibedge,vtype,p,q,qual,iseed,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*),p(*),q(*), 1 itedge(3,*),vtype(*),iequv(*),ibedge(2,*),corner(9), 2 elist(500),tlist(500),vlist(500),blist(500),vsv(500) double precision + gf(*),rp(100),e(*),xm(*),ym(*),vx(*),vy(*), 1 bump(*),qual(*) save corner data corner/0,0,1,0,1,0,1,0,1/ data ibit/0/ c c check to see if we have solved problem on current finest grid c ntf=ip(1) nvf=ip(2) nbf=ip(4) nvtrgt=max0(ip(28),nvf/2) idbcpt=ip(7) maxv=ip(22) lenb=ip(76)*3 nproc=ip(49) irgn=ip(50) ibase=ip(70) ngf=ip(77) if(rp(15).le.0.0d0.or.rp(15).gt.1.0d0) rp(15)=1.0d0 diam=rp(78) hmax=diam*rp(15) eps=ceps(ibit) c if(nvf.le.nvtrgt) go to 60 c angmin=1.0d-3 arcmax=0.26d0 hmin=0.0d0 c c initialize iseed, vtype c call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) call cequv1(nvf,nbf,ibndry,iequv,0) c nn=ntf*lenb uu=rl2nrm(nn,bump) if(uu.gt.0.0d0) then coeff=uu*eps/dsqrt(dfloat(nn)) else coeff=1.0d0/(diam**2) endif emax=0.0d0 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) emax=dmax1(emax,e(i)) enddo c c initialize qual, p,q c call cedge5(nbf,itedge,ibedge,1) do i=1,nvf p(i)=i q(i)=i call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) if(vtype(i).eq.5) then call tstvt5(i,itnode,ibndry,itedge, + vtype,ibase,irgn,tlist,elist,len) endif qual(i)=vqual(i,emax,vlist,tlist,elist,len, + e,vtype,vx,vy,hmax) enddo c c initialize heap c nn=nvf/2 do k=nn,1,-1 call updhp(k,nvf,p,q,qual,0) enddo last=nvf c c main elimination loop c do nn=nvf,1,-1 if(last.le.nvtrgt) go to 60 i=p(1) if(qual(i).le.-emax) go to 60 p(1)=p(last) p(last)=i q(p(last))=last q(p(1))=1 last=last-1 call updhp(1,last,p,q,qual,0) c c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) lvsv=0 do j=2,len+1 if(corner(vtype(vlist(j))).ne.1) then lvsv=lvsv+1 vsv(lvsv)=vlist(j) if(iequv(vlist(j)).ne.vlist(j)) then lvsv=lvsv+1 vsv(lvsv)=iequv(vlist(j)) endif endif enddo if(vtype(i).eq.8) then ii=vlist(len+2) kk=q(ii) p(kk)=p(last) p(last)=ii q(p(last))=last q(p(kk))=kk last=last-1 call updhp(kk,last,p,q,qual,1) len1=elist(len+2) do j=len+3,len1+1 if(corner(vtype(vlist(j))).ne.1) then lvsv=lvsv+1 vsv(lvsv)=vlist(j) if(iequv(vlist(j)).ne.vlist(j)) then lvsv=lvsv+1 vsv(lvsv)=iequv(vlist(j)) endif endif enddo endif c c reduce to degree 3 or 4 by edge swapping c call reduc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,hmin,coeff,1,iflag) c c if(corner(vtype(i)).eq.1) stop 6235 if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist,len, 1 hmin,coeff,ibase,1) if(vtype(i).eq.8) then len1=elist(len+2)-(len+1) call dlknot(ii,itnode,itedge,ibndry,ibedge, + vx,vy,lenb,bump,e,iseed,vtype,vlist(len+2), 1 tlist(len+2),elist(len+2),len1,hmin,coeff, 2 ibase,1) endif else if(vtype(i).eq.8) then last=last+1 qual(ii)=-emax endif last=last+1 qual(i)=-emax endif c c update vertices in connected to i c do jj=1,lvsv j=vsv(jj) qual(j)=-emax call cirlst(j,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) if(vtype(j).ne.1) then call tstvty(j,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) endif if(vtype(i).eq.5) then call tstvt5(i,itnode,ibndry,itedge, + vtype,ibase,irgn,tlist,elist,len) endif qual(j)=vqual(j,emax,vlist,tlist,elist,len, + e,vtype,vx,vy,hmax) kk=q(j) call updhp(kk,last,p,q,qual,1) enddo enddo 60 call clnup(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,iseed,gf,maxv,ngf,idbcpt) c c improve geometry c call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,1) call cedge5(nbf,itedge,ibedge,0) c c call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) itmax=2 call mfe2(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge) c c update e c hmin=0.0d0 coeff=0.0d0 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) enddo c ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(7)=idbcpt c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine unifrm(ip,itnode,ibndry,vx,vy,xm,ym,gf, + e,bump,ja,ibedge,mark,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ja(*), 1 mark(*),list(6,*),ibedge(2,*) double precision + gf(*),bump(*),e(*),xm(*),ym(*),vx(*),vy(*) c c this routine does uniform refinement c irefn=ip(27) if(irefn.le.1) return maxt=ip(21) maxv=ip(22) maxb=ip(24) ntf=ip(1) nvf=ip(2) nbf=ip(4) ngf=ip(77) lenb=ip(76)*3 nhole=(2*nvf-ntf-nbf-2)/2 ntnew=ntf*irefn**2 if(ntnew.gt.maxt) then ip(25)=21 return endif nbnew=nbf*irefn if(nbnew.gt.maxb) then ip(25)=24 return endif nvnew=(ntnew+nbnew+2-2*nhole)/2 if(nvnew.gt.maxv) then ip(25)=22 return endif ip(25)=0 c c comput ja c lenja=nvf+1+(3*ntf+nbf)/2 call setgr(ntf,nvf,nbf,itnode,ibndry,ja,lenja) c c mark triangles with curved edges c do i=1,ntf mark(i)=0 enddo do i=1,nbf if(ibndry(3,i).gt.0) then it=ibedge(1,i)/4 mark(it)=i if(ibedge(2,i).gt.0) then it=ibedge(2,i)/4 mark(it)=i endif endif enddo c nv0=nvf call adedge(nvf,nbf,irefn,ja,itnode,ibndry,ibedge, + vx,vy,gf,maxv,ngf,xm,ym) c call adtri(nv0,nvf,ntf,irefn,ja,itnode,ibndry,mark, + vx,vy,gf,maxv,ngf,lenb,bump,e,list) c ip(1)=ntf ip(2)=nvf ip(4)=nbf c ip(25)=0 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine smthu(nvf,ntf,nbf,u,vx,vy,itnode,ibndry,ja,a, + iequv,b,z) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),iequv(*),ja(*) double precision + vx(*),vy(*),u(*),a(*),z(*),b(*) c if(nvf.le.100) return call cequv1(nvf,nbf,ibndry,iequv,1) mxsmth=2 if(nvf.le.1000) mxsmth=1 eps=1.0d-6 c i1=1 i2=i1+nvf i3=i2+nvf c c compute mass matrix c maxlnk=4*nvf call setgr1(ntf,nvf,itnode,ja,a,iequv,maxlnk,jflag) c c smoothing c call h10mtx(nvf,ntf,vx,vy,itnode,ja,a,iequv) do i=1,nvf b(i)=0.0d0 enddo call jcg(nvf,ja,a,u,b,mxsmth,z(i1),z(i2),z(i3),eps) c do i=1,nvf u(i)=u(iequv(i)) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine adknot(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,xm,ym,lenb,bump,e,maxv,maxt,maxb,mark,gf,ngf, 1 p,q,slist,inext,rlist,next,hmin,coeff,ibase,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),index(3,3), 1 imark(3,7),jmark(3,7),mark(*),ied(7),p(*),q(*), 2 slist(*),rlist(*),ibedge(2,*) double precision + vx(*),vy(*),xm(*),ym(*),bump(lenb,*),gf(maxv,*), 1 c(3),e(*) save index,imark,jmark,ied data index/1,2,3,2,3,1,3,1,2/ data imark/0,0,0,0,0,0,0,0,0,0,1,0,3,0,0,0,0,2,3,1,2/ data jmark/0,0,0,0,0,0,0,0,0,2,0,0,0,0,1,0,3,0,2,3,1/ data ied/1,2,3,1,1,2,1/ c c check storage c itri=next iedge=ied(mark(itri)) if(nvf+1.gt.maxv) then iflag=22 return endif kedge=itedge(iedge,itri) if(kedge.gt.0) then jtri=kedge/4 jedge=kedge-4*jtri ibdy=0 else ibdy=-kedge if(ibndry(4,ibdy).eq.0) then if(ibedge(2,ibdy)/4.eq.itri) then ibedge(2,ibdy)=ibedge(1,ibdy) ibedge(1,ibdy)=4*itri+iedge endif jtri=ibedge(2,ibdy)/4 jedge=ibedge(2,ibdy)-4*jtri else jtri=0 jedge=0 endif endif if(jtri.gt.0) then if(ntf+2.gt.maxt) then iflag=21 return endif else if(ntf+1.gt.maxt) then iflag=21 return endif endif if(ibdy.gt.0) then if(nbf+1.gt.maxb) then iflag=24 return endif endif iflag=0 c c create new vertex c nvf=nvf+1 k2=itnode(index(2,iedge),itri) k3=itnode(index(3,iedge),itri) c vx(nvf)=(vx(k2)+vx(k3))/2.0d0 vy(nvf)=(vy(k2)+vy(k3))/2.0d0 do k=1,ngf gf(nvf,k)=(gf(k2,k)+gf(k3,k))/2.0d0 enddo c c refine ibdy c if(ibdy.gt.0) then nbf=nbf+1 c c check curved boundary edge c kc=ibndry(3,ibdy) if(kc.gt.0) then call midpt(vx(k2),vy(k2),vx(k3),vy(k3), + xm(kc),ym(kc),vx(nvf),vy(nvf)) call bari(vx(nvf),vy(nvf),vx,vy,itnode(1,itri),c) m1=itnode(1,itri) m2=itnode(2,itri) m3=itnode(3,itri) do k=1,ngf gf(nvf,k)=c(1)*gf(m1,k)+c(2)*gf(m2,k)+c(3)*gf(m3,k) enddo endif c c fixup ibndry c do k=1,6 ibndry(k,nbf)=ibndry(k,ibdy) enddo ibndry(1,ibdy)=k2 ibndry(2,ibdy)=nvf ibndry(1,nbf)=nvf ibndry(2,nbf)=k3 ibedge(1,nbf)=iedge+4*(ntf+1) if(jtri.gt.0) then ibedge(2,nbf)=jedge+4*(ntf+2) else ibedge(2,nbf)=0 endif c c fixup ibndry for periodic edges c if(ibndry(4,ibdy).lt.0) then jbdy=-ibndry(4,ibdy) kbdy=-ibndry(4,jbdy) if(kbdy.eq.ibdy) then ibndry(4,ibdy)=-nbf else ibndry(4,kbdy)=-ibdy ibndry(4,ibdy)=-kbdy ibndry(4,jbdy)=-nbf ibndry(4,nbf)=-jbdy endif endif c c fixup ibndry for interface edges c if(ibndry(5,ibdy).ne.0) then it=iabs(ibndry(5,ibdy))/ibase+1 ir=iabs(ibndry(5,ibdy))-(it-1)*ibase if(ibndry(5,ibdy).gt.0) then ibndry(5,ibdy)=ir+(2*it-1)*ibase ibndry(5,nbf)=ir+2*it*ibase else ibndry(5,ibdy)=-(ir+(2*it-1)*ibase) ibndry(5,nbf)=-(ir+2*it*ibase) endif endif endif c c refine itri c ntf=ntf+1 do k=1,5 itnode(k,ntf)=itnode(k,itri) enddo itnode(index(3,iedge),itri)=nvf itnode(index(2,iedge),ntf)=nvf c c fixup itedge c do k=1,3 itedge(k,ntf)=itedge(k,itri) enddo do k=1,lenb bump(k,ntf)=bump(k,itri) enddo itedge(index(2,iedge),itri)=4*ntf+index(3,iedge) itedge(index(3,iedge),ntf)=4*itri+index(2,iedge) if(ibdy.gt.0) then itedge(iedge,ntf)=-nbf else itedge(iedge,ntf)=4*(ntf+1)+jedge endif m=itedge(index(2,iedge),ntf) if(m.gt.0) then mtri=m/4 medge=m-4*mtri itedge(medge,mtri)=index(2,iedge)+4*ntf else mb=-m if(ibedge(1,mb)/4.eq.itri) then ibedge(1,mb)=index(2,iedge)+4*ntf else ibedge(2,mb)=index(2,iedge)+4*ntf endif endif c c bookkeeping c mark(ntf)=jmark(iedge,mark(itri)) mark(itri)=imark(iedge,mark(itri)) c e(ntf)=tqual(ntf,itnode,vx,vy,lenb,bump,hmin,coeff) p(ntf)=ntf q(ntf)=ntf call updhp(ntf,ntf,p,q,e,1) e(itri)=tqual(itri,itnode,vx,vy,lenb,bump,hmin,coeff) kk=q(itri) call updhp(kk,ntf,p,q,e,1) c if(slist(itri).eq.0) then slist(itri)=inext inext=itri endif slist(ntf)=inext inext=ntf rlist(ntf)=next next=ntf c c refine jtri c if(jtri.gt.0) then ntf=ntf+1 c c fixup itnode c do k=1,5 itnode(k,ntf)=itnode(k,jtri) enddo itnode(index(2,jedge),jtri)=nvf itnode(index(3,jedge),ntf)=nvf c c fixup itedge c do k=1,3 itedge(k,ntf)=itedge(k,jtri) enddo do k=1,lenb bump(k,ntf)=bump(k,jtri) enddo itedge(index(3,jedge),jtri)=4*ntf+index(2,jedge) itedge(index(2,jedge),ntf)=4*jtri+index(3,jedge) if(ibdy.gt.0) then itedge(jedge,ntf)=-nbf else itedge(jedge,ntf)=4*(ntf-1)+iedge endif m=itedge(index(3,jedge),ntf) if(m.gt.0) then mtri=m/4 medge=m-4*mtri itedge(medge,mtri)=index(3,jedge)+4*ntf else mb=-m if(ibedge(1,mb)/4.eq.jtri) then ibedge(1,mb)=index(3,jedge)+4*ntf else ibedge(2,mb)=index(3,jedge)+4*ntf endif endif c c bookkeeping c mark(ntf)=imark(jedge,mark(jtri)) mark(jtri)=jmark(jedge,mark(jtri)) c e(ntf)=tqual(ntf,itnode,vx,vy,lenb,bump,hmin,coeff) p(ntf)=ntf q(ntf)=ntf call updhp(ntf,ntf,p,q,e,1) e(jtri)=tqual(jtri,itnode,vx,vy,lenb,bump,hmin,coeff) kk=q(jtri) call updhp(kk,ntf,p,q,e,1) c if(slist(jtri).eq.0) then slist(jtri)=inext inext=jtri endif slist(ntf)=inext inext=ntf rlist(ntf)=next next=ntf c endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mklist(itri,itnode,itedge,vx,vy, + mark,num,next,rlist,ibedge,ibndry) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),mark(*),itedge(3,*),index(3,3),ibndry(6,*), 1 rlist(*),ibedge(2,*) double precision 1 vx(*),vy(*),s(3) save index data index/1,2,3,2,3,1,3,1,2/ c c mark(i) = 0 divide no edges c = 1, 2, 3 divide edges 1, 2, 3, resp. c = 4, 5, 6 divide edges (1,2), (1,3), (2,3) resp. c = 7 divide all edges c fract=1.05d0 next=itri rlist(itri)=-1 mark(itri)=0 i=itri num=0 c c detremine type c do j=1,3 j2=itnode(index(2,j),i) j3=itnode(index(3,j),i) s(j)=(vx(j2)-vx(j3))**2+(vy(j2)-vy(j3))**2 enddo imax=1 if(s(2).gt.s(imax)) imax=2 if(s(3).gt.s(imax)) imax=3 mark(i)=imax c c now do dominos c 10 num=num+1 if(itedge(imax,i).gt.0) then k=itedge(imax,i)/4 kedge=itedge(imax,i)-4*k else ib=-itedge(imax,i) if(ibndry(4,ib).eq.0) then if(ibedge(1,ib)/4.eq.i) then k=ibedge(2,ib)/4 kedge=ibedge(2,ib)-4*k else k=ibedge(1,ib)/4 kedge=ibedge(1,ib)-4*k endif else if(ibndry(4,ib).lt.0) then jb=-ibndry(4,ib) k=ibedge(1,jb)/4 kedge=ibedge(1,jb)-4*k else return endif endif rlist(k)=next next=k mark(k)=kedge do j=1,3 j2=itnode(index(2,j),k) j3=itnode(index(3,j),k) s(j)=(vx(j2)-vx(j3))**2+(vy(j2)-vy(j3))**2 enddo kmax=1 if(s(2).gt.s(kmax)) kmax=2 if(s(3).gt.s(kmax)) kmax=3 if(kmax.eq.kedge) return if(s(kmax).le.s(kedge)*fract) return c c use dominos only near boundaries, interfaces c c* kk=6-kmax-kedge c* ksw=0 c* if(min0(itedge(kmax,k),itedge(kk,k)).le.0) then c* ksw=1 c* else c* m=itedge(kmax,k)/4 c* if(itnode(5,m).ne.itnode(5,k)) ksw=1 c* m=itedge(kk,k)/4 c* if(itnode(5,m).ne.itnode(5,k)) ksw=1 c* endif c* if(ksw.eq.0) return mark(k)=kedge+kmax+1 imax=kmax i=k go to 10 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dlknot(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist,len, 1 hmin,coeff,ibase,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),index(3,3), 1 iseed(*),vtype(*),vlist(500),tlist(500),elist(500), 2 ibedge(2,*) double precision + vx(*),vy(*),bump(lenb,*),gg(5),e(*) save index data index/1,2,3,2,3,1,3,1,2/ c c eliminate vertex c if(vtype(i).eq.1) then numax=2 if(len.eq.3) then jj=2 else do m=2,len+1 gg(m)=geom(vlist(m-1),vlist(m), + vlist(m+1),vx,vy) enddo if(dmin1(gg(2),gg(4)).lt.dmin1(gg(3),gg(5))) then jj=2 else jj=1 endif endif else if(vtype(i).eq.6.or.vtype(i).eq.8) then numax=1 jj=2 k2=-tlist(1) k3=-tlist(len+1) ibndry(1,k2)=vlist(len+1) ibndry(1,k3)=0 if(ibndry(5,k2).ne.0.and.isw.ne.0) then im2=iabs(ibndry(5,k2))/ibase+1 ir=iabs(ibndry(5,k2))-(im2-1)*ibase im3=iabs(ibndry(5,k3))/ibase+1 imm=max0(im2,im3)/2 if(ibndry(5,k2).gt.0) then ibndry(5,k2)=ir+(imm-1)*ibase else ibndry(5,k2)=-(ir+(imm-1)*ibase) endif endif if(vtype(i).eq.8) then mb=-ibndry(4,k3) ibndry(4,mb)=-k2 endif if(len.eq.2) then k=iabs(elist(jj)) it=tlist(jj) kt=itedge(k,it)/4 ke=itedge(k,it)-4*kt itnode(1,it)=0 itedge(ke,kt)=-k2 ibedge(1,k2)=4*kt+ke do j=1,3 iseed(itnode(j,kt))=4*kt+j enddo return endif else if(vtype(i).eq.2.or.vtype(i).eq.4) then numax=2 if(len.eq.3) then if(elist(1).gt.0) then jj=3 else if(elist(2).gt.0) then jj=1 else jj=2 endif else if(elist(2).lt.0) then jj=2 else jj=1 endif endif if(vtype(i).eq.4) then ie1=iabs(elist(jj)) it1=tlist(jj) ie2=iabs(elist(jj+1)) it2=tlist(jj+1) k1=-itedge(index(3,ie1),it1) k2=-itedge(index(2,ie2),it2) if(k1.le.0.or.k2.le.0) stop 9598 ibndry(1,k1)=vlist(jj) ibndry(2,k1)=vlist(jj+2) ibndry(1,k2)=0 if(ibndry(5,k1).ne.0.and.isw.ne.0) then im1=iabs(ibndry(5,k1))/ibase+1 ir=iabs(ibndry(5,k1))-(im1-1)*ibase im2=iabs(ibndry(5,k2))/ibase+1 imm=max0(im1,im2)/2 if(ibndry(5,k1).gt.0) then ibndry(5,k1)=ir+(imm-1)*ibase else ibndry(5,k1)=-(ir+(imm-1)*ibase) endif endif if(len.eq.3) then numax=1 ie3=iabs(elist(jj+2)) it3=tlist(jj+2) if(itedge(ie3,it3).lt.0) stop 4913 m=itedge(ie3,it3)/4 medge=itedge(ie3,it3)-4*m itedge(medge,m)=-k1 itnode(1,it3)=0 endif endif endif c c fixup elements c do num=1,numax if(num.eq.1) then c c first pair c k=iabs(elist(jj)) it=tlist(jj) itnode(k,it)=vlist(jj+2) k1=iabs(elist(jj+1)) it1=tlist(jj+1) iedge=index(2,k) else c c second pair c if(len.eq.4) then k=iabs(elist(jj+3)) it=tlist(jj+3) itnode(k,it)=vlist(jj+2) endif k1=iabs(elist(jj+2)) it1=tlist(jj+2) iedge=index(3,k) endif if(itnode(5,it).ne.itnode(5,it1).and.len.ne.3) stop 6113 itnode(1,it1)=0 itedge(iedge,it)=itedge(k1,it1) if(itedge(k1,it1).gt.0) then mt=itedge(k1,it1)/4 medge=itedge(k1,it1)-4*mt itedge(medge,mt)=4*it+iedge else mb=-itedge(k1,it1) if(ibndry(4,mb).eq.0) then if(ibedge(1,mb)/4.ne.it1) then ibedge(2,mb)=4*it+iedge else ibedge(1,mb)=4*it+iedge endif else ibedge(1,mb)=4*it+iedge endif endif do j=1,3 iseed(itnode(j,it))=4*it+j enddo if(isw.eq.1) then do j=1,lenb bump(j,it)=(bump(j,it)+bump(j,it1))/2.0d0 enddo e(it)=tqual(it,itnode,vx,vy,lenb,bump,hmin,coeff) endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),vtype(*),iseed(*),ibndry(6,*), 1 index(3,3),ibedge(2,*), 2 elist(500),blist(500),vlist(500),tlist(500) save index data index/1,2,3,2,3,1,3,1,2/ c c compute circular list for vertex i c len=2 k=iseed(i)/4 j=iseed(i)-4*k vlist(1)=0 c c check for boundary vertex c if(vtype(i).gt.5) then 5 j2=index(3,j) if(itedge(j2,k).gt.0) then kk=itedge(j2,k)/4 ks=itedge(j2,k)-4*kk k=kk j=index(3,ks) go to 5 else ib=-itedge(j2,k) if(ibndry(4,ib).eq.0) then ii=1 if(ibedge(1,ib)/4.eq.k) ii=2 kk=ibedge(ii,ib)/4 ks=ibedge(ii,ib)-4*kk k=kk j=index(3,ks) go to 5 endif endif iseed(i)=j+4*k endif c c now compute circular list c kstrt=k 25 j1=index(2,j) j2=index(3,j) vlist(len)=itnode(j1,k) vlist(len+1)=itnode(j2,k) if(itedge(j2,k).gt.0) then tlist(len-1)=itedge(j2,k)/4 if(itnode(5,k).eq.itnode(5,tlist(len-1)).and. + itnode(4,k).eq.itnode(4,tlist(len-1))) then elist(len)=j else elist(len)=-j endif blist(len)=0 else ib=-itedge(j2,k) if(ibndry(4,ib).eq.0) then ii=1 if(ibedge(1,ib)/4.eq.k) ii=2 tlist(len-1)=ibedge(ii,ib)/4 elist(len)=-j blist(len)=ib else elist(len)=j blist(len)=0 tlist(len-1)=itedge(j2,k) endif endif tlist(len)=k len=len+1 if(len.gt.500) stop 1309 if(itedge(j1,k).gt.0) then kk=itedge(j1,k)/4 ks=itedge(j1,k)-4*kk j=index(2,ks) k=kk tlist(len)=k if(tlist(len).ne.kstrt) go to 25 vlist(1)=vlist(len-1) elist(1)=elist(len-1) elist(len)=elist(2) blist(1)=blist(len-1) blist(len)=blist(2) len=len-2 else ib=-itedge(j1,k) if(ibndry(4,ib).eq.0) then ii=1 if(ibedge(1,ib)/4.eq.k) ii=2 kk=ibedge(ii,ib)/4 ks=ibedge(ii,ib)-4*kk j=index(2,ks) k=kk tlist(len)=k if(tlist(len).ne.kstrt) go to 25 vlist(1)=vlist(len-1) elist(1)=elist(len-1) elist(len)=elist(2) blist(1)=blist(len-1) blist(len)=blist(2) len=len-2 else tlist(len)=itedge(j1,k) elist(1)=0 elist(len)=0 blist(1)=-tlist(1) blist(len)=-tlist(len) len=len-1 endif endif c if(vtype(i).lt.8) return ib=-tlist(len+1) ib=-ibndry(4,ib) ll=len+2 c c vlist(ll) is the equivalent to vertex i c vlist(ll+1) is equivalent to last vertex in circular list for i c vlist(ll)=ibndry(1,ib) vlist(ll+1)=ibndry(2,ib) tlist(ll)=-ib elist(ll)=0 blist(ll)=ib ll=ll+1 if(ll.gt.100) stop 1310 k=ibedge(1,ib)/4 ks=ibedge(1,ib)-4*k j=index(2,ks) 35 j1=index(2,j) j2=index(3,j) vlist(ll)=itnode(j1,k) vlist(ll+1)=itnode(j2,k) if(itedge(j2,k).gt.0) then tlist(ll-1)=itedge(j2,k)/4 if(itnode(5,k).eq.itnode(5,tlist(ll-1)).and. + itnode(4,k).eq.itnode(4,tlist(ll-1))) then elist(ll)=j else elist(ll)=-j endif blist(ll)=0 else ib=-itedge(j2,k) if(ibndry(4,ib).eq.0) then ii=1 if(ibedge(1,ib)/4.eq.k) ii=2 tlist(ll-1)=ibedge(ii,ib)/4 elist(ll)=-j blist(ll)=ib else elist(ll)=j tlist(ll-1)=itedge(j2,k) blist(ll)=0 endif endif tlist(ll)=k ll=ll+1 if(ll.gt.100) stop 1311 if(itedge(j1,k).gt.0) then kk=itedge(j1,k)/4 ks=itedge(j1,k)-4*kk j=index(2,ks) k=kk tlist(ll)=k go to 35 else ib=-itedge(j1,k) if(ibndry(4,ib).eq.0) then ii=1 if(ibedge(1,ib)/4.eq.k) ii=2 kk=ibedge(ii,ib)/4 ks=ibedge(ii,ib)-4*kk j=index(2,ks) k=kk tlist(ll)=k go to 35 else tlist(ll)=itedge(j1,k) elist(ll)=0 blist(ll)=-tlist(ll) ll=ll-1 elist(len+2)=ll endif endif ccc len=ll return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine reduc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist,blist,len, 1 hmin,coeff,isw,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),index(3,3), 1 iseed(*),vtype(*),ibedge(2,*), 2 vlist(500),tlist(500),elist(500),blist(500) double precision + vx(*),vy(*),bump(lenb,*),e(*) save index data index/1,2,3,2,3,1,3,1,2/ c c reduce degree to 3 or 4 by swapping edges c iflag=0 if(vtype(i).ge.6) go to 30 if(len.le.4) return c ivf1=0 ivf2=0 if(vtype(i).gt.1) then do j=2,len+1 if(elist(j).lt.0) then if(ivf1.eq.0) then ivf1=vlist(j) else ivf2=vlist(j) endif endif enddo endif c c 10 if(len.gt.4) then jj=2 gs=-1.0d0 do 20 j=2,len+1 if(vlist(j).eq.ivf1.or.vlist(j).eq.ivf2) go to 20 if(vlist(j-1).eq.ivf1.and.vlist(j+1).eq.ivf2) go to 20 if(vlist(j+1).eq.ivf1.and.vlist(j-1).eq.ivf2) go to 20 qq=geom(i,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0d0) go to 20 gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg.gt.gs) then jj=j gs=gg endif 20 continue if(gs.le.0.0d0) then iflag=1 return endif k=index(3,iabs(elist(jj))) it=tlist(jj) call eswapc(it,k,itnode,itedge,ibedge, + lenb,bump,e,iseed,vx,vy,hmin,coeff,isw) call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) go to 10 endif return c c boundary cases c 30 if(len.gt.3) then jj=3 gs=-1.0d0 do 40 j=3,len qq=geom(i,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0d0) go to 40 gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg.gt.gs) then jj=j gs=gg endif 40 continue if(gs.le.0.0d0) then iflag=2 return endif k=index(3,iabs(elist(jj))) it=tlist(jj) call eswapc(it,k,itnode,itedge,ibedge, + lenb,bump,e,iseed,vx,vy,hmin,coeff,isw) call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) go to 30 endif if(vtype(i).ne.8) return 50 ks1=len+3 len1=elist(len+2) ii=vlist(len+2) if(len1+2-ks1.gt.3) then jj=ks1+1 gs=-1.0d0 do 60 j=ks1+1,len1 qq=geom(ii,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0d0) go to 60 gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg.gt.gs) then jj=j gs=gg endif 60 continue if(gs.le.0.0d0) then iflag=3 return endif k=index(3,iabs(elist(jj))) it=tlist(jj) call eswapc(it,k,itnode,itedge,ibedge, + lenb,bump,e,iseed,vx,vy,hmin,coeff,isw) call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) go to 50 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function tqual(it,itnode,vx,vy,lenb, + bump,hmin,coeff) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),bump(lenb,*),tx(3),ty(3),e(3),x(3), 1 y(3),c(3),dp(3) save index data index/1,2,3,2,3,1,3,1,2/ c c local error estimate in h1 norm c do j=1,3 j2=itnode(index(2,j),it) j3=itnode(index(3,j),it) tx(j)=vx(j3)-vx(j2) ty(j)=vy(j3)-vy(j2) x(j)=tx(j)**2 y(j)=ty(j)**2 c(j)=2.0d0*tx(j)*ty(j) enddo dp(1)=tx(2)*tx(3)+ty(2)*ty(3) dp(2)=tx(3)*tx(1)+ty(3)*ty(1) dp(3)=tx(1)*tx(2)+ty(1)*ty(2) c sq=(x(1)+y(1)+x(2)+y(2)+x(3)+y(3))/3.0d0 if(dsqrt(sq).le.hmin) then tqual=0.0d0 return endif det=dabs(tx(2)*ty(3)-tx(3)*ty(2))*3.0d0/4.0d0 se=0.0d0 do j=1,lenb,3 e(1)=x(1)*bump(j,it)+y(1)*bump(j+1,it)+c(1)*bump(j+2,it) e(2)=x(2)*bump(j,it)+y(2)*bump(j+1,it)+c(2)*bump(j+2,it) e(3)=x(3)*bump(j,it)+y(3)*bump(j+1,it)+c(3)*bump(j+2,it) se=se-(dp(1)*((e(2)-e(3))**2+e(1)**2) + +dp(2)*((e(3)-e(1))**2+e(2)**2) 1 +dp(3)*((e(1)-e(2))**2+e(3)**2))/det enddo tqual=se+(sq/det)*(coeff*sq)**2 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function tqual1(it,itnode,vx,vy,u,ux,uy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),u(*),ux(*),uy(*) save index data index/1,2,3,2,3,1,3,1,2/ c iv1=itnode(1,it) iv2=itnode(2,it) iv3=itnode(3,it) x2=vx(iv2)-vx(iv1) x3=vx(iv3)-vx(iv1) y2=vy(iv2)-vy(iv1) y3=vy(iv3)-vy(iv1) u2=u(iv2)-u(iv1) u3=u(iv3)-u(iv1) det=x2*y3-x3*y2 uhx=(u2*y3-u3*y2)/det uhy=(x2*u3-x3*u2)/det tqual1=0.0d0 do k=1,3 k2=itnode(index(2,k),it) k3=itnode(index(3,k),it) ex=(ux(k2)+ux(k3))/2.0d0-uhx ey=(uy(k2)+uy(k3))/2.0d0-uhy tqual1=tqual1+ex**2+ey**2 enddo tqual1=tqual1*dabs(det)/6.0d0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function tqual2(it,itnode,vx,vy,lenb,bump) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),bump(lenb,*),tx(3),ty(3),x(3),y(3),c(3) save index data index/1,2,3,2,3,1,3,1,2/ c c local error estimate in l2 norm c do j=1,3 j2=itnode(index(2,j),it) j3=itnode(index(3,j),it) tx(j)=vx(j3)-vx(j2) ty(j)=vy(j3)-vy(j2) x(j)=tx(j)**2 y(j)=ty(j)**2 c(j)=2.0d0*tx(j)*ty(j) enddo se=0.0d0 do j=1,lenb,3 e1=x(1)*bump(j,it)+y(1)*bump(j+1,it)+c(1)*bump(j+2,it) e2=x(2)*bump(j,it)+y(2)*bump(j+1,it)+c(2)*bump(j+2,it) e3=x(3)*bump(j,it)+y(3)*bump(j+1,it)+c(3)*bump(j+2,it) se=se+(e1+e2)**2+(e2+e3)**2+(e3+e1)**2 enddo tqual2=se*dabs(tx(2)*ty(3)-tx(3)*ty(2))*2.0d0/45.0d0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function vqual(i,emax,vlist,tlist,elist, + len,e,vtype,vx,vy,hmax) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vtype(*),vlist(500),tlist(500),elist(500), 1 corner(9),ie(2) double precision + e(*),bias(4),vx(*),vy(*) save bias,corner data bias/0.6d0,0.8d0,0.9d0,1.0d0/ data corner/0,0,1,0,1,0,1,0,1/ c c compute quality funtion for vertex c vqual=-emax if(corner(vtype(i)).eq.1) return c if(vtype(i).ge.6) then if(len.gt.4) return dd=dsqrt((vx(vlist(2))-vx(vlist(len+1)))**2+ + (vy(vlist(2))-vy(vlist(len+1)))**2) if(dd.gt.hmax) return qq=0.0d0 do j=2,len qq=dmax1(qq,e(tlist(j))) enddo vqual=-qq*bias(2*len-4) if(vtype(i).eq.8) then len1=elist(len+2) if(len1.gt.len+5) then vqual=-emax return endif do j=len+3,len1 qq=dmax1(qq,e(tlist(j))) enddo vqual=dmin1(-qq*bias(len1-5),vqual) endif else if(len.gt.6) return if(len.eq.6) then d1=dsqrt((vx(vlist(1))-vx(vlist(4)))**2+ + (vy(vlist(1))-vy(vlist(4)))**2) d2=dsqrt((vx(vlist(2))-vx(vlist(5)))**2+ + (vy(vlist(2))-vy(vlist(5)))**2) d3=dsqrt((vx(vlist(3))-vx(vlist(6)))**2+ + (vy(vlist(3))-vy(vlist(6)))**2) if(dmin1(d1,d2,d3).gt.hmax) return else if(len.eq.5) then dd=dsqrt((vx(vlist(1))-vx(vlist(3)))**2+ + (vy(vlist(1))-vy(vlist(3)))**2) do j=2,5 dj=dsqrt((vx(vlist(j))-vx(vlist(j+2)))**2+ + (vy(vlist(j))-vy(vlist(j+2)))**2) dd=dmin1(dd,dj) enddo if(dd.gt.hmax)return else if(len.eq.4) then d1=dsqrt((vx(vlist(1))-vx(vlist(3)))**2+ + (vy(vlist(1))-vy(vlist(3)))**2) d2=dsqrt((vx(vlist(2))-vx(vlist(4)))**2+ + (vy(vlist(2))-vy(vlist(4)))**2) if(dmin1(d1,d2).gt.hmax) return endif if(vtype(i).ne.1) then k=0 do j=2,len+1 if(elist(j).lt.0) then k=k+1 ie(k)=j endif enddo if(k.ne.2) stop 7666 if(len.eq.4) then if(iabs(ie(1)-ie(2)).ne.2) return else if(len.eq.5) then if(iabs(ie(1)-ie(2)).lt.2) return if(iabs(ie(1)-ie(2)).gt.3) return else if(len.eq.6) then if(iabs(ie(1)-ie(2)).ne.3) return endif endif qq=0.0d0 do j=2,len+1 qq=dmax1(qq,e(tlist(j))) enddo vqual=-qq*bias(len-2) endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine vorder(ip,p,q,itnode,ibndry,vx,vy,gf,maxv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itnode(5,*),ibndry(6,*),ip(100) double precision + vx(*),vy(*),gf(maxv,*),gg(100) c c physically reorder the vertex arrays with respect to c permutation p c ntf=ip(1) nvf=ip(2) nbf=ip(4) idbcpt=ip(7) ngf=ip(77) c do i=1,nvf q(p(i))=i enddo c c move real arrays c do 20 i=1,nvf if(p(i).eq.i) go to 20 if(p(i).lt.0) go to 20 do m=1,ngf gg(m)=gf(i,m) enddo r1=vx(i) r2=vy(i) j=i 10 k=p(j) p(j)=-k if(k.ne.i) then do m=1,ngf gf(j,m)=gf(k,m) enddo vx(j)=vx(k) vy(j)=vy(k) j=k go to 10 endif do m=1,ngf gf(j,m)=gg(m) enddo vx(j)=r1 vy(j)=r2 20 continue c c fixup p c do i=1,nvf p(q(i))=i enddo c c fix up knots in itnode c do i=1,ntf do j=1,3 itnode(j,i)=q(itnode(j,i)) enddo enddo c c fix up knots in ibndry c do i=1,nbf do j=1,2 ibndry(j,i)=q(ibndry(j,i)) enddo enddo c c special dirichlet point c if(idbcpt.gt.0) then ip(7)=q(idbcpt) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine border(ip,p,q,ibndry) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),ibndry(6,*),ip(100),ib(6) c c physically reorder the vertex arrays with respect to c permutation p c nbf=ip(4) c do i=1,nbf q(p(i))=i enddo c c do 20 i=1,nbf if(p(i).eq.i) go to 20 if(p(i).lt.0) go to 20 do m=1,6 ib(m)=ibndry(m,i) enddo j=i 10 k=p(j) p(j)=-k if(k.ne.i) then do m=1,6 ibndry(m,j)=ibndry(m,k) enddo j=k go to 10 endif do m=1,6 ibndry(m,j)=ib(m) enddo 20 continue c do i=1,nbf p(q(i))=i enddo c do i=1,nbf if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,i)=-q(k) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clnup(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,lenb,bump,mark,gf,maxv,ngf,idbcpt) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),mark(*),ibedge(2,*) double precision + vx(*),vy(*),bump(lenb,*),gf(maxv,*) c c clean up data structure after vertex elimination c c fixup itnode, itedge, bump c ntnew=0 do i=1,ntf if(itnode(1,i).ne.0) then ntnew=ntnew+1 mark(i)=ntnew do j=1,5 itnode(j,ntnew)=itnode(j,i) enddo do j=1,3 itedge(j,ntnew)=itedge(j,i) enddo do j=1,lenb bump(j,ntnew)=bump(j,i) enddo else mark(i)=0 endif enddo do i=1,nbf ibedge(1,i)=0 ibedge(2,i)=0 enddo do i=1,ntnew do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 ke=itedge(j,i)-4*k itedge(j,i)=4*mark(k)+ke else m=-itedge(j,i) if(ibedge(1,m).gt.0) then ibedge(2,m)=4*i+j else ibedge(1,m)=4*i+j endif endif enddo enddo ntf=ntnew c c fixup ibndry...note internal interface edges are put in itedge c nbnew=0 do i=1,nbf if(ibndry(1,i).ne.0) then nbnew=nbnew+1 mark(i)=nbnew do j=1,6 ibndry(j,nbnew)=ibndry(j,i) enddo ibedge(1,nbnew)=ibedge(1,i) ibedge(2,nbnew)=ibedge(2,i) k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew).gt.0) then k=ibedge(2,nbnew)/4 ke=ibedge(2,nbnew)-4*k itedge(ke,k)=-nbnew endif else mark(i)=0 endif enddo nbf=nbnew c c periodic edges c do i=1,nbf if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,i)=-mark(k) endif enddo c c now fix vertex arrays c do i=1,nvf mark(i)=0 enddo do i=1,ntf do j=1,3 mark(itnode(j,i))=1 enddo enddo nvnew=0 do i=1,nvf if(mark(i).ne.0) then nvnew=nvnew+1 mark(i)=nvnew vx(nvnew)=vx(i) vy(nvnew)=vy(i) do k=1,ngf gf(nvnew,k)=gf(i,k) enddo endif enddo nvf=nvnew do i=1,ntf do j=1,3 itnode(j,i)=mark(itnode(j,i)) enddo enddo do i=1,nbf do j=1,2 ibndry(j,i)=mark(ibndry(j,i)) enddo enddo if(idbcpt.gt.0) idbcpt=mark(idbcpt) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clnup2(nvf,ntf,nbf,newnvf,newntf,newnbf,nvi,nbi, + irgn,itnode,itedge,ibndry,ibedge,vx,vy,mark,gf,maxv,ngf) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),mark(*),ibedge(2,*), 1 index(3,3) double precision + vx(*),vy(*),gf(maxv,*) save index data index/1,2,3,2,3,1,3,1,2/ c c clean up data structure after vertex elimination c c fixup itnode, itedge c ntnew=newntf do i=1,newntf mark(i)=i enddo do i=newntf+1,ntf if(itnode(1,i).ne.0) then ntnew=ntnew+1 mark(i)=ntnew do j=1,5 itnode(j,ntnew)=itnode(j,i) enddo do j=1,3 itedge(j,ntnew)=itedge(j,i) enddo else mark(i)=0 endif enddo do i=1,nbf ibedge(1,i)=0 ibedge(2,i)=0 enddo do i=1,ntnew do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 ke=itedge(j,i)-4*k itedge(j,i)=4*mark(k)+ke else m=-itedge(j,i) if(ibedge(1,m).gt.0) then ibedge(2,m)=4*i+j else ibedge(1,m)=4*i+j endif endif enddo enddo ntf=ntnew c c fixup ibndry...note internal interface edges are put in itedge c do i=1,newnbf mark(i)=i enddo nbnew=newnbf nbinew=newnbf do i=newnbf+1,nbf if(ibndry(1,i).ne.0) then nbnew=nbnew+1 if(i.le.nbi) nbinew=nbinew+1 mark(i)=nbnew do j=1,6 ibndry(j,nbnew)=ibndry(j,i) enddo ibedge(1,nbnew)=ibedge(1,i) ibedge(2,nbnew)=ibedge(2,i) k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew).gt.0) then k=ibedge(2,nbnew)/4 ke=ibedge(2,nbnew)-4*k itedge(ke,k)=-nbnew endif else mark(i)=0 endif enddo nbf=nbnew nbi=nbinew c c periodic edges c do i=1,nbf if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,i)=-mark(k) endif enddo c c orient boundary edges c do i=newntf+1,ntf do j=1,3 if(itedge(j,i).lt.0) then k=-itedge(j,i) ibndry(1,k)=itnode(index(2,j),i) ibndry(2,k)=itnode(index(3,j),i) if(ibndry(4,k).eq.0.and.itnode(4,i).ne.irgn) then if(ibedge(1,k)/4.ne.i) then ii=ibedge(1,k)/4 jj=ibedge(1,k)-4*ii else ii=ibedge(2,k)/4 jj=ibedge(2,k)-4*ii endif if(itnode(4,ii).eq.irgn) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) else if(itnode(4,ii).lt.itnode(4,i)) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) endif endif endif enddo enddo c c now fix vertex arrays c do i=1,newnvf mark(i)=i enddo do i=newnvf+1,nvf mark(i)=0 enddo do i=newntf+1,ntf do j=1,3 mark(itnode(j,i))=itnode(j,i) enddo enddo nvnew=newnvf nvinew=newnvf do i=newnvf+1,nvf if(mark(i).ne.0) then nvnew=nvnew+1 if(i.le.nvi) nvinew=nvinew+1 mark(i)=nvnew vx(nvnew)=vx(i) vy(nvnew)=vy(i) do k=1,ngf gf(nvnew,k)=gf(i,k) enddo endif enddo nvf=nvnew nvi=nvinew do i=newntf+1,ntf do j=1,3 itnode(j,i)=mark(itnode(j,i)) enddo enddo do i=newnbf+1,nbf do j=1,2 ibndry(j,i)=mark(ibndry(j,i)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine adtri(nv0,nvf,ntf,irefn,ja,itnode,ibndry,mark, + vx,vy,gf,maxv,ngf,lenb,bump,e,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),itnode(5,*),iv(3),index(3,3),mark(*),ibndry(6,*), 1 list(6,*) double precision + vx(*),vy(*),gf(maxv,*),bump(lenb,*),e(*) save index data index/1,2,3,2,3,1,3,1,2/ c c add knots to interior of triangles and initialize itnode c nt0=ntf hmin=0.0d0 coeff=0.0d0 c c transfer itnode to iv c do i=1,nt0 ntold=ntf+1 nvold=nvf+1 i1=1 if(itnode(2,i).gt.itnode(i1,i)) i1=2 if(itnode(3,i).gt.itnode(i1,i)) i1=3 iv(1)=itnode(i1,i) iv(2)=itnode(index(2,i1),i) iv(3)=itnode(index(3,i1),i) c c compute starting vertex for edges c j1=ja(iv(1)) j2=ja(iv(1)+1)-1 n12=0 n13=0 n23=0 do j=j1,j2 if(ja(j).eq.iv(2)) then n12=nv0+(irefn-1)*(j-ja(1))+1 else if(ja(j).eq.iv(3)) then n13=nv0+(irefn-1)*(j-ja(1))+1 endif enddo if(n12.eq.0) stop 777 if(n13.eq.0) stop 778 if(iv(2).gt.iv(3)) then inc=1 j1=ja(iv(2)) j2=ja(iv(2)+1)-1 do j=j1,j2 if(ja(j).eq.iv(3)) then n23=nv0+(irefn-1)*(j-ja(1))+1 endif enddo else inc=-1 j1=ja(iv(3)) j2=ja(iv(3)+1)-1 do j=j1,j2 if(ja(j).eq.iv(2)) then n23=nv0+(irefn-1)*(j-ja(1)+1) endif enddo endif c c now add triangles c do m=1,irefn if(m.eq.1) then itnode(1,i)=iv(1) itnode(2,i)=n12 itnode(3,i)=n13 ntsv=ntf+1 next=n13 else if(m.eq.irefn) then last=n12 ntf=ntf+1 itnode(1,ntf)=iv(2) itnode(2,ntf)=n23 itnode(3,ntf)=n12 itnode(4,ntf)=itnode(4,i) itnode(5,ntf)=itnode(5,i) do kk=1,m-1 ntf=ntf+1 itnode(1,ntf)=last itnode(2,ntf)=n23 itnode(3,ntf)=next itnode(4,ntf)=itnode(4,i) itnode(5,ntf)=itnode(5,i) ntf=ntf+1 itnode(1,ntf)=n23 itnode(2,ntf)=n23+inc itnode(3,ntf)=next itnode(4,ntf)=itnode(4,i) itnode(5,ntf)=itnode(5,i) n23=n23+inc last=next next=next+1 c c this is to get around -O bug in sgi compiler c if(kk.eq.m-1) then itnode(3,ntf-1)=n13 itnode(2,ntf)=iv(3) itnode(3,ntf)=n13 endif enddo else last=n12 ntf=ntf+1 n12=n12+1 n13=n13+1 nextsv=nvf+1 itnode(1,ntf)=n12 itnode(2,ntf)=nvf+1 itnode(3,ntf)=n12-1 itnode(4,ntf)=itnode(4,i) itnode(5,ntf)=itnode(5,i) do kk=1,m-1 nvf=nvf+1 c2=dfloat(kk)/dfloat(m) c1=1.0d0-c2 vx(nvf)=c1*vx(n12)+c2*vx(n13) vy(nvf)=c1*vy(n12)+c2*vy(n13) do k=1,ngf gf(nvf,k)=c1*gf(n12,k)+c2*gf(n13,k) enddo ntf=ntf+1 itnode(1,ntf)=last itnode(2,ntf)=nvf itnode(3,ntf)=next itnode(4,ntf)=itnode(4,i) itnode(5,ntf)=itnode(5,i) ntf=ntf+1 itnode(1,ntf)=nvf itnode(2,ntf)=nvf+1 itnode(3,ntf)=next itnode(4,ntf)=itnode(4,i) itnode(5,ntf)=itnode(5,i) last=next next=next+1 if(kk.eq.m-1) then itnode(3,ntf-1)=n13-1 itnode(2,ntf)=n13 itnode(3,ntf)=n13-1 endif enddo next=nextsv endif enddo e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) do m=ntsv,ntf do j=1,lenb bump(j,m)=bump(j,i) enddo e(m)=tqual(m,itnode,vx,vy,lenb,bump,hmin,coeff) enddo c c smooth knots generated in triangle with curved edge c if(mark(i).ne.0) call smth(nvold,nvf,ntold,ntf,i, + itnode,ibndry,mark,vx,vy,iv,list) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine adedge(nvf,nbf,irefn,ja,itnode,ibndry,ibedge, + vx,vy,gf,maxv,ngf,xm,ym) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),itnode(5,*),ibndry(6,*),ibedge(2,*) double precision + vx(*),vy(*),gf(maxv,*),xm(*),ym(*) c c add vertices on element edges c pi=3.141592653589793d0 nv0=nvf do i=1,nv0 j1=ja(i) j2=ja(i+1)-1 if(j1.le.j2) then do jj=j1,j2 j=ja(jj) do kk=1,irefn-1 nvf=nvf+1 c2=dfloat(kk)/dfloat(irefn) c1=1.0d0-c2 vx(nvf)=c1*vx(i)+c2*vx(j) vy(nvf)=c1*vy(i)+c2*vy(j) do k=1,ngf gf(nvf,k)=c1*gf(i,k)+c2*gf(j,k) enddo enddo enddo endif enddo c c add new boundary edges c nb0=nbf do i=1,nb0 iv1=ibndry(1,i) iv2=ibndry(2,i) if(iv1.gt.iv2) then inc=1 j1=ja(iv1) j2=ja(iv1+1)-1 do j=j1,j2 if(ja(j).eq.iv2) then n12=nv0+(irefn-1)*(j-ja(1))+1 endif enddo m1=iv1 m2=iv2 m12=n12 else inc=-1 j1=ja(iv2) j2=ja(iv2+1)-1 do j=j1,j2 if(ja(j).eq.iv1) then n12=nv0+(irefn-1)*(j-ja(1)+1) endif enddo m1=iv2 m2=iv1 m12=n12-irefn+2 endif if(ibndry(3,i).gt.0) then kt=ibndry(3,i) call arc(vx(m1),vy(m1),vx(m2),vy(m2), + xm(kt),ym(kt),theta1,theta2,r,alen) k1=ibedge(1,i)/4 k2=ibedge(1,i)-4*k1 m3=itnode(k2,k1) dt=(theta2-theta1)/dfloat(irefn) x1=vx(m1)-vx(m3) x2=vx(m2)-vx(m3) y1=vy(m1)-vy(m3) y2=vy(m2)-vy(m3) det=x1*y2-y1*x2 do m=1,irefn-1 tt=(theta1+dt*dfloat(m))*pi xx=xm(kt)+r*dcos(tt)-vx(m3) yy=ym(kt)+r*dsin(tt)-vy(m3) c1=(xx*y2-yy*x2)/det c2=(x1*yy-y1*xx)/det c3=1.0d0-c1-c2 vx(m12)=c1*vx(m1)+c2*vx(m2)+c3*vx(m3) vy(m12)=c1*vy(m1)+c2*vy(m2)+c3*vy(m3) do k=1,ngf gf(m12,k)=c1*gf(m1,k)+c2*gf(m2,k)+c3*gf(m3,k) enddo m12=m12+1 enddo endif c c now add boundary edges c do m=1,irefn if(m.eq.1) then ibndry(2,i)=n12 else nbf=nbf+1 do j=1,6 ibndry(j,nbf)=ibndry(j,i) enddo ibndry(1,nbf)=n12 ibndry(2,nbf)=n12+inc n12=n12+inc endif enddo ibndry(2,nbf)=iv2 if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibeg=nb0+(irefn-1)*(i-1) kend=nb0+(irefn-1)*k do j=1,irefn if(j.eq.1) then ibndry(4,i)=-kend else if(j.eq.irefn) then ibndry(4,ibeg+j-1)=-k else ibndry(4,ibeg+j-1)=-(kend-j+1) endif enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine smth(nv1,nvf,nt1,ntf,it,itnode,ibndry,mark, + vx,vy,iv,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),mark(*),ibndry(6,*),iv(3), 1 list(6,*) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c if(mark(it).eq.0) return if(nv1.gt.nvf) return ib=mark(it) ic=ibndry(3,ib) if(ic.le.0) return c itmax=100 tol=1.d-4 xx=(dabs(vx(iv(1)))+dabs(vx(iv(2)))+dabs(vx(iv(3))))/3.0d0 yy=(dabs(vy(iv(1)))+dabs(vy(iv(2)))+dabs(vy(iv(3))))/3.0d0 c c inilialize list c do i=1,nvf-nv1+1 list(1,i)=6 enddo kcc=0 do i=nt1,ntf do j=1,3 iv2=itnode(index(2,j),i) iv3=itnode(index(3,j),i) if(iv2.ge.nv1) then ii=iv2-nv1+1 k=list(1,ii) list(k,ii)=iv3 if(k.gt.1) then list(1,ii)=k-1 else kcc=kcc+1 endif endif enddo enddo if(kcc.ne.nvf-nv1+1) stop 9988 c c smoothing loop c do itnum=1,itmax error=0.0d0 do i=nv1,nvf ii=i-nv1+1 xs=0.0d0 ys=0.0d0 do j=1,6 xs=xs+vx(list(j,ii)) ys=ys+vy(list(j,ii)) enddo xs=xs/6.0d0 ys=ys/6.0d0 error=dmax1(dabs(vx(i)-xs)/xx,dabs(vy(i)-ys)/yy) vx(i)=xs vy(i)=ys enddo if(error.lt.tol) return enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mfe1(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge,lenb,bump) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),iseed(*),vtype(*),ibndry(6,*), 1 vf(2),vf1(2),ibedge(2,*),corner(9), 2 vlist(500),elist(500),tlist(500),blist(500) double precision + vx(*),vy(*),xm(*),ym(*),bump(lenb,*) save corner data corner/0,0,1,0,1,0,1,0,1/ c c rezone the region c tol=1.0d-2 eps=0.5d0 c c smooth the data points c call cedge5(nbf,itedge,ibedge,1) do itnum=1,itmax ifail=0 ichng=0 do 50 i=1,nvf if(corner(vtype(i)).eq.1) go to 50 c c compute circular list of vertices, initial function eval c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) len1=0 icen=0 if(vtype(i).ge.6) then ks=2 ie1=-tlist(1) ie2=-tlist(len+1) vf(1)=vlist(2) vf(2)=vlist(len+1) if(ibndry(3,ie2).gt.0) then icen=ibndry(3,ie2) rr=(xm(icen)-vx(i))**2+(ym(icen)-vy(i))**2 endif if(vtype(i).eq.8) then ks1=len+3 len1=elist(len+2) vf1(2)=vlist(ks1) vf1(1)=vlist(len1+1) ii=vlist(len+2) ie3=-tlist(len+2) if(ibndry(3,ie3).gt.0) then icen1=ibndry(3,ie3) endif dx=vx(vf(1))-vx(vf(2)) dy=vy(vf(1))-vy(vf(2)) dx1=vx(vf1(1))-vx(vf1(2)) dy1=vy(vf1(1))-vy(vf1(2)) dd=dx**2+dy**2 cc=(dx*dx1+dy*dy1)/dd ss=(dy*dx1-dx*dy1)/dd cc2=cc**2 cs2=cc*ss ss2=ss**2 xx1=vx(ii) yy1=vy(ii) endif else ks=1 if(vtype(i).ne.1) then ic=0 do k=ks,len if(elist(k).lt.0) then ic=ic+1 vf(ic)=vlist(k) ie1=blist(k) endif enddo if(vtype(i).eq.4) then if(ibndry(3,ie1).gt.0) then icen=ibndry(3,ie1) rr=(xm(icen)-vx(i))**2 + +(ym(icen)-vy(i))**2 endif endif endif endif c c initial function evaluation c call geval(i,vx,vy,vlist,tlist,ks,len, + lenb,bump,f0,gx,gy,gxx,gxy,gyy) if(vtype(i).eq.8) then call geval(ii,vx,vy,vlist,tlist,ks1,len1, + lenb,bump,fk1,gx1,gy1,gxx1,gxy1,gyy1) f0=f0+fk1 gx=gx+cc*gx1-ss*gy1 gy=gy+ss*gx1+cc*gy1 gxx=gxx+cc2*gxx1-2.0d0*cs2*gxy1+ss2*gyy1 gxy=gxy+cs2*(gxx1-gyy1)+(cc2-ss2)*gxy1 gyy=gyy+ss2*gxx1+2.0d0*cs2*gxy1+cc2*gyy1 endif gs=dmax1(dabs(gxx),dabs(gxy),dabs(gyy)) if(gs.eq.0.0d0) go to 50 f0=f0/gs gx=gx/gs gy=gy/gs gxx=gxx/gs gyy=gyy/gs gxy=gxy/gs g0=dsqrt(gx**2+gy**2) c c compute approximate newton direction c det=gxx*gyy-gxy**2 if(det.eq.0.0d0) go to 50 px=-(gx*gyy-gy*gxy)/det py=-(gxx*gy-gxy*gx)/det if(vtype(i).ne.1) then dx=vx(vf(1))-vx(vf(2)) dy=vy(vf(1))-vy(vf(2)) dd=(px*dx+dy*py)/(dx**2+dy**2) px=dx*dd py=dy*dd endif c c test to see if line search is justified c pp=dsqrt(px**2+py**2) if(pp*g0.eq.0.0d0) go to 50 d0=(px*gx+py*gy)/(g0*pp) if(d0+tol.ge.0.0d0) go to 50 smin=0.0d0 smax=stpmx(i,vx,vy,vlist,ks,len,px,py) if(vtype(i).eq.8) then px1=dx1*dd py1=dy1*dd smax1=stpmx(ii,vx,vy,vlist,ks1,len1,px1,py1) smax=dmin1(smax,smax1) endif if(smax.le.tol) go to 50 c c line search c ichng=ichng+1 step=smax xx=vx(i) yy=vy(i) ic=0 40 vx(i)=xx+step*px vy(i)=yy+step*py if(vtype(i).eq.8) then vx(ii)=xx1+step*px1 vy(ii)=yy1+step*py1 endif if(icen.gt.0) then rn=(xm(icen)-vx(i))**2+(ym(icen)-vy(i))**2 rn=dsqrt(rr/rn) vx(i)=xm(icen)+rn*(vx(i)-xm(icen)) vy(i)=ym(icen)+rn*(vy(i)-ym(icen)) if(vtype(i).eq.8) then vx(ii)=xm(icen1)+rn*(vx(ii)-xm(icen1)) vy(ii)=ym(icen1)+rn*(vy(ii)-ym(icen1)) endif endif ic=ic+1 call geval(i,vx,vy,vlist,tlist,ks,len, + lenb,bump,fk,gx,gy,gxx,gxy,gyy) if(vtype(i).eq.8) then call geval(ii,vx,vy,vlist,tlist,ks1,len1, + lenb,bump,fk1,gx1,gy1,gxx1,gxy1,gyy1) fk=fk+fk1 gx=gx+cc*gx1-ss*gy1 gy=gy+ss*gx1+cc*gy1 gxx=gxx+cc2*gxx1-2.0d0*cs2*gxy1+ss2*gyy1 gxy=gxy+cs2*(gxx1-gyy1)+(cc2-ss2)*gxy1 gyy=gyy+ss2*gxx1+2.0d0*cs2*gxy1+cc2*gyy1 endif fk=fk/gs gx=gx/gs gy=gy/gs gxx=gxx/gs gyy=gyy/gs gxy=gxy/gs gk=dsqrt(gx*gx+gy*gy) if(fk.lt.eps*f0) go to 50 if(gk.lt.eps*g0) go to 50 r=gx*px+gy*py dk=r/(gk*pp) if(dabs(dk).lt.eps) go to 50 s=gxx*px**2+2.0d0*gxy*px*py+gyy*py**2 if(r*s.lt.0.0d0) then smin=step else smax=step endif ss=step-r/s if(ss.gt.smin.and.ss.lt.smax) then step=ss else step=(smin+smax)/2.0d0 endif if(ic.lt.10) go to 40 if(gk.ge.g0) then vx(i)=xx vy(i)=yy if(vtype(i).eq.8) then vx(ii)=xx1 vy(ii)=yy1 endif ichng=ichng-1 endif ifail=ifail+1 50 continue enddo call cedge5(nbf,itedge,ibedge,0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mfe2(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),iseed(*),vtype(*),ibndry(6,*), 1 vf(2),vf1(2),ibedge(2,*),corner(9), 2 blist(500),vlist(500),elist(500),tlist(500) double precision + vx(*),vy(*),xm(*),ym(*) save corner data corner/0,0,1,0,1,0,1,0,1/ c c this routine tries to optimize knot placement c tol=1.0d-3 s3=dsqrt(3.0d0)/2.0d0 c c thr main loop in which the knots positions are c optimized c call cedge5(nbf,itedge,ibedge,1) do itnum=1,itmax do 110 i=1,nvf if(corner(vtype(i)).eq.1) go to 110 c c compute circular list of vertices c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) jtnum=1 len1=0 icen=0 if(vtype(i).ge.6) then ks=2 ie1=-tlist(1) ie2=-tlist(len+1) vf(1)=vlist(2) vf(2)=vlist(len+1) if(ibndry(3,ie2).gt.0) then icen=ibndry(3,ie2) rr=(xm(icen)-vx(i))**2+(ym(icen)-vy(i))**2 endif if(vtype(i).eq.8) then jtnum=2 ks1=len+3 len1=elist(len+2) vf1(2)=vlist(ks1) vf1(1)=vlist(len1+1) ii=vlist(len+2) ie3=-tlist(len+2) if(ibndry(3,ie3).gt.0) then icen1=ibndry(3,ie3) endif px=vx(vf(1))-vx(vf(2)) py=vy(vf(1))-vy(vf(2)) px1=vx(vf1(1))-vx(vf1(2)) py1=vy(vf1(1))-vy(vf1(2)) dd=px**2+py**2 cc1=(px*px1+py*py1)/dd ss1=(py*px1-px*py1)/dd endif else ks=1 if(vtype(i).ne.1) then ic=0 do k=ks,len if(elist(k).lt.0) then ic=ic+1 vf(ic)=vlist(k) ie1=blist(k) endif enddo if(vtype(i).eq.4) then if(ibndry(3,ie1).gt.0) then icen=ibndry(3,ie1) rr=(xm(icen)-vx(i))**2 + +(ym(icen)-vy(i))**2 endif endif endif endif qmin=1.0d0 qmin2=1.0d0 k1=0 k2=0 kbeg=ks kend=len iv=i do iter=1,jtnum do k=kbeg,kend kb=vlist(k) ka=vlist(k+1) q=geom(iv,kb,ka,vx,vy) if(q.lt.qmin) then qmin2=qmin qmin=q k2=k1 k1=k else if(q.lt.qmin2) then qmin2=q k2=k endif enddo kbeg=len+3 kend=len1 iv=vlist(len+2) enddo xmin=vx(i) ymin=vy(i) if(vtype(i).eq.8) then xmin1=vx(ii) ymin1=vy(ii) endif c c special cases of boundary or interface node c if(vtype(i).ne.1) then px=vx(vf(1))-vx(vf(2)) py=vy(vf(1))-vy(vf(2)) kb=vlist(k1) ka=vlist(k1+1) if(k1.le.len) then x1=vx(ka)-vx(i) y1=vy(ka)-vy(i) x2=vx(kb)-vx(i) y2=vy(kb)-vy(i) else xa=vx(ka)-vx(ii) ya=vy(ka)-vy(ii) xb=vx(kb)-vx(ii) yb=vy(kb)-vy(ii) x1=cc1*xa-ss1*ya y1=ss1*xa+cc1*ya x2=cc1*xb-ss1*yb y2=ss1*xb+cc1*yb endif det=x2*y1-x1*y2 cd=x1**2+y1**2+x2**2+y2**2+(x1-x2)**2+(y1-y2)**2 bn=-(px*(y1-y2)-py*(x1-x2)) bd=-2.0d0*(px*(x1+x2)+py*(y1+y2)) ad=2.0d0*(px**2+py**2) aa=ad*bn if(aa.ne.0.0d0) then bb=ad*det/aa cc=(bd*det-bn*cd)/aa disc=dsqrt(bb**2-cc) if(bb.gt.0.0d0) then r1=-cc/(bb+disc) r2=-(bb+disc) else r1=disc-bb r2=-cc/(bb-disc) endif if(bn.gt.0.0d0) then beta=dmax1(r1,r2) else beta=dmin1(r1,r2) endif else beta=-(bd*det-bn*cd)/(2.0d0*ad*det) endif xmax=vx(i)+px*beta ymax=vy(i)+py*beta if(vtype(i).eq.8) then xmax1=vx(ii)+px1*beta ymax1=vy(ii)+py1*beta endif else c c the case of interior node c kb=vlist(k1) ka=vlist(k1+1) dxk=(vx(ka)-vx(kb))*s3 dyk=(vy(ka)-vy(kb))*s3 xmk=(vx(kb)+vx(ka))/2.0d0 ymk=(vy(kb)+vy(ka))/2.0d0 xmax=xmk-dyk ymax=ymk+dxk rk=dsqrt(dxk*dxk+dyk*dyk) lb=vlist(k2) la=vlist(k2+1) dxl=(vx(la)-vx(lb))*s3 dyl=(vy(la)-vy(lb))*s3 xml=(vx(lb)+vx(la))/2.0d0 yml=(vy(lb)+vy(la))/2.0d0 rl=dsqrt(dxl*dxl+dyl*dyl) xmm=xmk-xml dx=dxk-dxl ymm=ymk-yml dy=dyk-dyl r=rk+rl a=r*r-dx*dx-dy*dy b=ymm*dx-xmm*dy c=xmm*xmm+ymm*ymm+r*r beta=1.0d0 if(a.gt.0.0d0) beta=(b+dsqrt(b*b+a*c))/a xck=xmk-beta*dyk yck=ymk+beta*dxk xcl=xml-beta*dyl ycl=yml+beta*dxl xmax=(xck*rl+xcl*rk)/r ymax=(yck*rl+ycl*rk)/r endif c c the bisection loop c eps=tol*dmax1(dabs(xmin),dabs(xmax), 1 dabs(ymin),dabs(ymax)) 85 zx=dabs(xmin-xmax)/(dabs(xmin)+dabs(xmax)+eps) zy=dabs(ymin-ymax)/(dabs(ymin)+dabs(ymax)+eps) if(dmax1(zx,zy).lt.tol) then if(icen.eq.0) then vx(i)=xmin vy(i)=ymin else rn=(xm(icen)-xmin)**2+(ym(icen)-ymin)**2 rn=dsqrt(rr/rn) vx(i)=xm(icen)+rn*(xmin-xm(icen)) vy(i)=ym(icen)+rn*(ymin-ym(icen)) endif if(vtype(i).eq.8) then if(icen.eq.0) then vx(ii)=xmin1 vy(ii)=ymin1 else vx(ii)=xm(icen1)+rn*(xmin1-xm(icen1)) vy(ii)=ym(icen1)+rn*(ymin1-ym(icen1)) endif endif else vx(i)=(xmin+xmax)/2.0d0 vy(i)=(ymin+ymax)/2.0d0 if(vtype(i).eq.8) then vx(ii)=(xmin1+xmax1)/2.0d0 vy(ii)=(ymin1+ymax1)/2.0d0 endif qq=1.0d0 kbeg=ks kend=len iv=i do iter=1,jtnum do k=kbeg,kend kb=vlist(k) ka=vlist(k+1) q=geom(iv,kb,ka,vx,vy) if(q.lt.qmin) then xmax=vx(i) ymax=vy(i) if(vtype(i).eq.8) then xmax1=vx(ii) ymax1=vy(ii) endif go to 85 endif qq=dmin1(qq,q) enddo kbeg=len+3 kend=len1 iv=vlist(len+2) enddo xmin=vx(i) ymin=vy(i) if(vtype(i).eq.8) then xmin1=vx(ii) ymin1=vy(ii) endif qmin=qq go to 85 endif 110 continue enddo call cedge5(nbf,itedge,ibedge,0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine geval(i,vx,vy,vlist,tlist,ks,len,lenb,bump, + g,gx,gy,gxx,gxy,gyy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + tlist(*),vlist(*) double precision + vx(*),vy(*),bump(lenb,*) c c compute direction vector using newton direction c ss=2.0d0/3.0d0 g=0.0d0 gx=0.0d0 gy=0.0d0 gxx=0.0d0 gxy=0.0d0 gyy=0.0d0 do k=ks,len k2=vlist(k) k3=vlist(k+1) it=tlist(k) x1=vx(k3)-vx(k2) x2=vx(k2)-vx(i) x3=vx(k3)-vx(i) y1=vy(k3)-vy(k2) y2=vy(k2)-vy(i) y3=vy(k3)-vy(i) c det=x2*y3-x3*y2 detx=y2-y3 dety=x3-x2 c detxx=0.0e0 c detyy=0.0e0 c detxy=0.0e0 c q=x1**2+y1**2+x2**2+y2**2+x3**2+y3**2 qx=-2.0d0*(x2+x3) qy=-2.0d0*(y2+y3) c qxx=4.0e0 c qyy=4.0e0 c qxy=0.0e0 c do j=1,lenb,3 uxx=bump(j,it)*ss uyy=bump(j+1,it)*ss uxy=bump(j+2,it)*ss c r1=uxx*x1**2+2.0d0*uxy*x1*y1+uyy*y1**2 c r1x=0.0e0 c r1y=0.0e0 c r1xx=0.0e0 c r1yy=0.0e0 c r1xy=0.0e0 c r2=uxx*x2**2+2.0d0*uxy*x2*y2+uyy*y2**2 r2x=-2.0d0*(uxx*x2+uxy*y2) r2y=-2.0d0*(uxy*x2+uyy*y2) c r2xx=2.0e0*uxx c r2yy=2.0e0*uyy c r2xy=2.0e0*uxy c r3=uxx*x3**2+2.0d0*uxy*x3*y3+uyy*y3**2 r3x=-2.0d0*(uxx*x3+uxy*y3) r3y=-2.0d0*(uxy*x3+uyy*y3) c r3xx=2.0e0*uxx c r3yy=2.0e0*uyy c r3xy=2.0e0*uxy c s=r1**2+r2**2+r3**2 sx=2.0d0*(r2*r2x+r3*r3x) sy=2.0d0*(r2*r2y+r3*r3y) sxx=2.0d0*(r2x**2+(r2+r3)*2.0d0*uxx+r3x**2) syy=2.0d0*(r2y**2+(r2+r3)*2.0d0*uyy+r3y**2) sxy=2.0d0*(r2x*r2y+(r2+r3)*2.0d0*uxy+r3x*r3y) c f=s*q/det fx=(sx*q+qx*s-f*detx)/det fy=(sy*q+qy*s-f*dety)/det fxx=(4.0d0*s+2.0d0*sx*qx+sxx*q-2.0d0*fx*detx)/det fyy=(4.0d0*s+2.0d0*sy*qy+syy*q-2.0d0*fy*dety)/det fxy=(sx*qy+sy*qx+sxy*q-fx*dety-fy*detx)/det c g=g+f gx=gx+fx gy=gy+fy gxx=gxx+fxx gyy=gyy+fyy gxy=gxy+fxy enddo enddo c* c det=gxx*gyy-gxy**2 c if(det.le.0) then c write(6,*) 'i g',i,det,gxx,gxy,gyy c endif c* return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function stpmx(i,vx,vy,vlist,ks,len,px,py) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vlist(*) double precision + vx(*),vy(*) c c compute maximum step c qmin=0.6d0 stpmx=1.0d0 qq=2.0d0*dsqrt(3.0d0)/qmin do k=ks,len k2=vlist(k) k3=vlist(k+1) x1=vx(k2)-vx(k3) y1=vy(k2)-vy(k3) x2=vx(k2)-vx(i) x3=vx(k3)-vx(i) y2=vy(k2)-vy(i) y3=vy(k3)-vy(i) cn=x1**2+x2**2+x3**2+y1**2+y2**2+y3**2 cd=x2*y3-x3*y2 bn=-(px*(x2+x3)+py*(y2+y3)) bd=(px*y1-py*x1)/2.0d0 a=2.0d0*(px**2+py**2) c=cn-qq*cd b=bn-qq*bd discr=b**2-a*c if(discr.lt.0.0d0) then aa=bd**2 bb=bn*bd-a*cd/2.0d0 cc=bn**2-a*cn if(bb.gt.0.0d0) then rr=(dsqrt(bb**2-aa*cc)+bb)/aa else rr=-cc/(dsqrt(bb**2-aa*cc)-bb) endif ss=(bn-rr*bd)/a else discr=dsqrt(discr) if(b.lt.0.0d0) then r1=(-b+discr)/a r2=c/(-b+discr) else r1=-(b+discr)/a r2=-c/(b+discr) endif ss=dmax1(r1,r2) endif stpmx=dmin1(stpmx,ss) enddo c c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ldbal(ip,itnode,itedge,ibedge,ibndry,vx,vy, + e,p,q,ja,a,ka,jl,z,hist,time,pstat) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),newtag,ka(10,*), 1 ip(100),ibedge(2,*),q(*),p(*),jl(*),oldtag,ja(*), 2 list(1000) double precision + e(*),vx(*),vy(*),z(*),a(*),hist(22,*),pstat(10,*), 1 time(3,*) save mxlst data mxlst/1000/ c c load balancing c call ldinit(ip,itnode,ibndry,p,q) ntf=ip(1) nvf=ip(2) nbf=ip(4) ip(25)=0 c c boundary cases c nproc=ip(49) c******************************* c c ip(29) is used for debugging on one processor c ccc nproc=ip(29) c******************************* log2p=idint(dlog(dfloat(nproc)+0.1d0)/dlog(2.0d0))+1 if(nproc.ge.ntf) then do i=1,ntf itnode(4,i)=i enddo ip(25)=49 go to 50 else if(nproc.le.1) then do i=1,ntf itnode(4,i)=1 enddo go to 50 endif call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,z,jflag) c c scale e to be approx the same size as matrix elements c do i=1,ntf p(i)=i q(i)=i itnode(4,i)=1 enddo c i1=1 i2=i1+2*nproc-1 i3=i2+2*nproc-1 i4=i3+2*nproc-1 c c main loop c do ii=1,log2p mnrgn=2**(ii-1) mxrgn=2*mnrgn-1 call mkjl(ntf,mnrgn,mxrgn,jl,itnode,p,q) mxrgn=min0(mxrgn,nproc-1) do jj=mnrgn,mxrgn c ibeg=jl(jj-mnrgn+1) iend=jl(jj-mnrgn+2)-1 c oldtag=2*jj newtag=oldtag+1 cc call inertl(ibeg,iend,p,e,z(i1),itnode,vx,vy) c c make list of regions c call mklst(ibeg,iend,itedge,itnode,p,q,nr,mxlst,list) c c do eigenvalue problem c do i=1,nr jbeg=list(i) jend=list(i+1)-1 n1=jbeg-ibeg+1 if(jend-jbeg.gt.1) then call timer(time,9) call lbev(jbeg,jend,p,q,itedge,z(n1), + hist,ja,a,ka,ip,jflag) call timer(time,10) endif do j=n1,jend-ibeg+1 z(j)=z(j)+2.0d0*dfloat(i-1) enddo enddo c c split, do crude collapse of tiny regions c call spord(ibeg,iend,z(i1),p,q,itnode,e, + nproc,newtag,oldtag) call rtst(p,q,itnode,itedge,nr,list,e,nproc) enddo c c smoothing c call smth0(ntf,itedge,e,nproc,itnode,z(i1),z(i2), + z(i3),z(i4)) enddo c c shift region numbers to (1,nproc) c do i=1,ntf itnode(4,i)=itnode(4,i)-(nproc-1) enddo c 50 call ldbdy(ip,itnode,ibndry,itedge,ibedge,vx,vy,z) call pstat1(ntf,nproc,pstat,itnode,e,1) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine lbev(ibeg,iend,p,q,itedge,z,hist,ja,a,ka,ip,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itedge(3,*),ihist,ka(10,*),ja(*),ib(2), 1 ip(100) double precision + z(*),hist(22,*),a(*) save ihist data ihist/23/ c c split region into two approximately equal pieces c n=iend-ibeg+1 c c pointers (lenz > 19 n) c lenz=19*n iev0=n+1 irhs=iev0+n idx=irhs+n i1=idx+n i2=i1+n i3=i2+n i4=i3+n img=i4+n c c parameters c itmax=100 tol=1.0d-2 maxlvl=99 maxfil=10 dtol=1.0d-4 c ib(1)=1 ib(2)=n+1 nblock=1 ispd=1 method=0 ncfact=4 c c make ja, a c call mtxasm(ibeg,iend,p,q,ja,a,itedge) iqptr=ja(n+1)+n c c initialize c maxja=ip(18) maxa=ip(19) call mginit(n,ispd,nblock,ib,maxja,ja,maxa,a,ncfact, + maxlvl,maxfil,ka,lvl,dtol,method,lenz,z,iflag) if(iflag.ne.0) return ip(73)=ka(7,lvl)-1 ip(74)=ka(8,lvl)-1 ip(75)=lvl c nn=(n/2)*2 ss=1.0d0/dsqrt(dfloat(nn)) do i=1,nn,2 z(i)=ss z(i+1)=-ss enddo if(nn.ne.n) z(n)=0.0d0 do i=1,n z(iev0+i-1)=0.0d0 enddo c c main iteration loop c ihist=ihist+1 if(ihist.gt.26) ihist=23 call hist1(hist(1,ihist),0,1.0d0) do itnum=1,itmax call tresid(n,ja,a,z,z(irhs),z(idx),ev,bnorm) call hist1(hist(1,ihist),itnum,bnorm) if(bnorm.le.tol) go to 10 call cycle(ispd,lvl,ja,a,z(idx),z(irhs),ka,z(img)) call tev(n,ja,a,z,z(idx),z(iev0),z(i1),z(i2),z(i3)) enddo c c reorder c 10 do i=1,n z(i1+i-1)=z(ja(iqptr+i-1)) enddo do i=1,n z(i)=z(i1+i-1) enddo cc write(6,*) itnum,n,bnorm,ev,ss return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ldinit(ip,itnode,ibndry,p,q) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),p(*),q(*),ip(100) c c initialize for load balance c ntf=ip(1) nbf=ip(4) c c delete interface edges as necessary c do i=1,nbf if(ibndry(4,i).ne.0) then q(i)=1 else if(ibndry(5,i).gt.0) then q(i)=0 else q(i)=1 endif enddo newnbf=0 nn=nbf+1 do i=1,nbf if(q(i).eq.1) then newnbf=newnbf+1 p(newnbf)=i else nn=nn-1 p(nn)=i endif enddo if(nn.ne.newnbf+1) stop 2789 c call border(ip,p,q,ibndry) ip(4)=newnbf c c initialize label fields c do i=1,newnbf ibndry(5,i)=0 enddo do i=1,ntf itnode(4,i)=0 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ldbdy(ip,itnode,ibndry,itedge,ibedge,vx,vy,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),itedge(3,*), 1 ibedge(2,*),index(3,3),list(*) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c ntf=ip(1) nvf=ip(2) nbf=ip(4) maxb=ip(24) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,list,iflag) call cedge5(nbf,itedge,ibedge,1) c c add internal boundary edges c do i=1,nbf ibndry(5,i)=0 enddo newbdy=0 do i=1,ntf irgn=itnode(4,i) do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 if(itnode(4,k).ne.irgn.and.i.lt.k) then newbdy=newbdy+1 endif endif enddo enddo if(newbdy+nbf.gt.maxb) then ip(25)=24 return endif do i=1,ntf irgn=itnode(4,i) do j=1,3 if(itedge(j,i).lt.0) then k=-itedge(j,i) if(ibndry(4,k).eq.0) then m=ibedge(1,k)/4 if(m.eq.i) m=ibedge(2,k)/4 krgn=itnode(4,m) if(krgn.ne.irgn) ibndry(5,k)=-k else if(ibndry(4,k).lt.0) then km=-ibndry(4,k) m=ibedge(1,km)/4 krgn=itnode(4,m) if(krgn.ne.irgn) ibndry(5,k)=-min0(km,k) endif c else k=itedge(j,i)/4 if(itnode(4,k).ne.irgn.and.i.lt.k) then nbf=nbf+1 ibndry(1,nbf)=itnode(index(2,j),i) ibndry(2,nbf)=itnode(index(3,j),i) ibndry(3,nbf)=0 ibndry(4,nbf)=0 ibndry(5,nbf)=nbf ibndry(6,nbf)=0 endif endif enddo enddo ip(4)=nbf ip(70)=nbf+1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mklst(ibeg,iend,itedge,itnode,p,q,nr,mxlst,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),itnode(5,*),p(*),q(*),list(*) c c compute nr, pointer array list c nr=0 do i=ibeg,iend itnode(4,p(i))=-itnode(4,p(i)) enddo iptr=ibeg next=ibeg 10 k=p(next) if(itnode(4,k).lt.0) then nr=nr+1 if(nr+1.gt.mxlst) stop 5671 list(nr)=next itnode(4,k)=-itnode(4,k) iptr=iptr+1 endif next=next+1 do j=1,3 m=itedge(j,k)/4 if(m.gt.0) then if(itnode(4,m).lt.0) then itnode(4,m)=-itnode(4,m) mm=q(m) p(mm)=p(iptr) p(iptr)=m q(p(mm))=mm q(m)=iptr iptr=iptr+1 endif endif enddo if(next.le.iend) go to 10 list(nr+1)=iend+1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkjl(ntf,mnrgn,mxrgn,jl,itnode,p,q) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jl(*),itnode(5,*),p(*),q(*) c c make jl array, order triangles by region c do i=1,mxrgn-mnrgn+2 jl(i)=0 enddo do i=1,ntf ii=itnode(4,i)-mnrgn+2 jl(ii)=jl(ii)+1 enddo jl(1)=1 do i=2,mxrgn-mnrgn+2 jl(i)=jl(i)+jl(i-1) enddo do i=1,ntf ii=itnode(4,i)-mnrgn+1 p(jl(ii))=i q(i)=jl(ii) jl(ii)=jl(ii)+1 enddo do i=mxrgn-mnrgn+2,2,-1 jl(i)=jl(i-1) enddo jl(1)=1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxasm(ibeg,iend,p,q,ja,a,itedge) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),p(*),q(*),itedge(3,*) double precision + a(*) c c construct spectral decomposition matrix c n=iend-ibeg+1 do i=1,n+1 a(i)=0.0d0 enddo c ja(1)=n+2 do i=1,n it=p(i+ibeg-1) next=ja(i) do jj=1,3 jt=itedge(jj,it)/4 if(jt.gt.0) then j=q(jt)-ibeg+1 if(j.gt.i.and.j.le.n) then ja(next)=j a(next)=-1.0d0 a(i)=a(i)+1.0d0 a(j)=a(j)+1.0d0 next=next+1 endif endif enddo ja(i+1)=next enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tresid(n,ja,a,x,b,dx,ev,bnorm) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + x(*),b(*),a(*),dx(*) c c compute linear system for eigenvalue problem c ispd=1 c c rayleigh quotient c call mtxmlt(n,ja,a,x,b,ispd) ev=rl2ip(n,x,b)/rl2nrm(n,x)**2 c c compute right hand side residual c ss=0.0d0 do i=1,n b(i)=ev*x(i)-b(i) ss=ss+b(i) enddo c c make orthogonal to constant c ss=ss/dfloat(n) do i=1,n b(i)=b(i)-ss dx(i)=0.0d0 enddo bnorm=rl2nrm(n,b)/ev return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tev(n,ja,a,ev,dev,ev0,aev,adev,aev0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*) double precision + a(*),ev(*),aev(*),dev(*),adev(*), 1 ev0(*),aev0(*),aa(3,3),r(3),q(3,3) c c orthogonalize c ispd=1 sd=0.0d0 do i=1,n sd=sd+dev(i) enddo sd=sd/dfloat(n) do i=1,n dev(i)=dev(i)-sd enddo call orthog(n,ev,dev,ev0,irank) c call mtxmlt(n,ja,a,ev,aev,ispd) call mtxmlt(n,ja,a,dev,adev,ispd) call mtxmlt(n,ja,a,ev0,aev0,ispd) c c compute inner products for quadratic equation c aa(1,1)=rl2ip(n,ev,aev) aa(1,2)=rl2ip(n,ev,adev) aa(1,3)=rl2ip(n,ev,aev0) aa(2,1)=aa(1,2) aa(2,2)=rl2ip(n,dev,adev) aa(2,3)=rl2ip(n,dev,aev0) aa(3,1)=aa(1,3) aa(3,2)=aa(2,3) aa(3,3)=rl2ip(n,ev0,aev0) call ev3x3(aa,r,q,irank) c c reset ev c ss=0.0d0 s0=0.0d0 do i=1,n s=q(2,1)*dev(i)+q(3,1)*ev0(i) ev(i)=q(1,1)*ev(i)+s ev0(i)=s ss=ss+ev(i) s0=s0+ev0(i) enddo ss=ss/dfloat(n) s0=s0/dfloat(n) do i=1,n ev(i)=ev(i)-ss ev0(i)=ev0(i)-s0 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rtst(p,q,itnode,itedge,nr,list,e,nproc) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itedge(3,*),itnode(5,*),list(*),list0(1000), 1 list1(1000) double precision + e(*) save mxlst data mxlst/1000/ c kbeg=list(1) kend=list(nr+1)-1 ktag0=itnode(4,p(kbeg)) ktag1=itnode(4,p(kend)) nch0=nchild(ktag0,nproc) nch1=nchild(ktag1,nproc) c ecur0=0.0d0 ecur1=0.0d0 ncur0=0 ncur1=0 do k=kbeg,kend if(itnode(4,p(k)).eq.ktag0) then ecur0=ecur0+e(p(k)) ncur0=ncur0+1 else ecur1=ecur1+e(p(k)) ncur1=ncur1+1 endif enddo c do 50 irgn=1,nr ibeg=list(irgn) iend=list(irgn+1)-1 itag0=itnode(4,p(ibeg)) itag1=itnode(4,p(iend)) if(itag0.eq.itag1) go to 50 10 do i=ibeg,iend if(itnode(4,p(i)).eq.itag0) imid=i enddo do i=ibeg,imid if(itnode(4,p(i)).ne.itag0) stop 9155 enddo do i=imid+1,iend if(itnode(4,p(i)).ne.itag1) stop 9156 enddo c c call mklst(ibeg,imid,itedge,itnode,p,q,nr0,mxlst,list0) call mklst(imid+1,iend,itedge,itnode,p,q,nr1,mxlst,list1) if(nr0.eq.1.and.nr1.eq.1) go to 50 c c compute smallest error on each side c e0=ecur0+ecur1 k0=0 do krgn=1,nr0 jbeg=list0(krgn) jend=list0(krgn+1)-1 s=0.0d0 do j=jbeg,jend s=s+e(p(j)) enddo if(s.lt.e0) then e0=s k0=krgn endif enddo e1=ecur0+ecur1 k1=0 do krgn=1,nr1 jbeg=list1(krgn) jend=list1(krgn+1)-1 s=0.0d0 do j=jbeg,jend s=s+e(p(j)) enddo if(s.lt.e0) then e1=s k1=krgn endif enddo c c decide if a swap is possible c if(ecur0.gt.ecur1) then if(nr0.le.1) go to 50 n0=list0(k0+1)-list0(k0) if(ncur0-n0.lt.nch0) go to 50 if(e0.gt.ecur0-ecur1) go to 50 jj=list0(k0) mm=imid do k=1,n0 if(mm.gt.jj) then ii=p(mm) p(mm)=p(jj) p(jj)=ii q(p(mm))=mm q(p(jj))=jj endif itnode(4,p(mm))=itag1 mm=mm-1 jj=jj+1 enddo ncur0=ncur0-n0 ncur1=ncur1+n0 ecur0=ecur0-e0 ecur1=ecur1+e0 go to 10 else if(nr1.le.1) go to 50 n1=list1(k1+1)-list1(k1) if(ncur1-n1.lt.nch1) go to 50 if(e1.gt.ecur1-ecur0) go to 50 jj=list1(k1+1)-1 mm=imid+1 do k=1,n1 if(mm.lt.jj) then ii=p(mm) p(mm)=p(jj) p(jj)=ii q(p(mm))=mm q(p(jj))=jj endif itnode(4,p(mm))=itag1 mm=mm+1 jj=jj-1 enddo ncur0=ncur0+n1 ncur1=ncur1-n1 ecur0=ecur0+e1 ecur1=ecur1-e1 go to 10 endif 50 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine inertl(ibeg,iend,p,e,z,itnode,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),itnode(5,*) double precision + e(*),z(*),vx(*),vy(*) c c compute center of mass c n=iend-ibeg+1 xc=0.0d0 yc=0.0d0 cc=0.0d0 do ii=1,n i=p(ii+ibeg-1) xx=(vx(itnode(1,i))+vx(itnode(2,i))+vx(itnode(3,i)))/3.0d0 yy=(vy(itnode(1,i))+vy(itnode(2,i))+vy(itnode(3,i)))/3.0d0 c* xc=xc+xx c* yc=yc+yy xc=xc+e(i)*xx yc=yc+e(i)*yy cc=cc+e(i) enddo c* xc=xc/float(n) c* yc=yc/float(n) xc=xc/cc yc=yc/cc c c compute inertial tensor c d1=0.0d0 d2=0.0d0 d0=0.0d0 do ii=1,n i=p(ii+ibeg-1) xx=(vx(itnode(1,i))+vx(itnode(2,i))+vx(itnode(3,i)))/3.0d0 + -xc yy=(vy(itnode(1,i))+vy(itnode(2,i))+vy(itnode(3,i)))/3.0d0 + -yc c* d1=d1+yy**2 c* d0=d0-xx*yy c* d2=d2+xx**2 d1=d1+e(i)*yy**2 d0=d0-e(i)*xx*yy d2=d2+e(i)*xx**2 enddo c c solve 2x2 eigenvalue problem c b=(d1+d2)/2.0d0 c0=dmax1(d1*d2-d0*d0,0.0d0) d=(d1-d2)/2.0d0 d=dsqrt(d*d+d0*d0) r1=c0/(b+d) c c compute eigenvector c if(dabs(d1-r1).gt.dabs(d2-r1)) then v1=d0 v2=r1-d1 else v1=r1-d2 v2=d0 end if ss=dsqrt(v1**2+v2**2) v1=v1/ss v2=v2/ss c c compute initial guess for z c do ii=1,n i=p(ii+ibeg-1) xx=(vx(itnode(1,i))+vx(itnode(2,i))+vx(itnode(3,i)))/3.0d0 + -xc yy=(vy(itnode(1,i))+vy(itnode(2,i))+vy(itnode(3,i)))/3.0d0 + -yc z(ii)=xx*v1+yy*v2 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine spord(ibeg,iend,z,p,q,itnode,e,nproc,newtag,oldtag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),newtag,oldtag,itnode(5,*) double precision + z(*),e(*) c c n=iend-ibeg+1 snew=0.0d0 sold=0.0d0 nnew=0 nold=0 c nn=n/2 do i=nn,1,-1 call mkheap(i,n,z,p(ibeg)) enddo do i=n,2,-1 i1=p(ibeg+i-1) p(ibeg+i-1)=p(ibeg) p(ibeg)=i1 z1=z(i) z(i)=z(1) z(1)=z1 call mkheap(1,i-1,z,p(ibeg)) enddo c c do i=ibeg,iend q(p(i))=i enddo c c iptr=ibeg knew=nchild(newtag,nproc) nbeg=knew+1 do ii=1,knew i=p(iptr) iptr=iptr+1 itnode(4,i)=newtag snew=snew+e(i) nnew=nnew+1 enddo c jptr=iend kold=nchild(oldtag,nproc) nend=n-kold do ii=1,kold i=p(jptr) jptr=jptr-1 itnode(4,i)=oldtag sold=sold+e(i) nold=nold+1 enddo c tnew=dfloat(knew) told=dfloat(kold) do ii=nbeg,nend if(snew*told.lt.tnew*sold) then i=p(iptr) iptr=iptr+1 itnode(4,i)=newtag snew=snew+e(i) nnew=nnew+1 else i=p(jptr) jptr=jptr-1 itnode(4,i)=oldtag sold=sold+e(i) nold=nold+1 endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- integer function nchild(k,n) c implicit double precision (a-h,o-z) implicit integer (i-n) c c if(k.le.0.or.k.ge.2*n) then nchild=0 return else if(k.ge.n) then nchild=1 return endif a=dlog(2.0d0) q=dlog(dfloat(n)+0.1d0)/a nl=idint(q) q=dlog(dfloat(k)+0.1d0)/a kl=idint(q) nchild=0 c c do level nl c k1=2**(nl-kl)*k k2=2**(nl-kl)*(k+1)-1 n1=n n2=2**(nl+1)-1 if(k2.ge.n1) then if (k1.gt.n1) then nchild=k2-k1+1 else nchild=k2-n1+1 endif endif c c do level nl+1 c k1=2*k1 k2=2*k2+1 n1=n2+1 n2=2*n-1 if(k1.le.n2) then if(k2.lt.n2) then nchild=nchild+k2-k1+1 else nchild=nchild+n2-k1+1 endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine smth0(ntf,itedge,e,nproc,itnode,wt,iwt,ichild,wtrgt) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),itnode(5,*),index(3,3),iwt(*), 1 ichild(*),itst(3),tag(3) double precision + e(*),wt(*),wtrgt(*) save index data index/1,2,3,2,3,1,3,1,2/ c itmax=20 theta=1.15d0 c c initialize wt,iwt c do i=1,2*nproc-1 wt(i)=0.0d0 iwt(i)=0 ichild(i)=nchild(i,nproc) enddo wtot=0.0d0 do i=1,ntf j=itnode(4,i) wt(j)=wt(j)+e(i) iwt(j)=iwt(j)+1 wtot=wtot+e(i) enddo do i=1,2*nproc-1 wtrgt(i)=wtot*dfloat(ichild(i))/dfloat(nproc) enddo c c the main loop c do itnum=1,itmax ichng=0 do 20 i=1,ntf itag=itnode(4,i) if(iwt(itag).le.ichild(itag)) go to 20 if(wt(itag).lt.wtrgt(itag)) go to 20 inum=0 ibdy=0 ii=0 do j=1,3 k=itedge(j,i)/4 if(k.le.0) then tag(j)=0 ibdy=ibdy+1 else tag(j)=itnode(4,k) if(tag(j).eq.itag) then inum=inum+1 ii=j endif endif enddo c c exclude obvious cases c if(ibdy+inum.ge.3) go to 20 if(inum.ge.2) go to 20 ibest=1 do j=1,3 itst(j)=-1 if(tag(j).ne.itag.and.tag(j).ne.0) then c c see if relative load balance is improved c gold=dmax1(dabs(wt(itag)-wtrgt(itag)), + dabs(wt(tag(j))-wtrgt(tag(j)))) gnew=dmax1(dabs(wt(itag)-e(i)-wtrgt(itag)), + dabs(wt(tag(j))+e(i)-wtrgt(tag(j)))) if(gnew.lt.gold) itst(j)=itst(j)+2 c c check load balance bounds c if(wt(itag)-e(i).ge.wtrgt(itag)/theta.and. + wt(tag(j))+e(i).le.wtrgt(tag(j))*theta) 1 itst(j)=itst(j)+1 endif if(itst(j).gt.itst(ibest)) ibest=j enddo if(inum.eq.0) then if(itst(ibest).le.0) go to 20 else if(tag(index(2,ii)).eq.tag(index(3,ii))) then if(itst(ibest).lt.0) go to 20 else if(itst(ibest).le.0) go to 20 endif endif ichng=ichng+1 jtag=tag(ibest) iwt(itag)=iwt(itag)-1 iwt(jtag)=iwt(jtag)+1 wt(itag)=wt(itag)-e(i) wt(jtag)=wt(jtag)+e(i) itnode(4,i)=jtag 20 continue if(ichng.eq.0) return enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cutr(ip,itnode,ibndry,vx,vy,e,p,q,befor,after, + itedge,ibedge,maxv,gf,icutsw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),p(*),q(*),itedge(3,*), 1 ibedge(2,*),index(3,3),befor(*),after(*) double precision + vx(*),vy(*),gf(maxv,*),e(*) save index data index/1,2,3,2,3,1,3,1,2/ c c p=3*ntf p/q are overlayed c ntf=ip(1) nvf=ip(2) nbf=ip(4) irgn=ip(50) ibase=ip(70) mbase=max0(nbf,ibase) c c order triangles in region irgn first c newntf=0 do i=1,ntf if(itnode(4,i).eq.irgn) then newntf=newntf+1 do j=1,5 ii=itnode(j,newntf) itnode(j,newntf)=itnode(j,i) itnode(j,i)=ii enddo ee=e(newntf) e(newntf)=e(i) e(i)=ee endif enddo c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,p,iflag) c c insure proper orientation of edges c call cedge5(nbf,itedge,ibedge,1) do i=1,ntf do j=1,3 if(itedge(j,i).lt.0) then k=-itedge(j,i) ibndry(1,k)=itnode(index(2,j),i) ibndry(2,k)=itnode(index(3,j),i) if(ibndry(4,k).eq.0.and.itnode(4,i).ne.irgn) then if(ibedge(1,k)/4.ne.i) then ii=ibedge(1,k)/4 jj=ibedge(1,k)-4*ii else ii=ibedge(2,k)/4 jj=ibedge(2,k)-4*ii endif if(itnode(4,ii).eq.irgn) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) else if(itnode(4,ii).lt.itnode(4,i)) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) endif endif endif enddo enddo c c mark edges c do i=1,nbf p(i)=i if(ibndry(4,i).gt.0) then k1=ibedge(1,i)/4 krgn=itnode(4,k1) if(krgn.eq.irgn) then q(i)=1 else q(i)=0 endif else if(ibndry(4,i).eq.0) then k1=ibedge(1,i)/4 k2=ibedge(2,i)/4 k1rgn=itnode(4,k1) k2rgn=itnode(4,k2) if(k1rgn.ne.k2rgn) then if(k1rgn.eq.irgn.or.k2rgn.eq.irgn) then q(i)=2 else q(i)=3 endif else if(k1rgn.eq.irgn) then q(i)=1 else q(i)=0 endif endif else k1=ibedge(1,i)/4 j=-ibndry(4,i) k2=ibedge(1,j)/4 k1rgn=itnode(4,k1) k2rgn=itnode(4,k2) if(k1rgn.ne.k2rgn) then if(k1rgn.eq.irgn) then q(i)=2 else if(k2rgn.eq.irgn) then q(i)=0 else if(k1rgn.lt.k2rgn) then q(i)=3 else q(i)=0 endif else if(k1rgn.eq.irgn) then q(i)=1 else q(i)=0 endif endif endif endif enddo c c reorder ibndry c nbb=0 do ii=1,nbf i=p(ii) if(q(i).eq.2) then nbb=nbb+1 p(ii)=p(nbb) p(nbb)=i endif enddo newnbf=nbb do ii=nbb+1,nbf i=p(ii) if(q(i).eq.1) then newnbf=newnbf+1 p(ii)=p(newnbf) p(newnbf)=i endif enddo nbi=newnbf do ii=newnbf+1,nbf i=p(ii) if(q(i).eq.3) then nbi=nbi+1 p(ii)=p(nbi) p(nbi)=i endif enddo c c reorder edges c call border(ip,p,q,ibndry) c c sort interfrace entries according to label c do i=1,mbase p(i)=0 enddo do i=1,nbb jj=iabs(ibndry(5,i)) jj=jj-(jj/ibase)*ibase p(jj)=p(jj)+1 enddo ii=1 do i=1,mbase jj=p(i) p(i)=ii ii=jj+ii enddo do i=1,nbb jj=iabs(ibndry(5,i)) jj=jj-(jj/ibase)*ibase q(i)=p(jj) p(jj)=p(jj)+1 enddo c c the rest of the interface edges c do i=1,mbase p(i)=0 enddo do i=newnbf+1,nbi jj=iabs(ibndry(5,i)) jj=jj-(jj/ibase)*ibase p(jj)=p(jj)+1 enddo ii=newnbf+1 do i=1,mbase jj=p(i) p(i)=ii ii=jj+ii enddo do i=newnbf+1,nbi jj=iabs(ibndry(5,i)) jj=jj-(jj/ibase)*ibase q(i)=p(jj) p(jj)=p(jj)+1 enddo c c do i=1,nbb p(q(i))=i enddo do i=nbb+1,newnbf p(i)=i enddo do i=newnbf+1,nbi p(q(i))=i enddo do i=nbi+1,nbf p(i)=i enddo call border(ip,p,q,ibndry) c c collect interface edges in consecutive entries c if(nbb.gt.0) then q(1)=1 nedge=1 do i=2,nbb ii=iabs(ibndry(5,i)) ii=ii-(ii/ibase)*ibase im=iabs(ibndry(5,i-1)) im=im-(im/ibase)*ibase if(ii.ne.im) then nedge=nedge+1 q(nedge)=i endif enddo else nedge=0 endif q(nedge+1)=nbb+1 if(nbi.gt.newnbf) then q(nedge+2)=newnbf+1 medge=nedge+2 do i=newnbf+2,nbi ii=iabs(ibndry(5,i)) ii=ii-(ii/ibase)*ibase im=iabs(ibndry(5,i-1)) im=im-(im/ibase)*ibase if(ii.ne.im) then medge=medge+1 q(medge)=i endif enddo else medge=nedge+1 endif q(medge+1)=nbi+1 c do i=1,nvf after(i)=0 befor(i)=0 enddo c c now order edges with the same label c do kk=1,2 if(kk.eq.1) then istart=1 iend=nedge else istart=nedge+2 iend=medge endif do iedge=istart,iend i1=q(iedge) i2=q(iedge+1)-1 do i=i1,i2 after(ibndry(1,i))=i befor(ibndry(2,i))=i enddo ii=0 do i=i1,i2 if(befor(ibndry(1,i)).eq.0) ii=i enddo if(ii.eq.0) stop 7891 p(i1)=ii do i=i1+1,i2 j=p(i-1) p(i)=after(ibndry(2,j)) enddo do i=i1,i2 after(ibndry(1,i))=0 befor(ibndry(2,i))=0 enddo enddo enddo c c do i=nbb+1,newnbf p(i)=i enddo do i=nbi+1,nbf p(i)=i enddo call border(ip,p,q,ibndry) c c mark vertices c do i=1,nvf p(i)=i q(i)=0 enddo do i=1,newntf do j=1,3 q(itnode(j,i))=2 enddo enddo do i=1,nbb q(ibndry(1,i))=3 q(ibndry(2,i))=3 enddo do i=newnbf+1,nbi if(q(ibndry(1,i)).eq.0) q(ibndry(1,i))=1 if(q(ibndry(2,i)).eq.0) q(ibndry(2,i))=1 enddo nvi=0 do k=3,1,-1 do ii=1,nvf i=p(ii) if(q(i).eq.k) then nvi=nvi+1 p(ii)=p(nvi) p(nvi)=i endif enddo if(k.eq.3) nvv=nvi if(k.eq.2) newnvf=nvi enddo c do i=1,nvf q(p(i))=i enddo nn=0 do i=1,nbb do j=1,2 ii=q(ibndry(j,i)) if(ii.gt.nn) then nn=nn+1 p(ii)=p(nn) p(nn)=ibndry(j,i) q(p(nn))=nn q(p(ii))=ii endif enddo enddo nn=newnvf do i=newnbf+1,nbi do j=1,2 ii=q(ibndry(j,i)) if(ii.gt.nn) then nn=nn+1 p(ii)=p(nn) p(nn)=ibndry(j,i) q(p(nn))=nn q(p(ii))=ii endif enddo enddo c call vorder(ip,p,q,itnode,ibndry,vx,vy,gf,maxv) c ip(31)=newntf ip(32)=newnvf ip(33)=newnbf ip(34)=nvv ip(35)=nbb ip(36)=nvi ip(37)=nbi c c if we just want to organize the data return c if(icutsw.eq.1) return c c set artificial boundary conditions c do i=1,nbb if(ibndry(4,i).eq.0) then if(ibndry(5,i).gt.0) then ibndry(4,i)=3 else ibndry(4,i)=4 endif else ibndry(4,i)=5 endif enddo c ip(1)=newntf ip(2)=newnvf ip(4)=newnbf if(ip(7).lt.0.or.ip(7).gt.ip(2)) ip(7)=0 ip(31)=ntf ip(32)=nvf ip(33)=nbf c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cutr2(ip,itnode,ibndry,vx,vy,p,q,befor,after, + itedge,ibedge,gf) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),p(*),q(*),itedge(3,*), 1 ibedge(2,*),index(3,3),befor(*),after(*) double precision + vx(*),vy(*),gf(*) save index data index/1,2,3,2,3,1,3,1,2/ c ntf=ip(1) nvf=ip(2) nbf=ip(4) newntf=ip(31) newnvf=ip(32) newnbf=ip(33) nvi=ip(36) nbi=ip(37) maxv=ip(22) irgn=ip(50) ibase=ip(70) mbase=max0(nbf,ibase) c c insure proper orientation c do i=newntf+1,ntf do j=1,3 if(itedge(j,i).lt.0) then k=-itedge(j,i) ibndry(1,k)=itnode(index(2,j),i) ibndry(2,k)=itnode(index(3,j),i) if(ibndry(4,k).eq.0.and.itnode(4,i).ne.irgn) then if(ibedge(1,k)/4.ne.i) then ii=ibedge(1,k)/4 jj=ibedge(1,k)-4*ii else ii=ibedge(2,k)/4 jj=ibedge(2,k)-4*ii endif if(itnode(4,ii).eq.irgn) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) else if(itnode(4,ii).lt.itnode(4,i)) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) endif endif endif enddo enddo c c do i=1,nbf p(i)=i enddo nbisv=nbi do ii=nbisv+1,nbf i=p(ii) if(ibndry(4,i).eq.0) then k1=ibedge(1,i)/4 k2=ibedge(2,i)/4 k1rgn=itnode(4,k1) k2rgn=itnode(4,k2) if(k1rgn.ne.k2rgn) then nbi=nbi+1 p(i)=p(nbi) p(nbi)=i endif else if(ibndry(4,i).lt.0) then k1=ibedge(1,i)/4 j=-ibndry(4,i) k2=ibedge(1,j)/4 k1rgn=itnode(4,k1) k2rgn=itnode(4,k2) ksw=0 if(irgn.eq.k1rgn) ksw=1 if(irgn.eq.k2rgn) ksw=1 if(k1rgn.ge.k2rgn) ksw=1 if(ksw.eq.0) then nbi=nbi+1 p(ii)=p(nbi) p(nbi)=i endif endif enddo call border(ip,p,q,ibndry) c c the rest of the interface edges c do i=1,mbase p(i)=0 enddo do i=newnbf+1,nbi jj=iabs(ibndry(5,i)) jj=jj-(jj/ibase)*ibase p(jj)=p(jj)+1 enddo ii=newnbf+1 do i=1,mbase jj=p(i) p(i)=ii ii=jj+ii enddo do i=newnbf+1,nbi jj=iabs(ibndry(5,i)) jj=jj-(jj/ibase)*ibase q(i)=p(jj) p(jj)=p(jj)+1 enddo do i=1,nbf p(i)=i enddo do i=newnbf+1,nbi p(q(i))=i enddo call border(ip,p,q,ibndry) c c collect interface edges in consecutive entries c do i=1,nvf after(i)=0 befor(i)=0 enddo nedge=1 q(1)=newnbf+1 do i=newnbf+2,nbi ii=iabs(ibndry(5,i)) ii=ii-(ii/ibase)*ibase im=iabs(ibndry(5,i-1)) im=im-(im/ibase)*ibase if(ii.ne.im) then nedge=nedge+1 q(nedge)=i endif enddo q(nedge+1)=nbi+1 c c now order edges with the same label c do i=1,nbf p(i)=i enddo do iedge=1,nedge i1=q(iedge) i2=q(iedge+1)-1 do i=i1,i2 after(ibndry(1,i))=i befor(ibndry(2,i))=i enddo ii=0 do i=i1,i2 if(befor(ibndry(1,i)).eq.0) ii=i enddo if(ii.eq.0) stop 7894 p(i1)=ii do i=i1+1,i2 j=p(i-1) p(i)=after(ibndry(2,j)) enddo do i=i1,i2 after(ibndry(1,i))=0 befor(ibndry(2,i))=0 enddo enddo call border(ip,p,q,ibndry) c c mark vertices c do i=1,nvf p(i)=i q(i)=0 enddo do i=newnbf+1,nbi if(q(ibndry(1,i)).eq.0) q(ibndry(1,i))=1 if(q(ibndry(2,i)).eq.0) q(ibndry(2,i))=1 enddo nvi=newnvf do ii=newnvf+1,nvf i=p(ii) if(q(i).eq.1) then nvi=nvi+1 p(ii)=p(nvi) p(nvi)=i endif enddo c do i=1,nvf q(p(i))=i enddo nn=newnvf do i=newnbf+1,nbi do j=1,2 ii=q(ibndry(j,i)) if(ii.gt.nn) then nn=nn+1 p(ii)=p(nn) p(nn)=ibndry(j,i) q(p(nn))=nn q(p(ii))=ii endif enddo enddo if(nn.ne.nvi) stop 7621 call vorder(ip,p,q,itnode,ibndry,vx,vy,gf,maxv) c ip(36)=nvi ip(37)=nbi c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkpth(ip,irgn,ipath,ibndry,itree,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipath(4,*),ibndry(6,*),ip(100),itree(2,*),list(*) c c pointer section 1 -- nproc+2 (nproc+2 is global) c c ipath(1,*) first interface vertex for irgn c mxlab/0 for nproc+2 c ipath(2,*) last interface vertex for irgn c ipath(3,*) first interface tree entry for irgn c ipath(4,*) last interface tree entry for irgn c c tree section c root root/leaf internal leaf c ipath(1,*) e1 v1 e1 v1 c ipath(2,*) e2 v2 e2 v2 c ipath(3,*) -l/n -l/n 0/n 0/n c ipath(4,*) son -e son -e c nproc=ip(49) nvv=ip(34) nbb=ip(35) ntf=ip(1) nbf=ip(4) ibase=ip(70) maxpth=ip(81) if(irgn.gt.0) then do i=1,nproc+2 ipath(1,i)=0 ipath(2,i)=-1 ipath(3,i)=0 ipath(4,i)=-1 enddo len=nbb istart=nproc+3 else len=nbf istart=3 endif c nseg=istart-1 k=1 10 if(k.gt.len) go to 20 itest=1 if(irgn.eq.0.and.ibndry(4,k).lt.3) itest=0 if(itest.eq.1) then nseg=nseg+1 if(nseg.gt.maxpth) then ip(25)=72 return endif istrt=ibndry(1,k) last=ibndry(2,k) lab=iabs(ibndry(5,k)) lab=lab-(lab/ibase)*ibase ipath(1,nseg)=k ipath(3,nseg)=-lab ipath(4,nseg)=0 do i=k+1,len+1 isw=0 ilab=iabs(ibndry(5,i)) ilab=ilab-(ilab/ibase)*ibase if(i.gt.len) then isw=1 else if(ibndry(1,i).ne.last) then isw=1 else if(ilab.ne.lab) then isw=1 else if(ibndry(2,i).eq.istrt) then last=0 else last=ibndry(2,i) endif if(isw.eq.1) then ipath(2,nseg)=i-1 k=i go to 10 endif enddo else k=k+1 go to 10 endif c c find max label c 20 mxlab=0 do iseg=istart,nseg mxlab=max0(mxlab,-ipath(3,iseg)) enddo c c now make tree c nlen=3*ntf/2 do i=1,nlen itree(1,i)=0 enddo istop=nseg do jseg=istart,istop ie1=ipath(1,jseg) ie2=ipath(2,jseg) c c initialize c len=0 do i=ie1,ie2 it=iabs(ibndry(5,i))/ibase+1 c c this could happen but the chances are remote c if(it.gt.nlen) stop 2112 itree(1,it)=i itree(2,it)=i len=len+1 list(len)=it enddo c c compute itree, starting a leaves ending at root c if(len.le.1) go to 40 i=0 30 i=i+1 it=list(i) ifath=it/2 is=itree(1,ifath) if(is.eq.0) then itree(1,ifath)=it else itree(1,ifath)=min0(itree(1,is),itree(1,it)) itree(2,ifath)=max0(itree(2,is),itree(2,it)) if(ifath.eq.1) go to 40 len=len+1 list(len)=ifath endif go to 30 c c set up tree in ipath c 40 iseg=jseg-1 ipath(4,jseg)=1 50 iseg=iseg+1 if(iseg.gt.nseg) go to 60 if(ipath(1,iseg).ne.ipath(2,iseg)) then if(nseg+2.gt.maxpth) then ip(25)=72 return endif it=ipath(4,iseg) ison=2*it if(itree(1,ison).lt.itree(1,ison+1)) then ison1=ison+1 else ison1=ison ison=ison+1 endif do i=1,2 ipath(1,nseg+i)=itree(1,ison) ipath(2,nseg+i)=itree(2,ison) ipath(3,nseg+i)=0 ipath(4,nseg+i)=ison itree(1,ison)=0 ison=ison1 enddo c ipath(4,iseg)=nseg+1 if(iseg.eq.jseg) iseg=nseg nseg=nseg+2 else ib=ipath(1,iseg) ipath(1,iseg)=ibndry(1,ib) ipath(2,iseg)=ibndry(2,ib) ipath(4,iseg)=-ib if(iseg.eq.jseg) go to 60 endif go to 50 60 itree(1,1)=0 enddo c if(irgn.gt.0) then ipath(1,irgn)=1 ipath(2,irgn)=nvv ipath(3,irgn)=istart ipath(4,irgn)=nseg c ipath(1,nproc+2)=mxlab ipath(2,nproc+2)=nvv ipath(3,nproc+2)=istart ipath(4,nproc+2)=nseg else ipath(1,1)=mxlab ipath(2,1)=nvv ipath(3,1)=istart ipath(4,1)=nseg ipath(1,2)=mxlab ipath(2,2)=nvv ipath(3,2)=istart ipath(4,2)=nseg endif ip(71)=nvv ip(72)=nseg do i=istart,nseg if(ipath(4,i).gt.0) then ipath(1,i)=ibndry(1,ipath(1,i)) ipath(2,i)=ibndry(2,ipath(2,i)) endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine spth(nproc,irgn,ipath,ipath0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipath(4,*),ipath0(4,*) c c order irgn last in ipath c do i=1,ipath(4,nproc+2) do j=1,4 ipath0(j,i)=ipath(j,i) enddo enddo c c ipath(4,nproc+2)=ipath(3,nproc+2)-1 do 20 i=1,nproc if(i.eq.irgn) go to 20 ipath(3,i)=ipath(4,nproc+2)+1 jb0=ipath(3,i)-ipath0(3,i) ipath(4,i)=ipath0(4,i)+jb0 ipath(4,nproc+2)=ipath(4,i) c do j=ipath(3,i),ipath(4,i) do k=1,4 ipath(k,j)=ipath0(k,j-jb0) enddo if(ipath(4,j).gt.0) ipath(4,j)=ipath(4,j)+jb0 enddo 20 enddo c ipath(3,irgn)=ipath(4,nproc+2)+1 jb0=ipath(3,irgn)-ipath0(3,irgn) ipath(4,irgn)=ipath0(4,irgn)+jb0 ipath(4,nproc+2)=ipath(4,irgn) c do j=ipath(3,irgn),ipath(4,irgn) do k=1,4 ipath(k,j)=ipath0(k,j-jb0) enddo if(ipath(4,j).gt.0) ipath(4,j)=ipath(4,j)+jb0 enddo c c fixup neighbors if present c do i=1,nproc do j=ipath0(3,i),ipath0(4,i) ipath0(1,j)=i enddo enddo do i=1,nproc do j=ipath(3,i),ipath(4,i) if(ipath(3,j).gt.0) then k=ipath0(1,ipath(3,j)) ipath(3,j)=ipath(3,j)+ipath(3,k)-ipath0(3,k) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine matchp(nproc,ipath,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipath(4,*),list(*) c c sort and match the tree roots c mxlab=ipath(1,nproc+2) if(mxlab.le.0) return do i=1,mxlab list(i)=0 enddo do 10 iseg=ipath(3,nproc+2),ipath(4,nproc+2) if(ipath(3,iseg).ge.0) go to 10 lab=iabs(ipath(3,iseg)) if(list(lab).eq.0) then list(lab)=iseg else jseg=list(lab) ipath(3,iseg)=jseg ipath(3,jseg)=iseg endif 10 enddo c c now match children c do 20 iseg=ipath(3,nproc+2),ipath(4,nproc+2) ison=ipath(4,iseg) if(ison.le.0) go to 20 if(ipath(3,ison).gt.0) go to 20 jseg=ipath(3,iseg) if(jseg.le.0) go to 20 if(ipath(3,jseg).ne.iseg) stop 2370 json=ipath(4,jseg) if(json.le.0) go to 20 ipath(3,ison)=json+1 ipath(3,ison+1)=json ipath(3,json)=ison+1 ipath(3,json+1)=ison 20 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mrgpth(ip,ipath,ipath0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipath(4,*),ipath0(4,*),ip(100) c c merge ipath0 into ipath c nproc=ip(49) do 20 i=1,nproc if(ipath0(1,i).eq.0) go to 20 if(ipath(1,i).ne.0) go to 20 c ipath(1,i)=ipath(2,nproc+2)+1 n0=ipath(1,i)-ipath0(1,i) ipath(2,i)=ipath0(2,i)+n0 ipath(2,nproc+2)=ipath(2,i) c ipath(3,i)=ipath(4,nproc+2)+1 jb0=ipath(3,i)-ipath0(3,i) ipath(4,i)=ipath0(4,i)+jb0 ipath(4,nproc+2)=ipath(4,i) c do j=ipath(3,i),ipath(4,i) do k=1,4 ipath(k,j)=ipath0(k,j-jb0) enddo if(ipath(4,j).gt.0) then ipath(4,j)=ipath(4,j)+jb0 else ipath(1,j)=ipath(1,j)+n0 ipath(2,j)=ipath(2,j)+n0 endif enddo 20 enddo ipath(1,nproc+2)=max0(ipath(1,nproc+2),ipath0(1,nproc+2)) ip(71)=ipath(2,nproc+2) ip(72)=ipath(4,nproc+2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkpthi(ip,ipath,ibndry,itree,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipath(4,*),ibndry(6,*),ip(100),itree(2,*),list(*) c c nproc=ip(49) irgn=ip(50) newnvf=ip(32) newnbf=ip(33) ntf=ip(1) nvi=ip(36) nbi=ip(37) ibase=ip(70) maxpth=ip(81) mxlab=ipath(1,nproc+2) nvv=ipath(2,nproc+2) c istart=ipath(4,nproc+2)+1 nseg=istart-1 k=newnbf+1 10 if(k.gt.nbi) go to 20 itest=1 if(irgn.eq.0.and.ibndry(4,k).lt.3) itest=0 if(itest.eq.1) then nseg=nseg+1 if(nseg.gt.maxpth) then ip(25)=72 return endif istrt=ibndry(1,k) last=ibndry(2,k) lab=iabs(ibndry(5,k)) lab=lab-(lab/ibase)*ibase ipath(1,nseg)=k ipath(3,nseg)=-lab ipath(4,nseg)=0 do i=k+1,nbi+1 isw=0 ilab=iabs(ibndry(5,i)) ilab=ilab-(ilab/ibase)*ibase if(i.gt.nbi) then isw=1 else if(ibndry(1,i).ne.last) then isw=1 else if(ilab.ne.lab) then isw=1 else if(ibndry(2,i).eq.istrt) then last=0 else last=ibndry(2,i) endif if(isw.eq.1) then ipath(2,nseg)=i-1 k=i go to 10 endif enddo else k=k+1 go to 10 endif c c now make tree c 20 nlen=3*ntf/2 do i=1,nlen itree(1,i)=0 enddo istop=nseg do jseg=istart,istop ie1=ipath(1,jseg) ie2=ipath(2,jseg) c c initialize c len=0 do i=ie1,ie2 it=iabs(ibndry(5,i))/ibase+1 c c this could happen but the chances are remote c if(it.gt.nlen) stop 2112 itree(1,it)=i itree(2,it)=i len=len+1 list(len)=it enddo c c compute itree, starting a leaves ending at root c if(len.le.1) go to 40 i=0 30 i=i+1 it=list(i) ifath=it/2 is=itree(1,ifath) if(is.eq.0) then itree(1,ifath)=it else itree(1,ifath)=min0(itree(1,is),itree(1,it)) itree(2,ifath)=max0(itree(2,is),itree(2,it)) if(ifath.eq.1) go to 40 len=len+1 list(len)=ifath endif go to 30 c c set up tree in ipath c 40 iseg=jseg-1 ipath(4,jseg)=1 50 iseg=iseg+1 if(iseg.gt.nseg) go to 60 if(ipath(1,iseg).ne.ipath(2,iseg)) then if(nseg+2.gt.maxpth) then ip(25)=72 return endif it=ipath(4,iseg) ison=2*it if(itree(1,ison).lt.itree(1,ison+1)) then ison1=ison+1 else ison1=ison ison=ison+1 endif do i=1,2 ipath(1,nseg+i)=itree(1,ison) ipath(2,nseg+i)=itree(2,ison) ipath(3,nseg+i)=0 ipath(4,nseg+i)=ison itree(1,ison)=0 ison=ison1 enddo c ipath(4,iseg)=nseg+1 if(iseg.eq.jseg) iseg=nseg nseg=nseg+2 else ib=ipath(1,iseg) ipath(1,iseg)=ibndry(1,ib)-newnvf+nvv ipath(2,iseg)=ibndry(2,ib)-newnvf+nvv ipath(4,iseg)=-ib if(iseg.eq.jseg) go to 60 endif go to 50 60 itree(1,1)=0 enddo c ipath(1,nproc+1)=nvv+1 ipath(2,nproc+1)=nvv+(nvi-newnvf) ipath(3,nproc+1)=istart ipath(4,nproc+1)=nseg do i=istart,nseg if(ipath(4,i).gt.0) then ipath(1,i)=ibndry(1,ipath(1,i))+nvv-newnvf ipath(2,i)=ibndry(2,ipath(2,i))+nvv-newnvf endif if(ipath(1,i).le.nvv) ipath(1,i)=0 if(ipath(2,i).le.nvv) ipath(2,i)=0 enddo ip(72)=nseg c c one way match of coarse edges to fine grid interface c do i=1,mxlab list(i)=0 enddo do jrgn=1,nproc do iseg=ipath(3,jrgn),ipath(4,jrgn) if(ipath(3,iseg).lt.0) then lab=-ipath(3,iseg) list(lab)=iseg endif enddo enddo do iseg=ipath(3,nproc+1),ipath(4,nproc+1) if(ipath(3,iseg).lt.0) then lab=-ipath(3,iseg) ipath(3,iseg)=list(lab) endif enddo do 70 iseg=ipath(3,nproc+1),ipath(4,nproc+1) ison=ipath(4,iseg) if(ison.le.0) go to 70 if(ipath(3,ison).gt.0) go to 70 jseg=ipath(3,iseg) if(jseg.le.0) go to 70 json=ipath(4,jseg) if(json.gt.0) then ipath(3,ison)=json+1 ipath(3,ison+1)=json endif 70 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cequv2(nproc,ipath,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + iequv(*),ipath(4,*) c c compute iequv array c c** nn=ipath(2,nproc+2) nn=ipath(2,nproc+1) do i=1,nn iequv(i)=i enddo do 60 iseg=ipath(3,nproc+2),ipath(4,nproc+2) if(ipath(4,iseg).ge.0) go to 60 jseg=ipath(3,iseg) if(jseg.le.0) stop 5890 if(ipath(3,jseg).ne.iseg) stop 5891 if(ipath(4,jseg).ge.0) stop 5892 do 50 mm=1,2 iv=ipath(mm,iseg) jv=ipath(3-mm,jseg) it=iv 40 it=iequv(it) if(it.eq.jv) go to 50 if(it.ne.iv) go to 40 it=iequv(iv) iequv(iv)=iequv(jv) iequv(jv)=it 50 continue 60 enddo c do 90 iseg=ipath(3,nproc+1),ipath(4,nproc+1) c*** if(ipath(4,iseg).ge.0) go to 90 jseg=ipath(3,iseg) if(jseg.le.0) go to 90 do 80 mm=1,2 iv=ipath(mm,iseg) if(iv.le.0) go to 80 jv=ipath(3-mm,jseg) it=iv 70 it=iequv(it) if(it.eq.jv) go to 80 if(it.ne.iv) go to 70 it=iequv(iv) iequv(iv)=iequv(jv) iequv(jv)=it 80 continue 90 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setgr2(irgn,nproc,ntf,nbf,nvv,newnvf,nvi,itnode, + ibndry,ibedge,iequv,ipath,jequv,ja,maxja,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ipath(4,*),itnode(5,*),iequv(*),index(3,3), 1 jequv(*),ibedge(2,*),ibndry(6,*) save index data index/1,2,3,2,3,1,3,1,2/ c c construct interface ja c iflag=1 n=ipath(2,nproc+2) do i=1,n+1 ja(i)=0 enddo c c count indices (can easily overcount, but should be infrequent) c do ib=1,nbf do j=1,2 if(ibedge(j,ib).gt.0) then it=ibedge(j,ib)/4 jrgn=itnode(4,it) i2=iequv(ibndry(1,ib)) i3=iequv(ibndry(2,ib)) imin=min0(i2,i3) imax=max0(i2,i3) if(imin.le.nvv) then jmin=i2j(imin,irgn,jrgn,1,0,ipath,jequv)+1 ja(jmin)=ja(jmin)+1 else if(imin.gt.newnvf.and.imin.le.nvi) then iimin=imin-newnvf jmin=i2j(iimin,nproc+1,jrgn,1,0,ipath,jequv)+1 ja(jmin)=ja(jmin)+1 endif endif enddo enddo do it=1,ntf jrgn=itnode(4,it) do j=1,3 i2=iequv(itnode(index(2,j),it)) i3=iequv(itnode(index(3,j),it)) imin=min0(i2,i3) imax=max0(i2,i3) if(imin.le.nvv) then jmin=i2j(imin,irgn,jrgn,1,0,ipath,jequv)+1 ja(jmin)=ja(jmin)+1 else if(imin.gt.newnvf.and.imin.le.nvi) then iimin=imin-newnvf jmin=i2j(iimin,nproc+1,jrgn,1,0,ipath,jequv)+1 ja(jmin)=ja(jmin)+1 endif enddo enddo c ja(1)=n+2 do i=1,n ja(i+1)=ja(i)+ja(i+1)/2 enddo if(ja(n+1).gt.maxja) return do i=ja(1),ja(n+1)-1 ja(i)=0 enddo c c fill out rest of ja c do it=1,ntf jrgn=itnode(4,it) do j=1,3 i2=iequv(itnode(index(2,j),it)) i3=iequv(itnode(index(3,j),it)) imin=min0(i2,i3) imax=max0(i2,i3) if(imin.le.nvv) then jmin=i2j(imin,irgn,jrgn,1,0,ipath,jequv) if(imax.le.nvv) then jmax=i2j(imax,irgn,jrgn,1,0,ipath,jequv) else if(imax.gt.newnvf.and.imax.le.nvi) then iimax=imax-newnvf jmax=i2j(iimax,nproc+1,jrgn,1,0,ipath,jequv) else jmax=-imax endif else if(imin.gt.newnvf.and.imin.le.nvi) then iimin=imin-newnvf jmin=i2j(iimin,nproc+1,jrgn,1,0,ipath,jequv) if(imax.le.nvi) then iimax=imax-newnvf jmax=i2j(iimax,nproc+1,jrgn,1,0,ipath,jequv) else jmax=-imax endif else jmin=0 endif if(jmin.ne.0) then do jj=ja(jmin),ja(jmin+1)-1 if(ja(jj).eq.0) then ja(jj)=jmax go to 20 else if(ja(jj).eq.jmax) then go to 20 endif enddo stop 9001 endif 20 enddo enddo c c sort indices in increasing order c do i=1,n j1=ja(i)+1 j2=ja(i+1)-1 do j=j1,j2 jmin=j-1 do k=j,j2 if(ja(k).lt.ja(jmin)) jmin=k enddo jtemp=ja(j-1) ja(j-1)=ja(jmin) ja(jmin)=jtemp enddo enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ja0map(ii,jj,i,j,ij,ji,ja0,amtx0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja0(*),amtx0 c c compute location of a(i,j) and a(j,i) c if(ii.lt.jj) then do ij=ja0(i),ja0(i+1)-1 if(ja0(ij).eq.j) then ji=ij+amtx0 return endif enddo c else do ji=ja0(j),ja0(j+1)-1 if(ja0(ji).eq.i) then ij=ji+amtx0 return endif enddo endif c*** stop 9721 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine jamap(i,j,ij,ji,ja,amtx) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx c c compute location of a(i,j) and a(j,i) c if(i.lt.j) then do ij=ja(i),ja(i+1)-1 if(ja(ij).eq.j) then ji=ij+amtx return endif enddo c else do ji=ja(j),ja(j+1)-1 if(ja(ji).eq.i) then ij=ji+amtx return endif enddo endif ij=0 ji=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- integer function i2j(i,irgn,jrgn,isw,jsw,ipath,jequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jequv(*),ipath(4,*) c c input i, corresponding to irgn -- c output i2j --corresponding vertex in jrgn c isw/jsw=1 i/i2j in grid numbering c isw/jsw=0 i/i2j in interface numbering c if(isw.eq.1) then i2j=i+ipath(1,irgn)-1 else i2j=i endif ii=i2j 10 if(i2j.ge.ipath(1,jrgn).and.i2j.le.ipath(2,jrgn)) then if(jsw.eq.1) i2j=i2j-ipath(1,jrgn)+1 return endif i2j=jequv(i2j) if(i2j.ne.ii) go to 10 i2j=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blkmlt(irgn,nproc,newnvf,nvf,ja,a,ipath, + ja0,a0,x,b,p,ispd) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ja0(*),p(*),qi,umtx,lmtx,ipath(4,*) double precision + a(*),a0(*),x(*),b(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c c compute b=a*x for fine grid block of the matrix only c lmtx=0 umtx=0 c iqptr=ja(nvf+1)-1+nvf do i=1,nvf b(i)=0.0d0 qi=ja(iqptr+i) p(qi)=i enddo c c multiply by a0 c nvv=ipath(2,irgn)-ipath(1,irgn)+1 nn=ipath(2,nproc+2) do i=1,nvv i0=i+ipath(1,irgn)-1 b(i)=a0(i0)*x(i) enddo c c off diagonal part of a0 c if(ispd.eq.0) lmtx=ja0(nn+1)-ja0(1) if(ispd.eq.-1) umtx=ja0(nn+1)-ja0(1) do i=1,nvv i0=i+ipath(1,irgn)-1 do jj=ja0(i0),ja0(i0+1)-1 if(ja0(jj).gt.0) then j=ja0(jj)-ipath(1,irgn)+1 b(i)=b(i)+a0(jj+umtx)*x(j) b(j)=b(j)+a0(jj+lmtx)*x(i) endif enddo enddo c c diagonal part of a c do i=nvv+1,newnvf qi=ja(iqptr+i) b(i)=a(qi)*x(i) enddo c c off diagonal part of a c if(ispd.eq.0) lmtx=ja(nvf+1)-ja(1) if(ispd.eq.-1) umtx=ja(nvf+1)-ja(1) do i=1,newnvf qi=ja(iqptr+i) do jj=ja(qi),ja(qi+1)-1 j=p(ja(jj)) mx=max0(i,j) if(mx.gt.nvv.and.mx.le.newnvf) then b(i)=b(i)+a(jj+umtx)*x(j) b(j)=b(j)+a(jj+lmtx)*x(i) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine jmpmlt(irgn,nproc,newnvf,nvi,nvf,ipath,jequv, + ja0,a0,ui,bi,b,ujmp,ispd,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja0(*),umtx,lmtx,ipath(4,*),jequv(*) double precision + a0(*),ui(*),bi(*),b(*),ujmp(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c c compute contribution to rhs from interface jumps c n=ipath(2,nproc+2) nvv=ipath(2,irgn)-ipath(1,irgn)+1 lmtx=0 umtx=0 if(ispd.eq.0) lmtx=ja0(n+1)-ja0(1) if(ispd.eq.-1) umtx=ja0(n+1)-ja0(1) c c residual part c if(isw.eq.1) then do ii=1,nvv i=ii+ipath(1,irgn)-1 sum=0.0d0 it=i 10 it=jequv(it) sum=sum+bi(it) if(it.ne.i) go to 10 b(ii)=sum enddo do ii=newnvf+1,nvi i=ii-newnvf+ipath(1,nproc+1)-1 sum=0.0d0 it=i 20 it=jequv(it) if(it.le.n) sum=sum+bi(it) if(it.ne.i) go to 20 b(ii)=sum enddo do i=nvi+1,nvf b(i)=0.0d0 enddo endif c c form jumps c do i=1,n ujmp(i)=0.0d0 enddo c c this loop takes the master node from irgn c do ii=1,nvv i=ii+ipath(1,irgn)-1 uii=ui(i) it=i 30 it=jequv(it) if(it.ne.i) then ujmp(it)=ui(it)-uii go to 30 endif enddo c c this loop takes averages on the interface c c do ii=1,nvv c i=ii+ipath(1,irgn)-1 c uii=0.0e0 c num=0 c it=i c 30 num=num+1 c uii=uii+ui(it) c it=jequv(it) c if(it.ne.i) go to 30 c uii=uii/float(num) c it=i c 40 ujmp(it)=ui(it)-uii c it=jequv(it) c if(it.ne.i) go to 40 c enddo c c coarse part of interface c do ii=newnvf+1,nvi i=ii-newnvf+ipath(1,nproc+1)-1 uii=0.0d0 num=0 it=i 60 it=jequv(it) if(it.le.n) then uii=uii+ui(it) num=num+1 endif if(it.ne.i) go to 60 if(num.gt.0) uii=uii/dfloat(num) it=i 70 it=jequv(it) if(it.le.n) ujmp(it)=ui(it)-uii if(it.ne.i) go to 70 enddo c c jump contribution to residual c do ii=1,nvv i=ii+ipath(1,irgn)-1 it=i 80 it=jequv(it) if(it.ne.i) then b(ii)=b(ii)+a0(it)*ujmp(it) do kk=ja0(it),ja0(it+1)-1 j=ja0(kk) if(j.gt.0) then jj=i2j(j,0,irgn,0,1,ipath,jequv) if(jj.eq.0) then jj=i2j(j,0,nproc+1,0,1,ipath,jequv)+newnvf if(jj.le.0) stop 9898 endif b(ii)=b(ii)+a0(kk+umtx)*ujmp(j) else jj=-j endif b(jj)=b(jj)+a0(kk+lmtx)*ujmp(it) enddo go to 80 endif enddo c do ii=newnvf+1,nvi i=ii-newnvf+ipath(1,nproc+1)-1 it=i 90 it=jequv(it) if(it.le.n) then b(ii)=b(ii)+a0(it)*ujmp(it) do kk=ja0(it),ja0(it+1)-1 j=ja0(kk) if(j.gt.0) then jj=i2j(j,0,nproc+1,0,1,ipath,jequv)+newnvf b(ii)=b(ii)+a0(kk+umtx)*ujmp(j) else jj=-j endif b(jj)=b(jj)+a0(kk+lmtx)*ujmp(it) enddo endif if(it.ne.i) go to 90 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine paste(ip,itnode,itedge,ibndry,ibedge,ipath, + vx,vy,xm,ym,maxv,gf,list,ipstsw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ip(100), 1 ibedge(2,*),ipath(4,*),list(*) double precision + vx(*),vy(*),gf(maxv,*),bump(6),xm(*),ym(*) save bump data bump/0.0d0,0.0d0,0.0d0,0.0d0,0.0d0,0.0d0/ c c c ntf=ip(1) nvf=ip(2) nbf=ip(4) maxt=ip(21) maxv=ip(22) maxb=ip(24) ngf=ip(77) maxpth=ip(81) ibase=ip(70) c c make ipath array c if(ipstsw.eq.1) then nproc=ip(49) irgn=ip(50) call spth(nproc,irgn,ipath,list) else nproc=0 irgn=1 call mkpth(ip,nproc,ipath,ibndry,itedge,ibedge) endif call matchp(nproc,ipath,list) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,list,iflag) if(iflag.ne.0) stop 8255 call cedge5(nbf,itedge,ibedge,1) c c make short paths c ismth=0 nseg=ipath(4,irgn) iseg=ipath(3,irgn)-1 40 iseg=iseg+1 if(iseg.gt.nseg) go to 50 if(ipath(4,iseg).gt.0) go to 40 jseg=ipath(3,iseg) if(jseg.le.0) go to 40 if(ipath(4,jseg).le.0) go to 40 ibdy=-ipath(4,iseg) 45 if(ibndry(4,ibdy).ne.0) then itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri else if(ibndry(4,ibdy).eq.0) then k=ibedge(1,ibdy)/4 if(itnode(4,k).ne.irgn) then itri=ibedge(2,ibdy)/4 iedge=ibedge(2,ibdy)-4*itri else itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri endif endif call etst(ibdy,irgn,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) call newnot(itri,iedge,nvf,ntf,nbf,itnode,itedge,ibndry, + ibedge,vx,vy,xm,ym,maxv,maxt,maxb,gf,ngf,ibase,iflag) if(iflag.ne.0) then ip(25)=iflag return endif ismth=1 if(isw.eq.0) go to 45 if(nseg+2.gt.maxpth) then ip(25)=72 return endif json=ipath(4,jseg) ipath(4,iseg)=nseg+1 ipath(1,nseg+1)=ipath(1,iseg) ipath(2,nseg+1)=nvf ipath(3,nseg+1)=json+1 ipath(3,json+1)=nseg+1 ipath(4,nseg+1)=-nbf ipath(1,nseg+2)=nvf ipath(2,nseg+2)=ipath(2,iseg) ipath(3,nseg+2)=json ipath(3,json)=nseg+2 ipath(4,nseg+2)=-ibdy nseg=nseg+2 go to 40 c 50 if(ismth.eq.0) go to 55 lenb=3 idbcpt=ip(7) angmin=1.0d-3 arcmax=0.26d0 i1=1 i2=i1+nvf itmax=2 c c swap edges c call cedge5(nbf,itedge,ibedge,1) call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge,list, + vx,vy,lenb,bump,0) c c smoothing c call cedge5(nbf,itedge,ibedge,0) call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,list(i1),list(i2),angmin,arcmax) call mfe2(nvf,nbf,itmax,vx,vy,xm,ym,list(i2),list(i1), + itnode,itedge,ibndry,ibedge) c 55 ip(1)=ntf ip(2)=nvf ip(4)=nbf c if(ipstsw.eq.1) return c c adjust interface boundary edges that have been resolved c do 60 iseg=ipath(3,irgn),nseg if(ipath(4,iseg).gt.0) go to 60 jseg=ipath(3,iseg) if(jseg.le.iseg) go to 60 if(ipath(4,jseg).gt.0) go to 60 i=-ipath(4,iseg) j=-ipath(4,jseg) if(ibndry(4,i).ne.ibndry(4,j)) stop 8123 ccc if(ibndry(5,i).ne.ibndry(5,j)) stop 8124 if(ibndry(4,i).lt.3) stop 8125 if(ibndry(5,i).lt.0) then ibndry(5,i)=-ibndry(4,i) ibndry(5,j)=-ibndry(4,j) else ibndry(5,i)=ibndry(4,i) ibndry(5,j)=ibndry(4,j) endif ibndry(4,i)=-j ibndry(4,j)=-i do m=1,ngf gg=(gf(ibndry(1,i),m)+gf(ibndry(2,j),m))/2.0d0 gf(ibndry(1,i),m)=gg gf(ibndry(2,j),m)=gg gg=(gf(ibndry(2,i),m)+gf(ibndry(1,j),m))/2.0d0 gf(ibndry(2,i),m)=gg gf(ibndry(1,j),m)=gg enddo 60 enddo c c delete extra edges and vertices c i1=1 i2=i1+nvf i3=i2+nvf call trmbdy(ip,itnode,ibndry,vx,vy,list(i1),list(i2), + list(i3),maxv,gf) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine paste1(ip,itnode,ibndry,vx,vy,xm,ym,gf, + itedge,ibedge,vtype,iseed,iequv,ipath) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*), 1 itedge(3,*),vtype(*),ibedge(2,*),iequv(*),ipath(4,*), 2 elist(500),tlist(500),vlist(500),blist(500) double precision + gf(*),vx(*),vy(*),bump(3),e(3),xm(*),ym(*) c c check to see if we have solved problem on current finest grid c ntf=ip(1) nvf=ip(2) nbf=ip(4) newntf=ip(31) newnvf=ip(32) newnbf=ip(33) nvi=ip(36) nbi=ip(37) maxt=ip(21) maxv=ip(22) maxb=ip(24) ngf=ip(77) nproc=ip(49) irgn=ip(50) ibase=ip(70) maxpth=ip(81) lenb=3 hmin=0.0d0 coeff=0.0d0 nvv=ipath(2,nproc+2) c c initailize c call mkpthi(ip,ipath,ibndry,itedge,iseed) c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,iseed,iflag) if(iflag.ne.0) stop 1311 call cedge5(nbf,itedge,ibedge,1) c ntfsv=ntf nseg=ipath(4,nproc+1) iseg=ipath(3,nproc+1)-1 40 iseg=iseg+1 if(iseg.gt.nseg) go to 50 if(min0(ipath(1,iseg),ipath(2,iseg)).gt.0) go to 40 if(ipath(4,iseg).gt.0) go to 40 jseg=ipath(3,iseg) if(jseg.le.0) go to 40 if(ipath(4,jseg).le.0) go to 40 ibdy=-ipath(4,iseg) 45 if(ibndry(4,ibdy).ne.0) then itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri else if(ibndry(4,ibdy).eq.0) then k=ibedge(1,ibdy)/4 if(itnode(4,k).ne.irgn) then itri=ibedge(2,ibdy)/4 iedge=ibedge(2,ibdy)-4*itri else itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri endif endif call etst(ibdy,irgn,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) call newnot(itri,iedge,nvf,ntf,nbf,itnode,itedge,ibndry, + ibedge,vx,vy,xm,ym,maxv,maxt,maxb,gf,ngf,ibase,iflag) if(iflag.ne.0) then ip(25)=iflag return endif if(isw.eq.0) go to 45 if(nseg+2.gt.maxpth) then ip(25)=72 return endif json=ipath(4,jseg) ipath(4,iseg)=nseg+1 ipath(1,nseg+1)=ipath(1,iseg) ipath(2,nseg+1)=nvf ipath(3,nseg+1)=json+1 ipath(4,nseg+1)=-nbf ipath(1,nseg+2)=nvf ipath(2,nseg+2)=ipath(2,iseg) ipath(3,nseg+2)=json ipath(4,nseg+2)=-ibdy nseg=nseg+2 go to 40 c 50 if(ntfsv.eq.ntf) go to 60 ip(1)=ntf ip(2)=nvf ip(4)=nbf i1=1 i2=i1+max0(nbf,nvf) i3=i2+max0(nbf,nvf) i4=i3+max0(nbf,nvf) call cutr2(ip,itnode,ibndry,vx,vy,iseed(i1),iseed(i2), + iseed(i3),iseed(i4),itedge,ibedge,gf) nvi=ip(36) nbi=ip(37) call mkpthi(ip,ipath,ibndry,itedge,iseed) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,iseed,iflag) if(iflag.ne.0) stop 1322 call cedge5(nbf,itedge,ibedge,1) c c 60 ic=0 do iseg=ipath(3,nproc+1),ipath(4,nproc+1) ison=ipath(4,iseg) if(ison.gt.0) then if(ipath(3,ison).le.0) ic=ic+1 endif enddo if(ic.eq.0) go to 80 c do i=1,nvf vtype(i)=1 enddo do i=1,nbf if(ibndry(4,i).gt.0) then do k=1,2 vtype(ibndry(k,i))=6 enddo else if(ibndry(4,i).lt.0) then do k=1,2 if(vtype(ibndry(k,i)).ne.6) vtype(ibndry(k,i))=8 enddo else do k=1,2 if(vtype(ibndry(k,i)).eq.1) vtype(ibndry(k,i))=4 enddo endif enddo do i=1,ntf iseed(itnode(1,i))=1+4*i iseed(itnode(2,i))=2+4*i iseed(itnode(3,i))=3+4*i enddo c call cequv1(nvf,nbf,ibndry,iequv,0) c c main elimination loop c do 70 iseg=ipath(4,nproc+1),ipath(3,nproc+1),-1 ison=ipath(4,iseg) if(ison.le.0) go to 70 if(ipath(3,ison).gt.0) go to 70 iv1=ipath(1,ison)-nvv+newnvf iv2=ipath(2,ison)-nvv+newnvf jv1=ipath(1,ison+1)-nvv+newnvf jv2=ipath(2,ison+1)-nvv+newnvf if(ipath(1,ison).eq.0) then i=iv2 else if(iv1.eq.jv2) then i=iv1 else if(iv2.eq.jv1) then i=iv2 else stop7666 endif c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) if(vtype(i).eq.8) then ii=vlist(len+2) vtype(ii)=8 endif c c reduce to degree 3 or 4 by edge swapping c call reduc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,hmin,coeff,0,iflag) c c if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist,len, 1 hmin,coeff,ibase,-1) if(vtype(i).eq.8) then len1=elist(len+2)-(len+1) call dlknot(ii,itnode,itedge,ibndry,ibedge, + vx,vy,lenb,bump,e,iseed,vtype,vlist(len+2), 1 tlist(len+2),elist(len+2),len1,hmin,coeff, 2 ibase,-1) endif else stop 6651 endif 70 enddo call clnup2(nvf,ntf,nbf,newnvf,newntf,newnbf,nvi,nbi,irgn, + itnode,itedge,ibndry,ibedge,vx,vy,iseed,gf,maxv,ngf) c ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(36)=nvi ip(37)=nbi c call mkpthi(ip,ipath,ibndry,itedge,iseed) ic=0 do iseg=ipath(3,nproc+1),ipath(4,nproc+1) ison=ipath(4,iseg) if(ison.gt.0) then if(ipath(3,ison).le.0) ic=ic+1 endif enddo if(ic.ne.0) stop 7612 80 call matchp(nproc,ipath,iseed) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine newnot(itri,iedge,nvf,ntf,nbf,itnode,itedge,ibndry, + ibedge,vx,vy,xm,ym,maxv,maxt,maxb,gf,ngf,ibase,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),index(3,3), 1 ibedge(2,*),it(4),ib(4),iv(4) double precision + vx(*),vy(*),gf(maxv,*),c(3),xm(*),ym(*) save index,it,ib,iv data index/1,2,3,2,3,1,3,1,2/ data it/1,2,2,2/ data ib/1,1,2,0/ data iv/1,1,2,1/ c c check storage c ibdy=-itedge(iedge,itri) if(ibdy.lt.0) then icase=4 jtri=itedge(iedge,itri)/4 jedge=itedge(iedge,itri)-4*jtri else if(ibndry(4,ibdy).gt.0) then icase=1 else if(ibndry(4,ibdy).eq.0) then icase=2 if(ibedge(1,ibdy)/4.ne.itri) then jtri=ibedge(1,ibdy)/4 jedge=ibedge(1,ibdy)-4*jtri else jtri=ibedge(2,ibdy)/4 jedge=ibedge(2,ibdy)-4*jtri endif else icase=3 jbdy=-ibndry(4,ibdy) jtri=ibedge(1,jbdy)/4 jedge=ibedge(1,jbdy)-4*jtri endif if(nvf+iv(icase).gt.maxv) then iflag=22 return endif if(nbf+ib(icase).gt.maxb) then iflag=24 return endif if(ntf+it(icase).gt.maxt) then iflag=21 return endif iflag=0 nvf=nvf+iv(icase) nbf=nbf+ib(icase) ntf=ntf+it(icase) c c if(icase.ne.4) go to 5 iv1=itnode(iedge,itri) iv2=itnode(index(2,iedge),itri) iv3=itnode(index(3,iedge),itri) vx(nvf)=(vx(iv2)+vx(iv3))/2.0d0 vy(nvf)=(vy(iv2)+vy(iv3))/2.0d0 do k=1,ngf gf(nvf,k)=(gf(iv2,k)+gf(iv3,k))/2.0d0 enddo go to 10 c c refine ibdy c 5 ic=ibndry(3,ibdy) if(ic.gt.0) then call midpt(vx(ibndry(1,ibdy)),vy(ibndry(1,ibdy)), + vx(ibndry(2,ibdy)),vy(ibndry(2,ibdy)), 1 xm(ic),ym(ic),vx(nvf),vy(nvf)) else vx(nvf)=(vx(ibndry(1,ibdy))+vx(ibndry(2,ibdy)))/2.0d0 vy(nvf)=(vy(ibndry(1,ibdy))+vy(ibndry(2,ibdy)))/2.0d0 endif call bari(vx(nvf),vy(nvf),vx,vy,itnode(1,itri),c) do k=1,ngf gf(nvf,k)=c(1)*gf(itnode(1,itri),k) + +c(2)*gf(itnode(2,itri),k)+c(3)*gf(itnode(3,itri),k) enddo c do k=1,6 ibndry(k,nbf)=ibndry(k,ibdy) enddo ibndry(1,nbf)=itnode(index(2,iedge),itri) ibndry(2,nbf)=nvf ibndry(1,ibdy)=nvf ibndry(2,ibdy)=itnode(index(3,iedge),itri) ibedge(1,nbf)=iedge+4*itri ibedge(1,ibdy)=iedge+4*ntf c if(ibndry(5,ibdy).ne.0) then is=iabs(ibndry(5,ibdy))/ibase+1 ir=iabs(ibndry(5,ibdy))-(is-1)*ibase if(ibndry(5,ibdy).gt.0) then ibndry(5,ibdy)=ir+(2*is-1)*ibase ibndry(5,nbf)=ir+2*is*ibase else ibndry(5,ibdy)=-(ir+(2*is-1)*ibase) ibndry(5,nbf)=-(ir+2*is*ibase) endif endif c if(icase.eq.2) then ibedge(2,nbf)=jedge+4*jtri ibedge(2,ibdy)=jedge+4*(ntf-1) else ibedge(2,nbf)=0 ibedge(2,ibdy)=0 endif c c refine jbdy c if(icase.ne.3) go to 10 ic=ibndry(3,jbdy) if(ic.gt.0) then call midpt(vx(ibndry(1,jbdy)),vy(ibndry(1,jbdy)), + vx(ibndry(2,jbdy)),vy(ibndry(2,jbdy)), 1 xm(ic),ym(ic),vx(nvf-1),vy(nvf-1)) else vx(nvf-1)=(vx(ibndry(1,jbdy))+vx(ibndry(2,jbdy)))/2.0d0 vy(nvf-1)=(vy(ibndry(1,jbdy))+vy(ibndry(2,jbdy)))/2.0d0 endif call bari(vx(nvf-1),vy(nvf-1),vx,vy,itnode(1,jtri),c) do k=1,ngf gf(nvf-1,k)=c(1)*gf(itnode(1,jtri),k) + +c(2)*gf(itnode(2,jtri),k)+c(3)*gf(itnode(3,jtri),k) enddo c do k=1,6 ibndry(k,nbf-1)=ibndry(k,jbdy) enddo ibndry(1,nbf-1)=nvf-1 ibndry(2,nbf-1)=itnode(index(3,jedge),jtri) ibndry(1,jbdy)=itnode(index(2,jedge),jtri) ibndry(2,jbdy)=nvf-1 c if(ibndry(5,jbdy).ne.0) then is=iabs(ibndry(5,jbdy))/ibase+1 ir=iabs(ibndry(5,jbdy))-(is-1)*ibase if(ibndry(5,jbdy).gt.0) then ibndry(5,jbdy)=ir+(2*is-1)*ibase ibndry(5,nbf-1)=ir+2*is*ibase else ibndry(5,jbdy)=-(ir+(2*is-1)*ibase) ibndry(5,nbf-1)=-(ir+2*is*ibase) endif endif c ibedge(1,nbf-1)=jedge+4*jtri ibedge(1,jbdy)=jedge+4*(ntf-1) ibedge(2,nbf-1)=0 ibedge(2,jbdy)=0 ibndry(4,nbf)=-(nbf-1) ibndry(4,nbf-1)=-nbf c c refine itri c 10 do k=1,5 itnode(k,ntf)=itnode(k,itri) enddo do k=1,3 itedge(k,ntf)=itedge(k,itri) enddo c itedge(index(2,iedge),itri)=4*ntf+index(3,iedge) itedge(index(3,iedge),ntf)=4*itri+index(2,iedge) if(icase.eq.4) then itedge(iedge,ntf)=4*(ntf-1)+jedge else itedge(iedge,itri)=-nbf itedge(iedge,ntf)=-ibdy endif itnode(index(3,iedge),itri)=nvf itnode(index(2,iedge),ntf)=nvf c m=itedge(index(2,iedge),ntf) if(m.gt.0) then mtri=m/4 medge=m-4*mtri itedge(medge,mtri)=index(2,iedge)+4*ntf else mb=-m if(ibedge(1,mb)/4.eq.itri) then ibedge(1,mb)=index(2,iedge)+4*ntf else ibedge(2,mb)=index(2,iedge)+4*ntf endif endif c c refine jtri c if(icase.eq.1) return do k=1,5 itnode(k,ntf-1)=itnode(k,jtri) enddo do k=1,3 itedge(k,ntf-1)=itedge(k,jtri) enddo c itedge(index(3,jedge),jtri)=4*(ntf-1)+index(2,jedge) itedge(index(2,jedge),ntf-1)=4*jtri+index(3,jedge) if(icase.eq.2) then itedge(jedge,jtri)=-nbf itedge(jedge,ntf-1)=-ibdy itnode(index(2,jedge),jtri)=nvf itnode(index(3,jedge),ntf-1)=nvf else if(icase.eq.4) then itedge(jedge,ntf-1)=4*ntf+iedge itnode(index(2,jedge),jtri)=nvf itnode(index(3,jedge),ntf-1)=nvf else itedge(jedge,jtri)=-(nbf-1) itedge(jedge,ntf-1)=-jbdy itnode(index(2,jedge),jtri)=nvf-1 itnode(index(3,jedge),ntf-1)=nvf-1 endif c m=itedge(index(3,jedge),ntf-1) if(m.gt.0) then mtri=m/4 medge=m-4*mtri itedge(medge,mtri)=index(3,jedge)+4*(ntf-1) else mb=-m if(ibedge(1,mb)/4.eq.jtri) then ibedge(1,mb)=index(3,jedge)+4*(ntf-1) else ibedge(2,mb)=index(3,jedge)+4*(ntf-1) endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine etst(ibdy,irgn,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ibedge(2,*), 1 index(3,3) double precision + vx(*),vy(*),h(3) save index data index/1,2,3,2,3,1,3,1,2/ c c isw=0 itri, iedge, not final c isw=1 itri, iedge, are the final ones. c isw=1 c c find itri, iedge in irgn c if(ibndry(4,ibdy).ne.0) then itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri else if(ibndry(4,ibdy).eq.0) then k=ibedge(1,ibdy)/4 if(itnode(4,k).ne.irgn) then itri=ibedge(2,ibdy)/4 iedge=ibedge(2,ibdy)-4*itri else itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri endif endif itsv=itri iesv=iedge c c test triangle on irgn side c iv1=itnode(iedge,itri) iv2=itnode(index(2,iedge),itri) iv3=itnode(index(3,iedge),itri) h(1)=(vx(iv2)-vx(iv3))**2+(vy(iv2)-vy(iv3))**2 h(2)=(vx(iv3)-vx(iv1))**2+(vy(iv3)-vy(iv1))**2 h(3)=(vx(iv1)-vx(iv2))**2+(vy(iv1)-vy(iv2))**2 if(h(1).ge.dmax1(h(2),h(3))) go to 20 isw=0 c c find longest edge c 10 if(h(2).gt.h(3)) then kedge=index(2,iedge) else kedge=index(3,iedge) endif c c find opposing triangle c if(itedge(kedge,itri).gt.0) then jtri=itedge(kedge,itri)/4 jedge=itedge(kedge,itri)-4*jtri else kbdy=-itedge(kedge,itri) if(ibndry(4,kbdy).gt.0) then iedge=kedge return else if(ibndry(5,kbdy).ne.0) then if(itri.eq.itsv) then isw=1 go to 20 else return endif else if(ibndry(4,kbdy).eq.0) then if(4*itri+kedge.eq.ibedge(1,kbdy)) then jtri=ibedge(2,kbdy)/4 jedge=ibedge(2,kbdy)-4*jtri else jtri=ibedge(1,kbdy)/4 jedge=ibedge(1,kbdy)-4*jtri endif else mbdy=-ibndry(4,kbdy) jtri=ibedge(1,mbdy)/4 jedge=ibedge(1,mbdy)-4*jtri endif endif iv1=itnode(jedge,jtri) iv2=itnode(index(2,jedge),jtri) iv3=itnode(index(3,jedge),jtri) h(1)=(vx(iv2)-vx(iv3))**2+(vy(iv2)-vy(iv3))**2 h(2)=(vx(iv3)-vx(iv1))**2+(vy(iv3)-vy(iv1))**2 h(3)=(vx(iv1)-vx(iv2))**2+(vy(iv1)-vy(iv2))**2 if(h(1).ge.dmax1(h(2),h(3))) then iedge=kedge return else itri=jtri iedge=jedge go to 10 endif c c if we made it this far, the irgn side is done c 20 if(ibndry(4,ibdy).eq.0) then if(4*itri+iedge.eq.ibedge(1,ibdy)) then jtri=ibedge(2,ibdy)/4 jedge=ibedge(2,ibdy)-4*jtri else jtri=ibedge(1,ibdy)/4 jedge=ibedge(1,ibdy)-4*jtri endif else mbdy=-ibndry(4,ibdy) jtri=ibedge(1,mbdy)/4 jedge=ibedge(1,mbdy)-4*jtri endif itri=jtri iedge=jedge jtsv=jtri c c test triangle on other side c iv1=itnode(iedge,itri) iv2=itnode(index(2,iedge),itri) iv3=itnode(index(3,iedge),itri) h(1)=(vx(iv2)-vx(iv3))**2+(vy(iv2)-vy(iv3))**2 h(2)=(vx(iv3)-vx(iv1))**2+(vy(iv3)-vy(iv1))**2 h(3)=(vx(iv1)-vx(iv2))**2+(vy(iv1)-vy(iv2))**2 if(h(1).ge.dmax1(h(2),h(3))) then itri=itsv iedge=iesv return endif isw=0 c c find longest edge c 30 if(h(2).gt.h(3)) then kedge=index(2,iedge) else kedge=index(3,iedge) endif c c find opposing triangle c if(itedge(kedge,itri).gt.0) then jtri=itedge(kedge,itri)/4 jedge=itedge(kedge,itri)-4*jtri else kbdy=-itedge(kedge,itri) if(ibndry(4,kbdy).gt.0) then iedge=kedge return else if(ibndry(4,kbdy).eq.0) then if(4*itri+kedge.eq.ibedge(1,kbdy)) then jtri=ibedge(2,kbdy)/4 jedge=ibedge(2,kbdy)-4*jtri else jtri=ibedge(1,kbdy)/4 jedge=ibedge(1,kbdy)-4*jtri endif else mbdy=-ibndry(4,kbdy) jtri=ibedge(1,mbdy)/4 jedge=ibedge(1,mbdy)-4*jtri endif endif if(itnode(4,jtri).eq.irgn) then if(itri.eq.jtsv) then isw=1 itri=itsv iedge=iesv endif return endif iv1=itnode(jedge,jtri) iv2=itnode(index(2,jedge),jtri) iv3=itnode(index(3,jedge),jtri) h(1)=(vx(iv2)-vx(iv3))**2+(vy(iv2)-vy(iv3))**2 h(2)=(vx(iv3)-vx(iv1))**2+(vy(iv3)-vy(iv1))**2 h(3)=(vx(iv1)-vx(iv2))**2+(vy(iv1)-vy(iv2))**2 if(h(1).ge.dmax1(h(2),h(3))) then iedge=kedge return else itri=jtri iedge=jedge go to 30 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine trmbdy(ip,itnode,ibndry,vx,vy,p,q,iequv,maxv,gf) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),p(*),q(*),iequv(*) double precision + vx(*),vy(*),gf(maxv,*) c ntf=ip(1) nvf=ip(2) nbf=ip(4) c c mark vertices c call cequv1(nvf,nbf,ibndry,iequv,2) do i=1,nvf p(i)=i enddo c c fixup triangles c do i=1,ntf do j=1,3 itnode(j,i)=iequv(itnode(j,i)) enddo enddo c c fixup boundary edges c do i=1,nbf do j=1,2 ibndry(j,i)=iequv(ibndry(j,i)) enddo enddo c c special dirichlet point c if(ip(7).gt.0) then ip(7)=iequv(ip(7)) endif c c now reorder vertices c newnvf=0 do i=1,nvf if(iequv(i).eq.i) then newnvf=newnvf+1 p(i)=p(newnvf) p(newnvf)=i endif enddo c call vorder(ip,p,q,itnode,ibndry,vx,vy,gf,maxv) c c reorder ibndry c do i=1,nbf p(i)=i enddo newnbf=0 do i=1,nbf isw=1 mk=iabs(ibndry(5,i)) if(mk.eq.3.or.mk.eq.4) then if(ibndry(4,i).lt.0) then m=-ibndry(4,i) if(i.gt.m) isw=0 ibndry(4,i)=0 endif endif if(isw.eq.1) then newnbf=newnbf+1 p(i)=p(newnbf) p(newnbf)=i endif enddo c c reorder edges c call border(ip,p,q,ibndry) c c reset ibndry(5,*) c do i=1,newnbf if(ibndry(5,i).lt.0) then if(ibndry(4,i).le.0) ibndry(5,i)=-i else if(ibndry(5,i).gt.0) then if(ibndry(4,i).le.0) ibndry(5,i)=i endif enddo ip(2)=newnvf ip(4)=newnbf ip(70)=newnbf return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine predct(ip,itnode,ibndry,vx,vy,xm,ym,b,u, + gm,u0,u0dot,rp,ibedge,idsp,mxfail,iequv, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),iequv(*),ip(100) double precision + vx(*),vy(*),u(*),u0(*),u0dot(*),rp(100),xm(*),ym(*), 1 b(*),gm(*) double precision + fa(6,6),fh(6,6),fg(6,6),fsm(6,6),fsu(6,6), 1 fb(6),fd(6),fp(12),fdl(12),um(6),d1u(6),d2u(6),uc(6) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy data ibit/0/ c c compute the step size for the next continuation step c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=ip(6) idbcpt=ip(7) ispd=ip(8) c bias=100.0d0 ratmax=25.0d0 step=0.25d0 sh=rp(45) rl0dot=rp(33) rl0=rp(31) r0=rp(32) eps=100.0d0*ceps(ibit) ratio=2.0d0*ratmax scale=1.0d0 c c compute theta c call mkgm(nvf,ntf,vx,vy,gm,itnode,iequv) call ctheta(ip,rp,iflag) if(iflag.ne.0) then idsp=mxfail+1 return endif thetal=rp(69) thetar=rp(70) sigma=rp(71) seqdot=rp(74) if(seqdot.eq.0.0d0.or.idsp.gt.mxfail) then idsp=mxfail+1 return endif c isw=0 iter=-1 ifirst=3 c c initialize c 10 iter=iter+1 q=step*sigma/seqdot if(ratio.gt.ratmax) q=sigma/seqdot rl=rl0+q*rl0dot do i=1,nvf u(i)=u0(i)+q*u0dot(i) b(i)=0.0d0 enddo rr=0.0d0 anorm=0.0d0 c c compute integrals on elements c do i=1,ntf call eleasm(i,itnode,vx,vy,u,um,uc,d1u,d2u,vx0,vy0,u0, + rl,sh,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,0, 1 ispd,iprob,ifirst,a1xy,a2xy,fxy,p1xy) ifirst=0 rr=rr+fp(8) do k=1,3 ivk=iequv(itnode(k,i)) anorm=dmax1(anorm,dabs(fa(k,k))) b(ivk)=b(ivk)-fb(k) enddo enddo c c check for boundary edges c do i=1,nbf if(ibndry(5,i).le.0) then do j=1,2 if(ibedge(j,i).gt.0) then call elebdi(i,j,itnode,ibndry,ibedge, + vx,vy,xm,ym,u,uc,rl,fh,fg, 1 fsu,fp,fdl,iprob,0,p2xy) rr=rr+fp(8) endif enddo endif if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 call elenbc(i,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 iprob,0,gnxy) do k=1,3 ivk=iequv(itnode(k,it)) b(ivk)=b(ivk)-fb(k) enddo endif enddo c c scalar function c scleqn=thetar*(rr-r0)+thetal*(rl-rl0)-sigma c c norm of residual c do i=1,nbf if(ibndry(4,i).eq.2) then b(iequv(ibndry(1,i)))=0.0d0 b(iequv(ibndry(2,i)))=0.0d0 endif enddo if(idbcpt.gt.0) b(iequv(idbcpt))=0.0d0 bnorm=dl2nrm(nvf,b,gm,-1) c c compute scaling c if(ratio.gt.ratmax) then unorm=dl2nrm(nvf,u,gm,1) scale=bias d1=bnorm+anorm*unorm*10.0d0 d2=dabs(sigma)+dabs(r0)*dabs(thetar)+dabs(rl0)*dabs(thetal) if(dmin1(d1,d2).gt.0.0d0.and.bnorm.gt.anorm*0.001d0) + scale=bias*d1/d2 endif q=scleqn*scale bmax=dmax1(dabs(q),bnorm) if(bmax.gt.0.0d0) then bnorm=bmax*dsqrt((bnorm/bmax)**2+(q/bmax)**2) endif ratio=0.0d0 if(sigma.ne.0.0d0) ratio=bnorm/dabs(scale*sigma) c c test for sufficient decrease c if(1.0d0-ratio.gt.eps*step.or.iter.ge.mxfail) then rp(71)=sigma rp(68)=scale idsp=max0(idsp,iter) return else if(isw.eq.0.and.ratio.le.ratmax) then isw=1 iter=iter-1 else sigma=sigma/2.0d0 endif go to 10 endif c end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cd2u(ip,rp,u,ux,uy,vx,vy,itnode,lenb,bump,e) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ip(100) double precision + vx(*),vy(*),u(*),ux(*),uy(*),bump(lenb,*),e(*),rp(100) c ntf=ip(1) nvf=ip(2) coeff=0.0d0 hmin=0.0d0 c c compute second derivatives c enorm1=0.0d0 enorm2=0.0d0 do i=1,ntf c iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) x3=vx(iv3)-vx(iv1) y2=vy(iv2)-vy(iv1) y3=vy(iv3)-vy(iv1) det=x2*y3-x3*y2 c c compute gradients of ux and uy c u2=ux(iv2)-ux(iv1) u3=ux(iv3)-ux(iv1) uxx=(u2*y3-u3*y2)/det uxy=(x2*u3-x3*u2)/det c u2=uy(iv2)-uy(iv1) u3=uy(iv3)-uy(iv1) uyx=(u2*y3-u3*y2)/det uyy=(x2*u3-x3*u2)/det c bump(1,i)=-uxx/8.0d0 bump(2,i)=-uyy/8.0d0 bump(3,i)=-(uxy+uyx)/16.0d0 c e(i)=tqual1(i,itnode,vx,vy,u,ux,uy) ei=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) if(ei.gt.0.0d0) then aa=dsqrt(e(i)/ei) bump(1,i)=bump(1,i)*aa bump(2,i)=bump(2,i)*aa bump(3,i)=bump(3,i)*aa endif c enorm1=enorm1+e(i) enorm2=enorm2+tqual2(i,itnode,vx,vy,lenb,bump) enddo c rp(37)=dsqrt(enorm1) qx=cl2nrm(nvf,ntf,vx,vy,ux,itnode) qy=cl2nrm(nvf,ntf,vx,vy,uy,itnode) qq=dmax1(qx,qy) if(qq.gt.0.0d0) then rp(38)=dsqrt((qx/qq)**2+(qy/qq)**2)*qq else rp(38)=ch1nrm(nvf,ntf,vx,vy,u,itnode) endif rp(39)=dsqrt(enorm2) rp(40)=cl2nrm(nvf,ntf,vx,vy,u,itnode) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine recovr(nvf,ntf,u,ux,uy,vx,vy,itnode,ja,a,iequv, + bx,by,z) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),iequv(*),ja(*) double precision + vx(*),vy(*),u(*),a(*),z(*),ux(*),uy(*),bx(*),by(*) c c compute recovered gradient c mxcg=20 mxsmth=2 eps=1.0d-6 c i1=1 i2=i1+nvf i3=i2+nvf c c compute mass matrix c maxlnk=4*nvf call setgr1(ntf,nvf,itnode,ja,a,iequv,maxlnk,jflag) c do i=1,nvf bx(i)=0.0d0 by(i)=0.0d0 enddo c c compute projected gradient c do i=1,ntf c iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) x3=vx(iv3)-vx(iv1) y2=vy(iv2)-vy(iv1) y3=vy(iv3)-vy(iv1) det=x2*y3-x3*y2 c c compute gradient c dd=1.0d0/6.0d0 if(det.lt.0.0d0) dd=-dd u2=u(iv2)-u(iv1) u3=u(iv3)-u(iv1) rx=(u2*y3-u3*y2)*dd ry=(x2*u3-x3*u2)*dd c do k=1,3 ivk=iequv(itnode(k,i)) bx(ivk)=bx(ivk)+rx by(ivk)=by(ivk)+ry enddo enddo c c l2 projection c call l2mtx(nvf,ntf,vx,vy,itnode,ja,a,iequv) c c initial guess is current approximation (zero for coarse grid) c c* do i=1,nvf c* ux(i)=bx(i)/(2.0e0*a(i)) c* uy(i)=by(i)/(2.0e0*a(i)) c* enddo call sgscg(nvf,ja,a,ux,bx,mxcg,z(i1),z(i2),z(i3),eps) call sgscg(nvf,ja,a,uy,by,mxcg,z(i1),z(i2),z(i3),eps) c c smoothing c if(mxsmth.gt.0) then call h10mtx(nvf,ntf,vx,vy,itnode,ja,a,iequv) do i=1,nvf bx(i)=0.0d0 by(i)=0.0d0 enddo call jcg(nvf,ja,a,ux,bx,mxsmth,z(i1),z(i2),z(i3),eps) call jcg(nvf,ja,a,uy,by,mxsmth,z(i1),z(i2),z(i3),eps) endif c do i=1,nvf ux(i)=ux(iequv(i)) uy(i)=uy(iequv(i)) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cdlfn(ip,itnode,ibndry,vx,vy,u,ux,uy,b,udl, + ja,a,ka,mark,iequv,z,hist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ka(10,*),iequv(*),ja(*),amtx, 1 mark(*),ip(100),ibndry(6,*) double precision + vx(*),vy(*),u(*),ux(*),uy(*),udl(*), 1 z(*),hist(22,*),a(*),b(*) data ibit/0/ c c ntf=ip(1) nvf=ip(2) nbf=ip(4) mpisw=ip(48) nproc=ip(49) irgn=ip(50) ispd=ip(8) mxcg=ip(10) lvl=ip(75) eps=1.0d2*ceps(ibit) epsmg=dmax1(1.0d-3,eps) call cequv1(nvf,nbf,ibndry,iequv,0) c c set ups rhs c m0=1 m1=m0+nvf m2=m1+nvf if(ip(73).eq.0.or.ip(74).eq.0) go to 10 amtx=0 if(ispd.ne.1) amtx=ja(nvf+1)-ja(1) iqptr=ja(nvf+1)-1+nvf c do i=1,nvf mark(i)=0 z(i)=0.0d0 enddo do i=1,ntf if(itnode(4,i).eq.irgn) then do j=1,3 mark(ja(iqptr+itnode(j,i)))=1 enddo endif enddo do i=1,nvf if(mark(i).eq.1) then z(i)=a(i) do j=ja(i),ja(i+1)-1 k=ja(j) if(mark(k).eq.0) z(k)=z(k)-a(j) a(j)=0.0d0 a(j+amtx)=0.0d0 enddo else do j=ja(i),ja(i+1)-1 k=ja(j) if(mark(k).eq.1) then z(i)=z(i)-a(j+amtx) a(j)=0.0d0 a(j+amtx)=0.0d0 endif enddo endif enddo c c solve equations c if(ispd.eq.0) then jspd=-1 else jspd=1 endif call mtxml0(nvf,ja,a,udl,b,iequv,z(m1),jspd) do i=1,nvf b(i)=z(ja(iqptr+i))-b(i) enddo call mgilu(ja,a,lvl,ka,z) call mg(jspd,lvl,mxcg,epsmg,ja,a,z,b, + ka,iequv,relerr,jflag,z(m1),hist(1,18)) do i=1,nvf udl(i)=udl(i)+z(i) enddo return c c the case of no previous solution 10 do i=1,nvf udl(i)=0.0d0 mark(i)=0 enddo do i=1,ntf if(itnode(4,i).eq.irgn) then do j=1,3 udl(itnode(j,i))=1.0d0 enddo endif enddo maxlnk=4*nvf call setgr1(ntf,nvf,itnode,ja,a,iequv,maxlnk,jflag) call h10mtx(nvf,ntf,vx,vy,itnode,ja,a,iequv) do i=1,nbf if(ibndry(4,i).eq.2) then mark(ibndry(1,i))=1 mark(ibndry(2,i))=1 endif enddo idbcpt=ip(7) if(idbcpt.gt.0) mark(idbcpt)=1 do i=1,nvf do j=ja(i),ja(i+1)-1 if(mark(i).eq.1.or.mark(ja(j)).eq.1) a(j)=0.0d0 enddo enddo do i=1,nvf mark(i)=0 b(i)=0.0d0 enddo do i=1,ntf if(itnode(4,i).eq.irgn) then do j=1,3 mark(itnode(j,i))=1 enddo endif enddo do i=1,nvf if(mark(i).eq.1) then b(i)=a(i) do j=ja(i),ja(i+1)-1 k=ja(j) if(mark(k).eq.0) b(k)=b(k)-a(j) a(j)=0.0d0 enddo else do j=ja(i),ja(i+1)-1 k=ja(j) if(mark(k).eq.1) then b(i)=b(i)-a(j) a(j)=0.0d0 endif enddo endif enddo c c solve equations c call sgscg(nvf,ja,a,udl,b,mxcg,z(m0),z(m1),z(m2),epsmg) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cdlwts(nvf,ntf,nbf,jc,order,idist,irgn,itnode, + ibndry,ibase,lenb,bump,udl) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jc(*),order(*),idist(*),ibndry(6,*) double precision + bump(lenb,*),udl(*) c c mark fine grid points c do i=1,nvf idist(i)=nvf+1 enddo do i=1,ntf if(itnode(4,i).eq.irgn) then do j=1,3 idist(itnode(j,i))=0 enddo endif enddo c c this catches coarse interface edges near cross points c do i=1,nbf order(i)=0 enddo do i=1,nbf if(ibndry(5,i).ne.0) then it=iabs(ibndry(5,i))/ibase+1 ir=iabs(ibndry(5,i))-(it-1)*ibase do j=1,2 if(idist(ibndry(j,i)).eq.0) order(ir)=1 enddo endif enddo do i=1,nbf if(ibndry(5,i).ne.0) then it=iabs(ibndry(5,i))/ibase+1 ir=iabs(ibndry(5,i))-(it-1)*ibase if(order(ir).eq.1) then do j=1,2 idist(ibndry(j,i))=0 enddo endif endif enddo c c now order points c next=1 do i=1,nvf if(idist(i).eq.0) then order(next)=i next=next+1 endif enddo c do ii=1,nvf i=order(ii) if(i.eq.0) go to 10 do jj=jc(i),jc(i+1)-1 j=jc(jj) if(idist(j).gt.nvf) then order(next)=j next=next+1 idist(j)=idist(i)+1 if(next.gt.nvf) go to 10 endif enddo enddo c 10 imax=100 itheta=1 do i=1,ntf if(itnode(4,i).ne.irgn) then ii=imax ss=1.0d-7 do j=1,3 ii=min0(ii,idist(itnode(j,i))) ss=dmax1(ss,dabs(udl(itnode(j,i)))) enddo ii=ii-itheta if(ii.gt.0) then ratio=dmin1(ss,1.0d0)/dfloat(2*ii) do j=1,lenb bump(j,i)=bump(j,i)*ratio enddo endif endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine usrfn(ntf,itnode,iprob,vx,vy,u,ux,uy,e,rp, + lenb,bump,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),u(*),e(*),bump(lenb,*),rp(100),qv(6), 1 tx(3),ty(3),x(3),y(3),c(3),gx(3),gy(3),ux(*),uy(*) save index data index/1,2,3,2,3,1,3,1,2/ external qxy c c compute user function for use in error estimates c rl=rp(21) if(iprob.eq.6) rl=rp(46) c c the main loop c enorm1=0.0d0 unorm1=0.0d0 enorm2=0.0d0 unorm2=0.0d0 coeff=0.0d0 hmin=0.0d0 do i=1,ntf c c compute det c do k=1,3 k2=itnode(index(2,k),i) k3=itnode(index(3,k),i) tx(k)=vx(k3)-vx(k2) ty(k)=vy(k3)-vy(k2) enddo det=tx(2)*ty(3)-tx(3)*ty(2) do k=1,3 k2=index(2,k) k3=index(3,k) x(k)=ty(k2)*ty(k3) y(k)=tx(k2)*tx(k3) c(k)=-(tx(k2)*ty(k3)+ty(k2)*tx(k3))/2.0d0 gx(k)=-ty(k)/det gy(k)=tx(k)/det enddo det=dabs(det) c c compute bump functions coefficients c call eleufn(i,itnode,vx,vy,u,ux,uy,rl,qv,5,2,qxy) bump(1,i)=qv(4)-(qv(2)+qv(3))/2.0d0 bump(2,i)=qv(5)-(qv(3)+qv(1))/2.0d0 bump(3,i)=qv(6)-(qv(1)+qv(2))/2.0d0 c c compute bump c dd=det**2 b1=-bump(1,i)/dd b2=-bump(2,i)/dd b3=-bump(3,i)/dd bump(1,i)=b1*x(1)+b2*x(2)+b3*x(3) bump(2,i)=b1*y(1)+b2*y(2)+b3*y(3) bump(3,i)=b1*c(1)+b2*c(2)+b3*c(3) c zx=qv(1)*gx(1)+qv(2)*gx(2)+qv(3)*gx(3) zy=qv(1)*gy(1)+qv(2)*gy(2)+qv(3)*gy(3) e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) c enorm1=enorm1+e(i) unorm1=unorm1+(zx**2+zy**2)*det/2.0d0 enorm2=enorm2+tqual2(i,itnode,vx,vy,lenb,bump) unorm2=unorm2+((qv(2)+qv(3))**2+(qv(3)+qv(1))**2 + +(qv(1)+qv(2))**2)*det/24.0d0 enddo rp(37)=dsqrt(enorm1) rp(38)=dsqrt(unorm1) rp(39)=dsqrt(enorm2) rp(40)=dsqrt(unorm2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + deg,vx,vy,lenb,bump,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),deg(*),ibndry(6,*), 1 ibedge(2,*) double precision + vx(*),vy(*),bump(lenb,*),fract0(5),qmin0(5) save index,fract0,qmin0 data index/1,2,3,2,3,1,3,1,2/ data fract0/1.0d0, 1.0d0, 0.95d0, 0.9d0,1.0d0/ data qmin0 /1.0d0,0.95d0, 0.87d0, 0.6d0,0.95d0/ c c c this routine swaps interior triangle edges in an attempt c to improve the overall quality of the triangulation c c this version incoporporates ideas of field for equilibrating degrees c itmax=2 c c compute psuedo degrees for boundary vertices c do i=1,nvf deg(i)=0 enddo c do i=1,nbf if(ibndry(4,i).ne.0) then kv=ibndry(1,i) kb=ibndry(2,i) kedge=ibedge(1,i) 20 kt=kedge/4 ke=kedge-4*kt kedge=itedge(index(3,ke),kt) if(kedge.gt.0) go to 20 ka=itnode(ke,kt) q=6.0d0-cang(kb,kv,ka,vx,vy)*3.0d0 iq=max0(idint(q+0.5d0)-1,0) deg(kv)=min0(5,iq) endif enddo c c compute degrees in deg(*) c do i=1,ntf do j=1,3 k=itedge(j,i)/4 if(i.gt.k) then j2=itnode(index(2,j),i) j3=itnode(index(3,j),i) deg(j2)=deg(j2)+1 deg(j3)=deg(j3)+1 endif enddo enddo c c the main loop in which the edges are swapped c do 100 ithrsh=5,2,-1 qmin=qmin0(ithrsh) fract=fract0(ithrsh) do itnum=1,itmax ichng=0 do i=1,ntf do 50 ied=1,3 k=itedge(ied,i)/4 cccc if(k.le.i) go to 50 if(k.le.0) go to 50 if(itnode(4,k).ne.itnode(4,i)) go to 50 if(itnode(5,k).ne.itnode(5,i)) go to 50 if(k.le.0) go to 50 ked=itedge(ied,i)-4*k j2=itnode(index(ied,2),i) j3=itnode(index(ied,3),i) mi=itnode(ied,i) mk=itnode(ked,k) c c dont connect two boundary points or increase high degrees c mtst=deg(j2)+deg(j3) + -deg(mi)-deg(mk) if(mtst.lt.ithrsh.and.ithrsh.lt.5) go to 50 c ii=-itedge(index(ied,2),i) jj=-itedge(index(ked,3),k) if(min0(ii,jj).gt.0) then if(ibndry(4,ii).ne.0.and.ibndry(4,jj).ne.0) + go to 50 endif ii=-itedge(index(ied,3),i) jj=-itedge(index(ked,2),k) if(min0(ii,jj).gt.0) then if(ibndry(4,ii).ne.0.and.ibndry(4,jj).ne.0) + go to 50 endif c c dont create bad geometries c q2=geom(mi,j2,mk,vx,vy) q3=geom(mk,j3,mi,vx,vy) qi=geom(mi,j2,j3,vx,vy) qk=geom(mk,j3,j2,vx,vy) q23=dmin1(q2,q3) qik=dmin1(qi,qk) if(q23.lt.dmin1(qik*fract,qmin)) go to 50 c c swap edges c ichng=ichng+1 deg(j2)=deg(j2)-1 deg(j3)=deg(j3)-1 deg(mi)=deg(mi)+1 deg(mk)=deg(mk)+1 c itnode(index(ied,3),i)=mk itnode(index(ked,3),k)=mi itedge(ied,i)=itedge(index(ked,2),k) itedge(ked,k)=itedge(index(ied,2),i) itedge(index(ied,2),i)=index(ked,2)+4*k itedge(index(ked,2),k)=index(ied,2)+4*i c c fixup neighbors c li=itedge(ied,i)/4 if(li.gt.0) then ll=itedge(ied,i)-4*li itedge(ll,li)=4*i+ied else ll=-itedge(ied,i) if(ibedge(1,ll)/4.eq.k) then ibedge(1,ll)=4*i+ied else ibedge(2,ll)=4*i+ied endif endif lk=itedge(ked,k)/4 if(lk.gt.0) then ll=itedge(ked,k)-4*lk itedge(ll,lk)=4*k+ked else ll=-itedge(ked,k) if(ibedge(1,ll)/4.eq.i) then ibedge(1,ll)=4*k+ked else ibedge(2,ll)=4*k+ked endif endif c c fixup bump c if(isw.eq.1) then do m=1,lenb bump(m,i)=(bump(m,i)+bump(m,k))/2.0d0 bump(m,k)=bump(m,i) enddo endif 50 continue enddo if(ichng.le.0) go to 100 enddo 100 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eswapb(itnode,itedge,ibndry,ibedge,vx,vy,lenb,bump, + ntf,next,slist,p,q,e,hmin,coeff) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),ibndry(6,*), 1 slist(*),p(*),q(*),ibedge(2,*) double precision + vx(*),vy(*),bump(lenb,*),e(*) save index data index/1,2,3,2,3,1,3,1,2/ c c c this routine swaps interior triangle edges in an attempt c to improve the overall quality of the triangulation c c if(next.lt.0) return fract=0.99d0 10 ichng=0 i=next do 50 ied=1,3 k=itedge(ied,i)/4 if(k.le.0) go to 50 if(itnode(4,k).ne.itnode(4,i)) go to 50 if(itnode(5,k).ne.itnode(5,i)) go to 50 ked=itedge(ied,i)-4*k j2=itnode(index(ied,2),i) j3=itnode(index(ied,3),i) mi=itnode(ied,i) mk=itnode(ked,k) c c dont connect two boundary points c ii=-itedge(index(ied,2),i) jj=-itedge(index(ked,3),k) if(min0(ii,jj).gt.0) then if(ibndry(4,ii).ne.0.and.ibndry(4,jj).ne.0) + go to 50 endif ii=-itedge(index(ied,3),i) jj=-itedge(index(ked,2),k) if(min0(ii,jj).gt.0) then if(ibndry(4,ii).ne.0.and.ibndry(4,jj).ne.0) + go to 50 endif c c dont create bad geometries c q2=geom(mi,j2,mk,vx,vy) q3=geom(mk,j3,mi,vx,vy) qi=geom(mi,j2,j3,vx,vy) qk=geom(mk,j3,j2,vx,vy) q23=dmin1(q2,q3) qik=dmin1(qi,qk) c* if(q23.lt.qik*fract) go to 50 if(q23*fract.le.qik) go to 50 c c swap edges c ichng=ichng+1 itnode(index(ied,3),i)=mk itnode(index(ked,3),k)=mi itedge(ied,i)=itedge(index(ked,2),k) itedge(ked,k)=itedge(index(ied,2),i) itedge(index(ied,2),i)=index(ked,2)+4*k itedge(index(ked,2),k)=index(ied,2)+4*i c c fixup neighbors c li=itedge(ied,i)/4 if(li.gt.0) then ll=itedge(ied,i)-4*li itedge(ll,li)=4*i+ied else ll=-itedge(ied,i) if(ibedge(1,ll)/4.eq.k) then ibedge(1,ll)=4*i+ied else ibedge(2,ll)=4*i+ied endif endif lk=itedge(ked,k)/4 if(lk.gt.0) then ll=itedge(ked,k)-4*lk itedge(ll,lk)=4*k+ked else ll=-itedge(ked,k) if(ibedge(1,ll)/4.eq.i) then ibedge(1,ll)=4*k+ked else ibedge(2,ll)=4*k+ked endif endif c c fixup bump c do m=1,lenb bump(m,i)=(bump(m,i)+bump(m,k))/2.0d0 bump(m,k)=bump(m,i) enddo c c fixup e, bookkeeping c e(i)=tqual(i,itnode,vx,vy,lenb,bump,hmin,coeff) kk=q(i) call updhp(kk,ntf,p,q,e,1) e(k)=tqual(k,itnode,vx,vy,lenb,bump,hmin,coeff) kk=q(k) call updhp(kk,ntf,p,q,e,1) if(slist(k).eq.0) then slist(k)=next next=k endif 50 continue if(ichng.ne.0) go to 10 itemp=next next=slist(next) slist(itemp)=0 if(next.gt.0) go to 10 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eswapc(it,iedge,itnode,itedge,ibedge, + lenb,bump,e,iseed,vx,vy,hmin,coeff,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),iseed(*),ibedge(2,*) double precision + bump(lenb,*),e(*),vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c elementary edge swap c kt=itedge(iedge,it)/4 kedge=itedge(iedge,it)-4*kt i1=index(2,iedge) i2=index(3,iedge) k1=index(3,kedge) k2=index(2,kedge) c if(itnode(4,it).ne.itnode(4,kt)) stop 6016 if(itnode(5,it).ne.itnode(5,kt)) stop 6006 c itnode(i1,it)=itnode(kedge,kt) itnode(k2,kt)=itnode(iedge,it) iseed(itnode(i2,it))=4*it+i2 iseed(itnode(k1,kt))=4*kt+k1 itedge(iedge,it)=itedge(k1,kt) itedge(kedge,kt)=itedge(i2,it) itedge(i2,it)=4*kt+k1 itedge(k1,kt)=4*it+i2 c c fixup bump c if(isw.eq.1) then do m=1,lenb bump(m,it)=(bump(m,it)+bump(m,kt))/2.0d0 bump(m,kt)=bump(m,it) enddo e(it)=tqual(it,itnode,vx,vy,lenb,bump,hmin,coeff) e(kt)=tqual(kt,itnode,vx,vy,lenb,bump,hmin,coeff) endif c c fixup neighboring elements c li=itedge(iedge,it)/4 if(li.gt.0) then ll=itedge(iedge,it)-4*li itedge(ll,li)=4*it+iedge else ll=-itedge(iedge,it) if(ibedge(1,ll)/4.eq.kt) then ibedge(1,ll)=4*it+iedge else ibedge(2,ll)=4*it+iedge endif endif lk=itedge(kedge,kt)/4 if(lk.gt.0) then ll=itedge(kedge,kt)-4*lk itedge(ll,lk)=4*kt+kedge else ll=-itedge(kedge,kt) if(ibedge(1,ll)/4.eq.it) then ibedge(1,ll)=4*kt+kedge else ibedge(2,ll)=4*kt+kedge endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,list,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),list(*),index(3,3), 1 ibedge(2,*) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine makes the itedge array for the level 1 elements c iflag=0 do i=1,nvf list(i)=0 enddo llist=nvf+nbf+3*ntf iptr=nvf+1 do i=iptr,llist,2 list(i)=i+2 enddo list(llist-1)=0 list(llist-2)=0 c c put boundary edges on the list c do i=1,nbf ibedge(1,i)=0 ibedge(2,i)=0 imin=min0(ibndry(1,i),ibndry(2,i)) imax=max0(ibndry(1,i),ibndry(2,i)) ii=iptr iptr=list(iptr) list(ii)=list(imin) list(ii+1)=-i list(imin)=ii enddo c c first find adjacent triangles c do i=1,ntf do j=1,3 j2=index(2,j) j3=index(3,j) imax=max0(itnode(j2,i),itnode(j3,i)) imin=min0(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k.le.0) then c c add triangle i, edge j to list c if(iptr.le.0) then iflag=-40 return endif list(kold)=iptr ii=iptr iptr=list(iptr) list(ii)=0 list(ii+1)=j+4*i else c c check for a common edge c if(list(k+1).gt.0) then ii=list(k+1)/4 jj=list(k+1)-4*ii j2=index(2,jj) j3=index(3,jj) iimax=max0(itnode(j2,ii),itnode(j3,ii)) if(imax.eq.iimax) then itedge(j,i)=jj+4*ii itedge(jj,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k c c check geometry c qi=geom(itnode(j,i),imin,imax,vx,vy) qk=geom(itnode(jj,ii),imin,imax,vx,vy) if(qi*qk.ge.0.0d0) then iflag=-32 return endif else kold=k go to 40 endif else ii=-list(k+1) iimax=max0(ibndry(1,ii),ibndry(2,ii)) if(imax.eq.iimax) then itedge(j,i)=-ii if(ibndry(4,ii).eq.0) then if(ibedge(1,ii).ne.0) then ibedge(2,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k else ibedge(1,ii)=j+4*i endif else ibedge(1,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k endif else kold=k go to 40 endif endif endif enddo enddo c c check for left over edges c do i=1,nvf if(list(i).gt.0) then iflag=-48 return endif iflag=0 enddo c c check for illegal interface edges c do i=1,nbf if(ibndry(4,i).eq.0) then if(ibedge(2,i).eq.0) then iflag=-43 return endif k1=ibedge(1,i)/4 ke1=ibedge(1,i)-4*k1 itedge(ke1,k1)=ibedge(2,i) k2=ibedge(2,i)/4 ke2=ibedge(2,i)-4*k2 itedge(ke2,k2)=ibedge(1,i) c* if(itnode(5,k1).eq.itnode(5,k2)) then c* iflag=-43 c* return c* endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cedge5(nbf,itedge,ibedge,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),ibedge(2,*) c c switch modes in itedge c if(isw.eq.1) then do i=1,nbf if(ibedge(2,i).gt.0) then do k=1,2 it=ibedge(k,i)/4 iedge=ibedge(k,i)-4*it itedge(iedge,it)=-i enddo endif enddo else do i=1,nbf if(ibedge(2,i).gt.0) then do k=1,2 it=ibedge(k,i)/4 iedge=ibedge(k,i)-4*it itedge(iedge,it)=ibedge(3-k,i) enddo endif enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,list,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),list(*),index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine makes an ibedge array c iflag=0 do i=1,nvf list(i)=0 enddo llist=nvf+nbf*2 iptr=nvf+1 do i=iptr,llist,2 list(i)=i+2 enddo list(llist-1)=0 list(llist-2)=0 c c put boundary edges on the list c do i=1,nbf ibedge(1,i)=0 ibedge(2,i)=0 c*** if(ibndry(4,i).ne.0) then imin=min0(ibndry(1,i),ibndry(2,i)) imax=max0(ibndry(1,i),ibndry(2,i)) ii=iptr iptr=list(iptr) list(ii)=list(imin) list(ii+1)=-i list(imin)=ii c*** endif enddo c c first find adjacent triangles c do i=1,ntf do j=1,3 j2=index(2,j) j3=index(3,j) imax=max0(itnode(j2,i),itnode(j3,i)) imin=min0(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k.gt.0) then ii=-list(k+1) iimax=max0(ibndry(1,ii),ibndry(2,ii)) if(imax.eq.iimax) then if(ibndry(4,ii).eq.0) then if(ibedge(1,ii).ne.0) then ibedge(2,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k else ibedge(1,ii)=j+4*i endif else ibedge(1,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k endif else kold=k go to 40 endif endif enddo enddo c c check for left over edges c do i=1,nvf if(list(i).gt.0) then iflag=-48 return endif enddo c c check for illegal interface edges c do i=1,nbf if(ibndry(4,i).eq.0) then if(ibedge(2,i).eq.0) then iflag=-43 return endif c** k1=ibedge(1,i)/4 c** k2=ibedge(2,i)/4 c** if(itnode(5,k1).eq.itnode(5,k2)) then c** iflag=-43 c** return c** endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tgen(ip,rp,vx,vy,xm,ym,itnode,ibndry,jb,hloc, + ipoly,itedge,irgn,itptr,ivptr,irptr,list,llist,vx0,vy0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),ip(100),list(*),irgn(5,*), 1 ipoly(3,*),itedge(3,*),itptr(*),ivptr(*),irptr(*) double precision + vx(*),vy(*),xm(*),ym(*),rp(100),hloc(*),vx0(*),vy0(*) data ibit/0/ c c this routine triangulates the user defines regions c ntr=ip(1) nvr=ip(2) ncr=ip(3) nbr=ip(4) maxt=ip(21) maxv=ip(22) maxb=ip(24) c c iflag=0 c set up parameters c rp(15) = hmax c rp(16) = grade c rp(51) = eps c rp(76) = qual c rp(77) = angmn c rp(78) = diam c rp(79) = best c if(rp(15).le.0.0d0.or.rp(15).gt.1.0d0) rp(15)=1.0d0 rp(16)=dmax1(1.5d0,rp(16)) rp(16)=dmin1(2.5d0,rp(16)) eps=8.0d0*ceps(ibit) rp(51)=eps rp(76)=dsqrt(3.0d0)/2.0d0-eps rp(77)=1.0d0/4.0d0-eps call xybox(nbr,vx,vy,xm,ym,ibndry, + rp(87),rp(88),rp(89),rp(90),rp(78)) c c comput local h, refine boundary edges c call lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,xm,ym,itnode, + ibndry,jb,ipoly,hloc,list,vx0,vy0,iflag) if(iflag.ne.0) go to 100 c nlist=llist/2 call sethl(nvr,nbr,ntr,vx,vy,xm,ym,itnode,jb, + ibndry,ipoly,hloc,rp,list,nlist,vx0,vy0,iflag) if(iflag.ne.0) go to 100 c call invv(ntr,nvr,nbr,maxv,maxb,vx,vy,hloc,xm,ym,rp, + ibndry,itnode,list,iflag) if(iflag.ne.0) go to 100 c c save itnode in irgn c do i=1,ntr do j=1,5 irgn(j,i)=itnode(j,i) enddo enddo c c store crude triangulation in tail of itnode c call mktri0(ntr,nvr,nbr,ncr,vx,vy,xm,ym,ibndry,irptr,jb, + itnode,itedge,ipoly,list,llist,maxt,irgn,vx0,vy0,iflag) if(iflag.ne.0) go to 100 c c the main loop in which each subregion is triangulated c nr=ntr ntr=0 itptr(1)=1 ivptr(1)=nvr+1 do ir=1,nr ns=nr-ir+1 if(irgn(3,ir).eq.0) then c c triangulate a region c call tseg(ns,nvr,ntr,maxv,vx,vy,itnode, + ibndry,itedge,ipoly,irptr,rp,iflag) if(iflag.ne.0) go to 100 nt1=itptr(ir) call cedge2(nvr,nt1,ntr,nbr,itnode,itedge,list) call eswap(nt1,ntr,nvr,itnode,itedge,ipoly,vx,vy) nv1=ivptr(ir) call mfe0(nv1,nvr,nt1,ntr,itnode,itedge,vx,vy,list) else c c triangulate a region similar to a previous region c call csym(ns,ir,nvr,ntr,maxv,vx,vy,itnode,itedge, + ipoly,irgn,itptr,ivptr,irptr,rp,iflag) if(iflag.ne.0) go to 100 endif itptr(ir+1)=ntr+1 ivptr(ir+1)=nvr+1 enddo c c c 100 ip(1)=ntr ip(2)=nvr ip(3)=ncr ip(4)=nbr ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tseg(ns,nvr,ntr,maxv,vx,vy,itnode, + ibndry,itedge,ipoly,irptr,rp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),irptr(*), 1 ipoly(3,*),itedge(3,*),index(3,3) double precision + vx(*),vy(*),rp(100) save index data index/1,2,3,2,3,1,3,1,2/ c iflag=0 ns0=ns c c initialize ipoly c 5 it1=irptr(ns+1)+1 it2=irptr(ns) do i=it1,it2 do j=1,3 if(itedge(j,i).le.0) then j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) ipoly(1,j1)=j2 ipoly(2,j2)=j1 ipoly(3,j1)=4*i+j endif enddo enddo c c the main loop for chopping off triangles c kv=itnode(1,it1) 10 num=it2-it1+3 rp(79)=0.0d0 jchop=0 do i=1,num call tchop(j,kv,vx,vy,rp,itedge,ibndry,ipoly) if(j.ne.0) then jchop=kv if(j.eq.1) go to 70 endif kv=ipoly(1,kv) enddo c c test for convex region with 6 or fewer sides c call tcnvx(jcnvx,ns,irptr,itnode,vx,vy,rp,nvr,maxv,ipoly) if(jcnvx.eq.1) go to 80 c c link two non-adjacent vertices c jlink=0 kv=itnode(1,it1) rp(79)=0.0d0 do i=1,num call tlink(j,kv,kk,vx,vy,ipoly,rp,itnode,itedge) if(j.ne.0) then klink=kk jlink=kv if(j.eq.1) go to 90 endif kv=ipoly(1,kv) enddo c c make the best of a bad situation c if(jlink.ne.0) go to 90 if(jcnvx.ne.0) go to 80 if(jchop.eq.0) stop 8421 c c add a new triangle by chopping off one corner of the polygon c 70 kv=ipoly(1,jchop) call cchop(jchop,ntr,ns,irptr,itnode,itedge,ipoly) it1=irptr(ns+1)+1 it2=irptr(ns) if(it1.gt.it2) then ns=ns-1 if(ns.lt.ns0) return go to 5 endif go to 10 c c triangulate the remaining convex polygon c by adding one knot at the centroid c 80 call ccnvx(ns,nvr,ntr,maxv,vx,vy,itnode,irptr,ipoly,iflag) if(iflag.ne.0) return ns=ns-1 if(ns.lt.ns0) return go to 5 c c make jlink-klink link...add necessary vertices and adjust regions c 90 call clink(jlink,klink,ns,nvr,maxv,ntr, + vx,vy,ipoly,irptr,itnode,itedge,rp,iflag) if(iflag.ne.0) return go to 5 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine csym(nsr,ns,nvr,ntr,maxv,vx,vy,itnode,itedge, + ipoly,irgn,itptr,ivptr,irptr,rp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),irgn(5,*),itptr(*),ivptr(*),irptr(*), 1 ipoly(3,*),index(3,3),itedge(3,*) double precision + vx(*),vy(*),rp(100) save index data index/1,2,3,2,3,1,3,1,2/ c c triangluate a region similar to a previously triangulated region c iflag=0 tol=(rp(51)*rp(78))**2 nso=iabs(irgn(3,ns)) if(nso.eq.0.or.nso.ge.ns) go to 100 c c put region ns in ipoly(1,*) c len=0 it1=irptr(nsr+1)+1 it2=irptr(nsr) do i=it1,it2 do j=1,3 if(itedge(j,i).le.0) then j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) ipoly(1,j1)=j2 len=len+1 endif enddo enddo c c put region nso in ipoly(2,*) (noting reflection) c leno=0 jt1=itptr(nso) jt2=itptr(nso+1)-1 do i=jt1,jt2 do j=1,3 if(itedge(j,i).le.0) then j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) if(irgn(3,ns).gt.0) then ipoly(2,j1)=j2 else ipoly(2,j2)=j1 endif leno=leno+1 endif enddo enddo if(len.ne.leno) go to 100 c c mark equivalent vertices in ipoly(3,*) c iv=irgn(1,ns) ivo=irgn(1,nso) kv=iv kvo=ivo do i=1,len ipoly(3,kvo)=kv kv=ipoly(1,kv) kvo=ipoly(2,kvo) enddo c c c if(irgn(3,ns).lt.0) then m1=2 m2=1 sn=-1.0d0 else m1=1 m2=2 sn=1.0d0 endif c c compute affine transformation c kv=ipoly(1,iv) kvo=ipoly(2,ivo) dx=vx(kv)-vx(iv) dy=vy(kv)-vy(iv) dxo=vx(kvo)-vx(ivo) dyo=vy(kvo)-vy(ivo) dd=dxo*dxo+dyo*dyo a11=(dx*dxo+dy*dyo*sn)/dd a12=(dx*dyo-dy*dxo*sn)/dd a21=-a12*sn a22=a11*sn xx=vx(iv)-a11*vx(ivo)-a12*vy(ivo) yy=vy(iv)-a21*vx(ivo)-a22*vy(ivo) c c check affine map on all boundary points c kv=iv kvo=ivo do i=1,len kv=ipoly(1,kv) kvo=ipoly(2,kvo) dx=a11*vx(kvo)+a12*vy(kvo)+xx-vx(kv) dy=a21*vx(kvo)+a22*vy(kvo)+yy-vy(kv) if(dx*dx+dy*dy.gt.tol) go to 100 enddo c c compute new interior vertices c n1=ivptr(nso) n2=ivptr(nso+1)-1 if(n1.le.n2) then if(nvr+n2-n1+1.gt.maxv) then iflag=22 return endif do k=n1,n2 nvr=nvr+1 vx(nvr)=a11*vx(k)+a12*vy(k)+xx vy(nvr)=a21*vx(k)+a22*vy(k)+yy ipoly(3,k)=nvr enddo endif c c compute new triangles c if(ntr+jt2-jt1+1.gt.it2) then iflag=21 return endif jtag=itnode(4,it1) itag=itnode(5,it1) do k=jt1,jt2 ntr=ntr+1 itnode(m1,ntr)=ipoly(3,itnode(1,k)) itnode(m2,ntr)=ipoly(3,itnode(2,k)) itnode(3,ntr)=ipoly(3,itnode(3,k)) itnode(4,ntr)=jtag itnode(5,ntr)=itag enddo return 100 iflag=-55 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cequv(nvr,nbr,ntr,itnode,jb,ibndry,iequv,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*),iequv(*) c c initialize iequv c iflag=0 do i=1,nvr iequv(i)=i enddo c c order knots in ibndry counterclockwise for boundary edges c internal edges are counterclockwise wrt higher numbered region c do ns=1,ntr i1=jb(ns) i2=jb(ns+1)-1 ie2=jb(i2) do i=i1,i2 ie1=jb(i) iv=ibndry(1,ie1) if(iv.ne.ibndry(1,ie2).and.iv.ne.ibndry(2,ie2)) then iv=ibndry(2,ie1) ibndry(2,ie1)=ibndry(1,ie1) ibndry(1,ie1)=iv endif ie2=ie1 enddo enddo c c mark periodic vertices c do 30 i=1,nbr if(ibndry(4,i).ge.0) go to 30 j=-ibndry(4,i) if(j.lt.i) go to 30 do 20 mm=1,2 iv=ibndry(mm,i) jv=ibndry(3-mm,j) it=iv 10 it=iequv(it) if(it.eq.jv) go to 20 if(it.ne.iv) go to 10 it=iequv(iv) iequv(iv)=iequv(jv) iequv(jv)=it 20 continue 30 continue c c set up equivalence classes for vertices c do 60 ns=1,ntr if(itnode(3,ns).eq.0) go to 60 nso=iabs(itnode(3,ns)) if(nso.ge.ns) go to 200 i1=jb(ns) i2=jb(ns+1)-1 j1=jb(nso) j2=jb(nso+1)-1 if(i2-i1.ne.j2-j1) go to 200 ie1=jb(i1) ie2=jb(i2) je1=jb(j1) je2=jb(j2) c c find common vertex c iv=ibndry(1,ie1) if(iv.ne.ibndry(1,ie2).and.iv.ne.ibndry(2,ie2)) + iv=ibndry(2,ie1) jv=ibndry(1,je1) if(jv.ne.ibndry(1,je2).and.jv.ne.ibndry(2,je2)) + jv=ibndry(2,je1) if(itnode(3,ns).gt.0) then j=j1 inc=1 else j=j2 inc=-1 endif do i=i1,i2 jbi=jb(i) jbj=jb(j) it=iv 40 it=iequv(it) if(it.eq.jv) go to 50 if(it.ne.iv) go to 40 it=iequv(iv) iequv(iv)=iequv(jv) iequv(jv)=it 50 iv=ibndry(1,jbi)+ibndry(2,jbi)-iv jv=ibndry(1,jbj)+ibndry(2,jbj)-jv j=j+inc enddo 60 continue c c final form of iequv c do i=1,nvr if(iequv(i).gt.0) then next=iequv(i) last=i 70 iequv(last)=-i if(next.ne.i) then last=next next=iequv(next) go to 70 endif endif enddo do i=1,nvr iequv(i)=-iequv(i) enddo return 200 iflag=-55 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sethl(nvr,nbr,ntr,vx,vy,xm,ym,itnode,jb, + ibndry,iequv,hloc,rp,list,llist,vx0,vy0,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*),iequv(*),list(2,*) double precision + vx(*),vy(*),hloc(*),rp(100),xm(*),ym(*),vx0(*),vy0(*), 1 p(2),dp(2),q(2),dq(2),al(2),ang(2),theta(2),cen(2) c c compute appropriate values of hloc c itmax=nvr tol=1.0d-3 iflag=0 eps=rp(51) grade=rp(16) hmax=rp(78)*rp(15) c c initialize iequv c call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,jb,list, + vx0,vy0,iflag) if(iflag.ne.0) return call cequv(nvr,nbr,ntr,itnode,jb,ibndry,iequv,iflag) if(iflag.ne.0) return c c initialize hloc using edge lengths c do i=1,nvr hloc(iequv(i))=hmax enddo do i=1,nbr j1=ibndry(1,i) j2=ibndry(2,i) jc=ibndry(3,i) if(jc.gt.0) then call arc(vx(j1),vy(j1),vx(j2),vy(j2), + xm(jc),ym(jc),theta1,theta2,radius,d) else d=dsqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+ + (vy(j1)-vy(j2))*(vy(j1)-vy(j2))) endif hloc(iequv(j1))=dmin1(d,hloc(iequv(j1))) hloc(iequv(j2))=dmin1(d,hloc(iequv(j2))) enddo c c compute list of edge-vertex parirs to be made consistant c ncount=0 do 100 ns=1,ntr if(itnode(3,ns).ne.0) go to 100 i1=jb(ns) i2=jb(ns+1)-1 ie1=jb(i1) ie2=jb(i2) lv=ibndry(1,ie1) if(lv.ne.ibndry(1,ie2).and.lv.ne.ibndry(2,ie2)) + lv=ibndry(2,ie1) ist=lv do i=i1,i2 ie1=jb(i) iv=lv jv=ibndry(1,ie1)+ibndry(2,ie1)-iv jc=ibndry(3,ie1) p(1)=(vx(iv)+vx(jv))/2.0d0 p(2)=(vy(iv)+vy(jv))/2.0d0 dp(1)=(vx(jv)-vx(iv))/2.0d0 dp(2)=(vy(jv)-vy(iv))/2.0d0 dq(1)=dp(2) dq(2)=-dp(1) kv=ist do jj=i1,i2 je1=jb(jj) if(kv.eq.iv.or.kv.eq.jv) go to 90 q(1)=vx(kv) q(2)=vy(kv) if(jc.gt.0) then cen(1)=xm(jc) cen(2)=ym(jc) call arc(vx(iv),vy(iv),vx(jv),vy(jv),xm(jc), + ym(jc),theta(1),theta(2),radius,d) call liarc(q,dq,cen,theta,radius,npts, + al,ang,eps) if(npts.ne.1) go to 90 if(al(1).le.eps) go to 90 else call lil(p,dp,q,dq,al,jflag) if(jflag.ne.0) go to 90 if(dabs(al(1)).ge.1.0d0+eps) go to 90 if(al(2).le.eps) go to 90 endif ncount=ncount+1 if(ncount.gt.llist) go to 200 list(1,ncount)=kv list(2,ncount)=ie1 90 kv=ibndry(1,je1)+ibndry(2,je1)-kv enddo lv=ibndry(1,ie1)+ibndry(2,ie1)-lv enddo 100 continue c c final loop where hloc values are made consistant c do itnum=1,itmax ratio=0.0d0 c c check all edges c do i=1,nbr iv=ibndry(1,i) jv=ibndry(2,i) jc=ibndry(3,i) if(hloc(iequv(iv)).gt.hloc(iequv(jv))) then iv=jv jv=ibndry(1,i) endif if(jc.gt.0) then call arc(vx(iv),vy(iv),vx(jv),vy(jv), + xm(jc),ym(jc),theta1,theta2,radius,d) else dp(1)=(vx(jv)-vx(iv)) dp(2)=(vy(jv)-vy(iv)) d=dsqrt(dp(1)*dp(1)+dp(2)*dp(2)) endif r=((grade-1.0d0)*d+hloc(iequv(iv)))/grade if(r.lt.hloc(iequv(jv))) then ratio=dmax1(ratio,hloc(iequv(jv))/r) hloc(iequv(jv))=r endif enddo c c now check edge-vertex pairs c if(ratio-1.0d0.le.tol.and.ncount.le.0) go to 190 do 170 i=1,ncount kv=list(1,i) ie1=list(2,i) iv=ibndry(1,ie1) jv=ibndry(2,ie1) jc=ibndry(3,ie1) if(hloc(iequv(iv)).gt.hloc(iequv(jv))) then iv=jv jv=ibndry(1,ie1) endif q(1)=vx(kv) q(2)=vy(kv) dp(1)=(vx(jv)-vx(iv))/2.0d0 dp(2)=(vy(jv)-vy(iv))/2.0d0 dq(1)=dp(2) dq(2)=-dp(1) d=dsqrt(dp(1)*dp(1)+dp(2)*dp(2)) if(jc.gt.0) then cen(1)=xm(jc) cen(2)=ym(jc) call arc(vx(iv),vy(iv),vx(jv),vy(jv), + xm(jc),ym(jc),theta(1),theta(2),radius,dd) else p(1)=(vx(iv)+vx(jv))/2.0d0 p(2)=(vy(iv)+vy(jv))/2.0d0 dd=2.0d0*d endif c c check length of edge ie1 c r=((grade-1.0d0)*dd+hloc(iequv(iv)))/grade if(r.lt.hloc(iequv(jv))) then ratio=dmax1(ratio,hloc(iequv(jv))/r) hloc(iequv(jv))=r endif if(jc.gt.0) then call liarc(q,dq,cen,theta,radius,npts,al,ang,eps) z=d*dabs(al(1)) fr=(ang(1)-theta(1))/(theta(2)-theta(1)) if(iv.ne.ibndry(1,ie1)) fr=1.0d0-fr else call lil(p,dp,q,dq,al,jflag) z=d*dabs(al(2)) fr=(al(1)+1.0d0)/2.0d0 endif hb=hloc(iequv(iv))+fr*(hloc(iequv(jv))-hloc(iequv(iv))) ht=hloc(iequv(kv)) if(ht.lt.hb) then c c the case where hloc on the edge (iv,jv) is bigger c r=((grade-1.0d0)*z+ht)/grade r=dmin1(r,z) if(r.ge.hb) go to 170 c c nearer to iv c if(fr.lt.0.25d0) then rj=((grade-1.0d0)*fr*dd+r)/grade rj=dmin1(rj,hloc(iequv(jv))) ri=rj+(r-rj)/(1.0d0-fr) ri=dmax1(r/grade,ri) ri=dmin1(ri,hloc(iequv(iv))) rj=((grade-1.0d0)*dd+ri)/grade rj=dmin1(rj,hloc(iequv(jv))) c c nearer to jv c else if(fr.gt.0.75d0) then ri=((grade-1.0d0)*(1.0d0-fr)*dd+r)/grade ri=dmin1(ri,hloc(iequv(iv))) rj=ri+(r-ri)/fr rj=dmax1(r/grade,rj) rj=dmin1(rj,hloc(iequv(jv))) ri=((grade-1.0d0)*dd+rj)/grade ri=dmin1(ri,hloc(iequv(iv))) c c middle of interval c else ri=dmin1(r,hloc(iequv(iv))) rj=ri+(r-ri)/fr rj=dmin1(rj,z,hloc(iequv(jv))) endif c ratio=dmax1(ratio,hloc(iequv(iv))/ri) hloc(iequv(iv))=dmin1(ri,hloc(iequv(iv))) ratio=dmax1(ratio,hloc(iequv(jv))/rj) hloc(iequv(jv))=dmin1(rj,hloc(iequv(jv))) else c c the case where hloc at vertex kv is bigger c r=((grade-1.0d0)*z+hb)/grade r=dmin1(r,z) if(r.lt.ht) then ratio=dmax1(ratio,hloc(iequv(kv))/r) hloc(iequv(kv))=r endif endif 170 continue if(ratio-1.0d0.le.tol) go to 190 enddo 190 do i=1,nvr hloc(i)=hloc(iequv(i)) enddo return 200 iflag=20 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine invv(ntr,nvr,nbr,maxv,maxb,vx,vy,hloc,xm,ym,rp, + ibndry,itnode,list,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),list(*) double precision + vx(*),vy(*),hloc(*),xm(*),ym(*),rp(100) c c divide user specified edges c iflag=0 pi=3.141592653589793d0 nbr0=nbr do i=1,nbr0 list(i)=nbr+1 j1=ibndry(1,i) j2=ibndry(2,i) c c the case of a curved edge c if(ibndry(3,i).gt.0) then jc=ibndry(3,i) call arc(vx(j1),vy(j1),vx(j2),vy(j2), + xm(jc),ym(jc),theta1,theta2,radius,d) xc=xm(jc) yc=ym(jc) call dvpram(hloc(j1),hloc(j2),d,rp,al,h,np) if(nvr+np.gt.maxv) then iflag=22 return endif if(nbr+np.gt.maxb) then iflag=23 return endif c c add new points on circular arc c if(np.gt.0) then nvsave=nvr dt=theta2-theta1 q=0.0d0 do j=1,np q=q+h h=h*al arg=(theta1+q*dt)*pi nvr=nvr+1 vx(nvr)=xc+radius*dcos(arg) vy(nvr)=yc+radius*dsin(arg) nbr=nbr+1 ibndry(1,nbr)=nvr ibndry(2,nbr)=nvr+1 ibndry(3,nbr)=ibndry(3,i) ibndry(4,nbr)=ibndry(4,i) ibndry(5,nbr)=ibndry(5,i) ibndry(6,nbr)=ibndry(6,i) enddo ibndry(2,nbr)=j2 ibndry(2,i)=nvsave+1 endif c c the case of a straight edge c else d=dsqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+ + (vy(j1)-vy(j2))*(vy(j1)-vy(j2))) call dvpram(hloc(j1),hloc(j2),d,rp,al,h,np) if(nvr+np.gt.maxv) then iflag=22 return endif if(nbr+np.gt.maxb) then iflag=23 return endif c c add new vertices along a line segment c if(np.gt.0) then nvsave=nvr p1=vx(j1) p2=vy(j1) dp1=vx(j2)-p1 dp2=vy(j2)-p2 q=0.0d0 do j=1,np q=q+h h=h*al nvr=nvr+1 vx(nvr)=p1+q*dp1 vy(nvr)=p2+q*dp2 nbr=nbr+1 ibndry(1,nbr)=nvr ibndry(2,nbr)=nvr+1 ibndry(3,nbr)=0 ibndry(4,nbr)=ibndry(4,i) ibndry(5,nbr)=ibndry(5,i) ibndry(6,nbr)=ibndry(6,i) enddo ibndry(2,nbr)=j2 ibndry(2,i)=nvsave+1 endif endif enddo list(nbr0+1)=nbr+1 c c fix itnode c do i=1,ntr k=itnode(1,i) j=itnode(2,i) if(ibndry(1,j).ne.k.and.ibndry(2,j).ne.k) then jj=list(j+1)-1 if(ibndry(2,jj).ne.k) stop 9327 itnode(2,i)=jj endif enddo c c periodic boundary edges c do i=1,nbr0 if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibeg=list(i) iend=list(i+1) kbeg=list(k) kend=list(k+1) if(ibeg.lt.iend) then do j=ibeg,iend if(j.eq.iend) then ibndry(4,i)=-(kend-1) else if(j.eq.iend-1) then ibndry(4,iend-1)=-k else ibndry(4,j)=-(kend-2+ibeg-j) endif enddo endif endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mktri0(ntr,nvr,nbr,ncr,vx,vy,xm,ym,ibndry,irptr,jb, + itnode,itedge,vindex,list,llist,maxt,irgn,vx0,vy0,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jb(*),itnode(5,*),irgn(5,*), 1 itedge(3,*),list(*),vindex(*),irptr(*),index(3,3) double precision + vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*) save index data index/1,2,3,2,3,1,3,1,2/ c c make a crude triangulation of the skeleton c iflag=0 call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,jb,list, + vx0,vy0,iflag) if(iflag.ne.0) return c i1=1 i2=nvr+1 i3=(llist-i2+1)/2 irptr(1)=maxt do itag=ntr,1,-1 nb1=jb(itag) nb2=jb(itag+1)-1 ie1=jb(nb1) ie2=jb(nb2) ivc=ibndry(1,ie1) if(ivc.ne.ibndry(1,ie2).and.ivc.ne.ibndry(2,ie2)) + ivc=ibndry(2,ie1) nn=0 do jj=nb1,nb2 it=jb(jj) ivn=ibndry(1,it)+ibndry(2,it)-ivc nn=nn+1 vindex(nn)=ivc ivc=ivn enddo j4tag=irgn(4,itag) j5tag=irgn(5,itag) irptr(ntr-itag+2)=irptr(ntr-itag+1)-nn+2 nt1=irptr(ntr-itag+2)+1 nt2=irptr(ntr-itag+1) ntt=nt1-1 call trisk(nn,vx,vy,vindex,ntt,itnode,j4tag,j5tag, + list(i1),list(i2),list(i3)) call cedgek(nvr,nt1,nt2,nb1,nb2,itnode,ibndry, + itedge,jb,vx,vy,list) call eswapk(nt1,nt2,itnode,itedge,vx,vy) enddo c c determine boundary and internal interface edges c do i=1,nbr if(ibndry(4,i).ne.0) then list(i)=1 else list(i)=0 endif enddo do i=1,ntr ie1=jb(i) ie2=jb(i+1)-1 do k=ie1,ie2 j=jb(k) if(list(j).lt.0) then m=-list(j) if(irgn(5,m).ne.irgn(5,i)) list(j)=1 else if(list(j).eq.0) then list(j)=-i endif enddo enddo c c set up final form of ibndry by removing interior edges c nbr0=nbr nbr=0 do i=1,nbr0 if(list(i).le.0) then jb(i)=0 else nbr=nbr+1 jb(i)=nbr do j=1,6 ibndry(j,nbr)=ibndry(j,i) enddo endif enddo c do i=1,nbr if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,i)=-jb(k) endif enddo c c fixup itedge to refect ibndry update, orient ibndry c do i=nt1,maxt do j=1,3 k=-itedge(j,i) if(k.gt.0) then itedge(j,i)=-jb(k) if(jb(k).gt.0) then ibndry(1,jb(k))=itnode(index(2,j),i) ibndry(2,jb(k))=itnode(index(3,j),i) endif endif enddo enddo c c now fixup xm,ym c if(ncr.eq.0) return do i=1,ncr jb(i)=0 enddo do i=1,nbr if(ibndry(3,i).gt.0) jb(ibndry(3,i))=1 enddo c ncr0=ncr ncr=0 do i=1,ncr0 if(jb(i).eq.1) then ncr=ncr+1 jb(i)=ncr xm(ncr)=xm(i) ym(ncr)=ym(i) endif enddo do i=1,nbr if(ibndry(3,i).gt.0) ibndry(3,i)=jb(ibndry(3,i)) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine drgrdx(vx,vy,nv,nt1,nt2,itnode) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),x(4),y(4),z(4),red(6),green(6),blue(6) save red,green,blue data red/1.0d0,0.0d0,1.0d0,0.0d0,0.0d0,1.0d0/ data green/1.0d0,0.0d0,0.0d0,0.0d0,1.0d0,1.0d0/ data blue/1.0d0,0.0d0,0.0d0,1.0d0,0.0d0,0.0d0/ c call pltutl(6,red,green,blue) c write(6,*) 'nv',nv,nt1,nt2 ax=vx(itnode(1,nt1+1)) bx=ax ay=vy(itnode(1,nt1+1)) by=ay do i=nt1+1,nt2 do j=1,3 ax=dmin1(ax,vx(itnode(j,i))) bx=dmax1(bx,vx(itnode(j,i))) ay=dmin1(ay,vy(itnode(j,i))) by=dmax1(by,vy(itnode(j,i))) enddo enddo dx=bx-ax dy=by-ay dd=dmax1(dx,dy) scale=0.9d0/dd xshift=0.5d0-scale*(ax+bx)/2.0d0 yshift=0.5d0-scale*(ay+by)/2.0d0 do i=1,4 z(i)=0.0d0 enddo do i=nt1+1,nt2 if(itnode(1,i).gt.0) then do j=1,3 x(j)=vx(itnode(j,i))*scale+xshift y(j)=vy(itnode(j,i))*scale+yshift enddo x(4)=x(1) y(4)=y(1) call pline(x,y,z,4,2) endif enddo c call pltutl(-1,red,green,blue) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine drgrdz(ibegin,iend,index,vx,vy,nt1,nt2,itnode) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(*) double precision + vx(*),vy(*),x(5),y(5),z(5),red(6),green(6),blue(6) save red,green,blue data red/1.0d0,0.0d0,1.0d0,0.0d0,0.0d0,1.0d0/ data green/1.0d0,0.0d0,0.0d0,0.0d0,1.0d0,1.0d0/ data blue/1.0d0,0.0d0,0.0d0,1.0d0,0.0d0,0.0d0/ c call pltutl(6,red,green,blue) c ax=vx(index(ibegin)) bx=ax ay=vy(index(ibegin)) by=ay do i=ibegin,iend ax=dmin1(ax,vx(index(i))) bx=dmax1(bx,vx(index(i))) ay=dmin1(ay,vy(index(i))) by=dmax1(by,vy(index(i))) enddo dx=bx-ax dy=by-ay dd=dmax1(dx,dy) scale=0.9d0/dd xshift=0.5d0-scale*(ax+bx)/2.0d0 yshift=0.5d0-scale*(ay+by)/2.0d0 j=iend h=.005d0 do i=1,5 z(i)=0.0d0 enddo do i=ibegin,iend x(1)=vx(index(i))*scale+xshift y(1)=vy(index(i))*scale+yshift x(2)=vx(index(j))*scale+xshift y(2)=vy(index(j))*scale+yshift call pline(x,y,z,2,2) xx=x(1) yy=y(1) x(1)=xx+h y(1)=yy+h x(2)=xx-h y(2)=yy+h x(3)=xx-h y(3)=yy-h x(4)=xx+h y(4)=yy-h x(5)=xx+h y(5)=yy+h call pline(x,y,z,5,2) j=i enddo do i=nt1+1,nt2 if(itnode(1,i).gt.0) then do j=1,3 x(j)=vx(itnode(j,i))*scale+xshift y(j)=vy(itnode(j,i))*scale+yshift enddo x(4)=x(1) y(4)=y(1) call pline(x,y,z,4,2) endif enddo c call pltutl(-1,red,green,blue) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tswap(it1,it2,itnode,itedge) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),iadj1(3),iadj2(3) c c swap triangles it1 and it2 c c first fix up itedge (must be careful to handle case when c it1 and it2 are neighbors correctly) c if(it1.eq.it2) return do j=1,3 iadj1(j)=itedge(j,it1) iadj2(j)=itedge(j,it2) enddo do j=1,3 if(iadj1(j).gt.0) then kt=iadj1(j)/4 ke=iadj1(j)-4*kt itedge(ke,kt)=4*it2+j endif if(iadj2(j).gt.0) then kt=iadj2(j)/4 ke=iadj2(j)-4*kt itedge(ke,kt)=4*it1+j endif enddo do j=1,5 k=itnode(j,it1) itnode(j,it1)=itnode(j,it2) itnode(j,it2)=k enddo do j=1,3 k=itedge(j,it1) itedge(j,it1)=itedge(j,it2) itedge(j,it2)=k enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tchop(ichop,kv,vx,vy,rp,itedge,ibndry,ipoly) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),ibndry(6,*),ipoly(3,*),index(3,3) double precision + vx(*),vy(*),rp(100) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine decides whether it is a good idea to c chop off the triangle it c qual=rp(76) best=rp(79) ichop=0 c c find vertex to chop c ka=ipoly(1,kv) kb=ipoly(2,kv) it=ipoly(3,kv)/4 if(it.ne.ipoly(3,kb)/4) return c c check geometry c gg=geom(kb,kv,ka,vx,vy) currnt=dmin1(1.0d0,gg/qual) if(currnt.le.best) return c c check for two boundary edges c c ied=ipoly(3,kv)-4*it c jj=index(2,ied) c if(itedge(jj,it).gt.0) then c ib1=-itedge(index(2,jj),it) c ib2=-itedge(index(3,jj),it) c if(min0(ib1,ib2).gt.0) then c if(min0(ibndry(3,ib1),ibndry(3,ib2)).gt.0) return cc currnt=currnt/2.0e0 cc if(currnt.le.best) return c endif c else c ic=0 c do j=1,3 c ibj=-itedge(j,it) c if(ibj.gt.0) then c if(ibndry(3,ibj).gt.0) ic=ic+1 c endif c enddo c if(ic.gt.1) return c endif ichop=1 if(currnt.lt.1.0d0) ichop=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cchop(kv,ntr,ns,irptr,itnode,itedge,ipoly) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),irptr(*),itedge(3,*),ipoly(3,*), 1 index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c chop off triangle it c it1=irptr(ns+1)+1 irptr(ns+1)=it1 it2=irptr(ns) it=ipoly(3,kv)/4 if(it.lt.it1.or.it.gt.it2) stop 1093 call tswap(it1,it,itnode,itedge) ntr=ntr+1 do j=1,5 itnode(j,ntr)=itnode(j,it1) enddo do j=1,3 if(itedge(j,it1).gt.0) then k=itedge(j,it1)/4 ke=itedge(j,it1)-4*k itedge(ke,k)=0 c j1=itnode(index(2,ke),k) j2=itnode(index(3,ke),k) ipoly(1,j1)=j2 ipoly(2,j2)=j1 ipoly(3,j1)=4*k+ke endif enddo if(it.gt.it1) then do j=1,3 if(itedge(j,it).le.0) then j1=itnode(index(2,j),it) ipoly(3,j1)=4*it+j endif enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tcnvx(icnvx,ns,irptr,itnode,vx,vy,rp,nvr,maxv,ipoly) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + irptr(*),itnode(5,*),ipoly(3,*) double precision + vx(*),vy(*),rp(100) c c this routine checks if a convex region can be c triangulated by adding one vertex at the centriod c icnvx=0 it1=irptr(ns+1)+1 it2=irptr(ns) num=it2-it1+3 if(num.ge.7) return if(nvr+1.gt.maxv) return qual=rp(76) best=rp(79) currnt=1.0d0 cc if(num.eq.7) currnt=0.9e0 cc if(num.eq.8) currnt=0.8e0 cc if(currnt.le.best) return c c compute centroid c kv=itnode(1,it1) x=0.0d0 y=0.0d0 do i=1,num x=x+vx(kv) y=y+vy(kv) kv=ipoly(1,kv) enddo nvr1=nvr+1 vx(nvr1)=x/dfloat(num) vy(nvr1)=y/dfloat(num) c c check geometry c do i=1,num g=geom(kv,ipoly(1,kv),nvr1,vx,vy) currnt=dmin1(currnt,g/qual) if(currnt.le.best) return kv=ipoly(1,kv) enddo if(currnt.le.0.0d0) return icnvx=1 if(currnt.lt.1.0d0) icnvx=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ccnvx(ns,nvr,ntr,maxv,vx,vy,itnode,irptr,ipoly,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + irptr(*),itnode(5,*),ipoly(3,*) double precision + vx(*),vy(*) c c add centroid to convex region c list array computed in icnvx c iflag=0 it1=irptr(ns+1)+1 it2=irptr(ns) num=it2-it1+3 if(ntr+num.gt.it2) then iflag=21 return endif if(nvr+1.gt.maxv) then iflag=22 return endif c c compute centroid c kv=itnode(1,it1) x=0.0d0 y=0.0d0 do i=1,num x=x+vx(kv) y=y+vy(kv) kv=ipoly(1,kv) enddo nvr=nvr+1 vx(nvr)=x/dfloat(num) vy(nvr)=y/dfloat(num) c c make triangles c jtag=itnode(4,it1) itag=itnode(5,it1) do i=1,num itnode(1,ntr+i)=kv itnode(2,ntr+i)=ipoly(1,kv) itnode(3,ntr+i)=nvr itnode(4,ntr+i)=jtag itnode(5,ntr+i)=itag kv=ipoly(1,kv) enddo ntr=ntr+num return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tlink(ilink,kv,kk,vx,vy,ipoly,rp,itnode,itedge) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipoly(3,*),itnode(5,*),itedge(3,*),index(3,3) double precision + vx(*),vy(*),rp(100) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine determines the best point, if any, to c be linked with kv. it is return in kk. c angmn=rp(77) best=rp(79) angmin=1.0d0/20.0d0 angmax=2.0d0-angmin ilink=0 c c kk=0 currnt=0.0d0 ks=ipoly(1,kv) kf=ipoly(2,kv) xx=vx(kv) yy=vy(kv) kt=ipoly(3,kv)/4 ke=ipoly(3,kv)-4*kt 10 km=itnode(ke,kt) if(km.ne.kf) then jt=itedge(index(3,ke),kt) kt=jt/4 ke=jt-4*kt kb=ipoly(2,km) ka=ipoly(1,km) c c compute spacing c dx=vx(km)-xx dy=vy(km)-yy dd=dsqrt(dx*dx+dy*dy) hv=chloc(kf,kv,ks,vx,vy) hk=chloc(kb,km,ka,vx,vy) call dvpram(hv,hk,dd,rp,qa,ha,nps) if(nps.eq.0) go to 10 c c compute angles c a1=cang(km,kv,ks,vx,vy) a2=cang(kf,kv,km,vx,vy) a3=cang(kb,km,kv,vx,vy) a4=cang(kv,km,ka,vx,vy) aamin=dmin1(a1,a2,a3,a4) aamax=dmax1(a1,a2,a3,a4) if(aamin.lt.angmin.or.aamax.gt.angmax) go to 10 testkm=dmin1(1.0d0,aamin/angmn) c if(ka.eq.kf.or.kb.eq.ks) testkm=testkm/2.0d0 if(testkm.gt.currnt) then c c km is the best point found so far c currnt=testkm kk=km if(currnt.eq.1.0d0) go to 180 endif go to 10 endif if(kk.eq.0) return if(currnt.le.best) return 180 ilink=1 if(currnt.lt.1.0d0) ilink=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rlink(hl,hr,d,rp,xl,yl,xr,yr,vx,vy,nvr,maxv,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100),vx(*),vy(*) c iflag=0 call dvpram(hl,hr,d,rp,alpha,h,np) if(np.eq.0) return if(nvr+np.gt.maxv) then iflag=22 return endif if(np.eq.0) return qq=0.0d0 dx=xr-xl dy=yr-yl do i=1,np qq=qq+h h=h*alpha vx(nvr+i)=xl+qq*dx vy(nvr+i)=yl+qq*dy enddo nvr=nvr+np return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clink(kv,kk,ns,nvr,maxv,ntr, + vx,vy,ipoly,irptr,itnode,itedge,rp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ipoly(3,*),irptr(*),itnode(5,*),itedge(3,*),index(3,3) double precision + vx(*),vy(*),rp(100), 1 p(2),dp(2),q(2),dq(2),al(2) save index data index/1,2,3,2,3,1,3,1,2/ c c add new point along the line connecting kv and kk c iflag=0 grade=rp(16) hmax=rp(78)*rp(15) it1=irptr(ns+1)+1 it2=irptr(ns) num=it2-it1+3 nvr0=nvr c c compute points on linking line c d=dsqrt((vx(kv)-vx(kk))**2+(vy(kv)-vy(kk))**2) ka=ipoly(1,kk) kb=ipoly(2,kk) ks=ipoly(1,kv) kf=ipoly(2,kv) hk=chloc(kb,kk,ka,vx,vy) hv=chloc(kf,kv,ks,vx,vy) c c see if increasing h towards the middle of the interval c is possible or worthwhile c if(num.le.8) go to 60 if(d.le.grade*(hv+hk)) go to 60 ds=d*(grade-1.0d0)/grade theta=(hv-hk)/(2.0d0*ds) if(dabs(theta).gt.0.4d0) go to 60 fv=0.5d0-theta fk=0.5d0+theta hm=(ds+hv+hk)/2.0d0 hmin=fv*hk+fk*hv hm=dmin1(hm,hmax) if(hm.lt.hmin) go to 60 c c set up lines c xm=fv*vx(kk)+fk*vx(kv) ym=fv*vy(kk)+fk*vy(kv) p(1)=xm p(2)=ym dp(1)=vx(kk)-vx(kv) dp(2)=vy(kk)-vy(kv) dq(1)=-dp(2) dq(2)=dp(1) k=kk do 45 i=1,num k=ipoly(1,k) cc if(k.eq.ka.or.k.eq.kb) go to 45 cc if(k.eq.ks.or.k.eq.kf) go to 45 if(k.eq.kv.or.k.eq.kk) go to 45 q(1)=vx(k) q(2)=vy(k) call lil(p,dp,q,dq,al,ier) if(al(1).lt.0.0d0) then al1=-al(1)/fv ht=hv else al1=al(1)/fk ht=hk endif if(al1.ge.1.0d0) go to 45 al2=dabs(al(2))*ds if(al2.gt.hm*(1.0d0-al1)) go to 45 hh=chloc(ipoly(2,k),k,ipoly(1,k),vx,vy) z=al2+hh/grade h=hm+(ht-hm)*al1 if(h.gt.z) then hz=(z-al1*ht)/(1.0d0-al1) if(hz.le.0.0d0) go to 45 hm=dmin1(hm,hz) if(hm.lt.hmin) go to 60 endif 45 continue c c first set up segment between kv and (xm,ym) c dv=fv*d call rlink(hv,hm,dv,rp,vx(kv),vy(kv),xm,ym, + vx,vy,nvr,maxv,iflag) if(iflag.ne.0) return if(nvr.lt.maxv) then nvr=nvr+1 vx(nvr)=xm vy(nvr)=ym else iflag=22 return endif c c next set up segment between (xm,ym) and kk c dk=fk*d call rlink(hm,hk,dk,rp,xm,ym,vx(kk),vy(kk), + vx,vy,nvr,maxv,iflag) if(iflag.ne.0) return go to 70 c c take h to be a linear function between kv and kk c 60 call rlink(hv,hk,d,rp,vx(kv),vy(kv),vx(kk),vy(kk), + vx,vy,nvr,maxv,iflag) if(iflag.ne.0) return c c find two triangles sharing the edge (kv,kk) c 70 kt=ipoly(3,kv)/4 ke=ipoly(3,kv)-4*kt 80 kz=itnode(ke,kt) if(kk.ne.kz) then jt=itedge(index(3,ke),kt) kt=jt/4 ke=jt-4*kt go to 80 endif ke=index(3,ke) jt=itedge(ke,kt)/4 je=itedge(ke,kt)-4*jt newt=nvr-nvr0 if(it1-2*newt.le.ntr) then iflag=21 return endif it0=it1-2*newt c istart=it0 nvr1=nvr0+1 kn=itnode(ke,kt) kts=itedge(index(2,ke),kt) ktf=itedge(index(3,ke),kt) c itnode(1,kt)=kv itnode(2,kt)=kn itnode(3,kt)=nvr1 itedge(1,kt)=4*istart+3 itedge(2,kt)=0 itedge(3,kt)=kts if(kts.gt.0) then mt=kts/4 me=kts-4*mt itedge(me,mt)=4*kt+3 endif do i=istart,istart+newt-1 itnode(4,i)=itnode(4,kt) itnode(5,i)=itnode(5,kt) itnode(1,i)=nvr1+i-istart itnode(2,i)=kn if(i.lt.istart+newt-1) then itnode(3,i)=itnode(1,i)+1 itedge(1,i)=4*(i+1)+3 else itnode(3,i)=kk itedge(1,i)=ktf if(ktf.gt.0) then mt=ktf/4 me=ktf-4*mt itedge(me,mt)=4*i+1 endif endif itedge(2,i)=0 if(i.gt.istart) then itedge(3,i)=4*(i-1)+1 else itedge(3,i)=4*kt+1 endif enddo c c istart=it0+newt nvr1=nvr kn=itnode(je,jt) kts=itedge(index(2,je),jt) ktf=itedge(index(3,je),jt) c itnode(1,jt)=kk itnode(2,jt)=kn itnode(3,jt)=nvr1 itedge(1,jt)=4*istart+3 itedge(2,jt)=0 itedge(3,jt)=kts if(kts.gt.0) then mt=kts/4 me=kts-4*mt itedge(me,mt)=4*jt+3 endif do i=istart,istart+newt-1 itnode(4,i)=itnode(4,jt) itnode(5,i)=itnode(5,jt) itnode(1,i)=nvr1+istart-i itnode(2,i)=kn if(i.lt.istart+newt-1) then itnode(3,i)=itnode(1,i)-1 itedge(1,i)=4*(i+1)+3 else itnode(3,i)=kv itedge(1,i)=ktf if(ktf.gt.0) then mt=ktf/4 me=ktf-4*mt itedge(me,mt)=4*i+1 endif endif itedge(2,i)=0 if(i.gt.istart) then itedge(3,i)=4*(i-1)+1 else itedge(3,i)=4*jt+1 endif enddo c c swap elements as necessary c last=it0+newt-1 icur=it0 90 do j=1,3 if(itedge(j,icur).gt.0) then mt=itedge(j,icur)/4 if(mt.gt.last) then last=last+1 call tswap(last,mt,itnode,itedge) endif endif enddo icur=icur+1 if(icur.le.last) go to 90 c c finish setting up new regions c irptr(ns+1)=last call eswapk(last+1,it2,itnode,itedge,vx,vy) ns=ns+1 irptr(ns+1)=it0-1 call eswapk(it0,last,itnode,itedge,vx,vy) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cedge2(nvr,nt1,nt2,nbf,itnode,itedge,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),list(*),index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine makes a simple itedge array c do i=1,nvr list(i)=0 enddo llist=nvr+nbf+3*(nt2-nt1+1) iptr=nvr+1 do i=iptr,llist,2 list(i)=i+2 enddo list(llist-1)=0 list(llist-2)=0 c c first find adjacent triangles c do i=nt1,nt2 do j=1,3 itedge(j,i)=0 enddo enddo do i=nt1,nt2 do j=1,3 j2=index(2,j) j3=index(3,j) imax=max0(itnode(j2,i),itnode(j3,i)) imin=min0(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k.le.0) then c c add triangle i, edge j to list c if(iptr.le.0) stop 7783 list(kold)=iptr ii=iptr iptr=list(iptr) list(ii)=0 list(ii+1)=j+4*i else c c check for a common edge c ii=list(k+1)/4 jj=list(k+1)-4*ii j2=index(2,jj) j3=index(3,jj) iimax=max0(itnode(j2,ii),itnode(j3,ii)) if(imax.eq.iimax) then itedge(j,i)=jj+4*ii itedge(jj,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k else kold=k go to 40 endif endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eswap(nt1,nt2,nvr,itnode,itedge,ipoly,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),ipoly(3,*) double precision + vx(*),vy(*),qmin0(4),fract0(4) save index,fract0,qmin0 data index/1,2,3,2,3,1,3,1,2/ data fract0/1.0d0, 1.0d0, 0.8d0, 0.6d0/ data qmin0 /1.0d0, 1.0d0, 0.6d0, 0.3d0/ c c c this routine swaps interior triangle edges in an attempt c to improve the overall quality of the triangulation c c this version incoporporates ideas of field for equilibrating degrees c itmax=3 c c initialize ipoly c do i=1,nvr ipoly(3,i)=0 enddo len=0 do i=nt1,nt2 do j=1,3 if(itedge(j,i).le.0) then j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) ipoly(1,j1)=j2 ipoly(2,j2)=j1 len=len+1 endif enddo enddo c c compute psuedo degress for boundary vertices c kv=j2 do ii=1,len ka=ipoly(1,kv) kb=ipoly(2,kv) q=6.0d0-cang(kb,kv,ka,vx,vy)*3.0d0 iq=max0(idint(q+0.5d0)-1,0) ipoly(3,kv)=min0(5,iq) kv=ipoly(1,kv) enddo if(kv.ne.j2) stop 7423 c c compute degrees in ipoly(3,*) c do i=nt1,nt2 do j=1,3 k=itedge(j,i)/4 if(i.gt.k) then j2=itnode(index(2,j),i) j3=itnode(index(3,j),i) ipoly(3,j2)=ipoly(3,j2)+1 ipoly(3,j3)=ipoly(3,j3)+1 endif enddo enddo c c the main loop in which the edges are swapped c do 100 ithrsh=4,2,-1 qmin=qmin0(ithrsh) fract=fract0(ithrsh) do itnum=1,itmax ichng=0 do i=nt1,nt2 do 50 ied=1,3 k=itedge(ied,i)/4 if(k.le.0) go to 50 ked=itedge(ied,i)-4*k if(k.lt.nt1.or.k.gt.nt2) stop 4321 j2=itnode(index(ied,2),i) j3=itnode(index(ied,3),i) mi=itnode(ied,i) mk=itnode(ked,k) c c dont connect two boundary points or increase high degrees c m1=max0(itedge(index(ied,2),i), + itedge(index(ked,3),k)) m2=max0(itedge(index(ked,2),k), + itedge(index(ied,3),i)) if(min0(m1,m2).le.0) go to 50 mtst=ipoly(3,j2)+ipoly(3,j3) + -ipoly(3,mi)-ipoly(3,mk) if(mtst.lt.ithrsh) go to 50 c c dont create bad geometries c q2=geom(mi,j2,mk,vx,vy) q3=geom(mk,j3,mi,vx,vy) qi=geom(mi,j2,j3,vx,vy) qk=geom(mk,j3,j2,vx,vy) q23=dmin1(q2,q3) qik=dmin1(qi,qk) if(q23.lt.dmin1(qik*fract,qmin)) go to 50 c c swap edges c ichng=ichng+1 ipoly(3,j2)=ipoly(3,j2)-1 ipoly(3,j3)=ipoly(3,j3)-1 ipoly(3,mi)=ipoly(3,mi)+1 ipoly(3,mk)=ipoly(3,mk)+1 c c itnode(index(ied,3),i)=mk itnode(index(ked,3),k)=mi itedge(ied,i)=itedge(index(ked,2),k) itedge(ked,k)=itedge(index(ied,2),i) itedge(index(ied,2),i)=index(ked,2)+4*k itedge(index(ked,2),k)=index(ied,2)+4*i j=itedge(ied,i)/4 if(j.gt.0) then jed=itedge(ied,i)-4*j itedge(jed,j)=ied+4*i endif j=itedge(ked,k)/4 if(j.gt.0) then jed=itedge(ked,k)-4*j itedge(jed,j)=ked+4*k endif 50 continue enddo if(ichng.le.0) go to 100 enddo 100 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mfe0(nv1,nv2,nt1,nt2,itnode,itedge,vx,vy,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vlist(50),itnode(5,*),itedge(3,*),list(*),index(3,3) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine tries to optimize knot placement c if(nv1.gt.nv2) return tol=1.0d-3 s3=dsqrt(3.0d0)/2.0d0 itmax=4 c c make list of seed triangles c do i=nt1,nt2 do j=1,3 list(itnode(j,i))=4*i+j enddo enddo c c thr main loop in which the knots positions are c optimized c do itnum=1,itmax do i=nv1,nv2 c c compute circular list of vertices c ideg=0 k=list(i)/4 ke=list(i)-4*k ke=index(2,ke) kv=itnode(ke,k) kk=kv 10 ideg=ideg+1 if(ideg.gt.30) stop 5521 vlist(ideg)=kk j=itedge(ke,k)/4 ke=itedge(ke,k)-4*j k=j ke=index(3,ke) if(itnode(index(3,ke),k).ne.i) stop 6630 kk=itnode(ke,k) if(kk.ne.kv) go to 10 vlist(ideg+1)=kv c qmin=1.0d0 qmin2=1.0d0 k1=0 k2=0 do k=1,ideg kb=vlist(k) ka=vlist(k+1) q=geom(i,kb,ka,vx,vy) if(q.lt.qmin) then qmin2=qmin qmin=q k2=k1 k1=k else if(q.lt.qmin2) then qmin2=q k2=k endif enddo xmin=vx(i) ymin=vy(i) kb=vlist(k1) ka=vlist(k1+1) dxk=(vx(ka)-vx(kb)) dyk=(vy(ka)-vy(kb)) xmk=(vx(kb)+vx(ka))/2.0d0 ymk=(vy(kb)+vy(ka))/2.0d0 c dxk=dxk*s3 dyk=dyk*s3 xmax=xmk-dyk ymax=ymk+dxk rk=dsqrt(dxk*dxk+dyk*dyk) lb=vlist(k2) la=vlist(k2+1) dxl=(vx(la)-vx(lb))*s3 dyl=(vy(la)-vy(lb))*s3 xml=(vx(lb)+vx(la))/2.0d0 yml=(vy(lb)+vy(la))/2.0d0 rl=dsqrt(dxl*dxl+dyl*dyl) xm=xmk-xml dx=dxk-dxl ym=ymk-yml dy=dyk-dyl r=rk+rl a=r*r-dx*dx-dy*dy b=ym*dx-xm*dy c=xm*xm+ym*ym+r*r beta=1.0d0 if(a.gt.0.0d0) beta=(b+dsqrt(b*b+a*c))/a xck=xmk-beta*dyk yck=ymk+beta*dxk xcl=xml-beta*dyl ycl=yml+beta*dxl xmax=(xck*rl+xcl*rk)/r ymax=(yck*rl+ycl*rk)/r c c the bisection loop c eps=tol*dmax1(dabs(xmin),dabs(xmax), 1 dabs(ymin),dabs(ymax)) 85 zx=dabs(xmin-xmax)/(dabs(xmin)+dabs(xmax)+eps) zy=dabs(ymin-ymax)/(dabs(ymin)+dabs(ymax)+eps) if(dmax1(zx,zy).lt.tol) then vx(i)=xmin vy(i)=ymin else vx(i)=(xmin+xmax)/2.0d0 vy(i)=(ymin+ymax)/2.0d0 qq=1.0d0 do k=1,ideg kb=vlist(k) ka=vlist(k+1) q=geom(i,kb,ka,vx,vy) if(q.lt.qmin) then xmax=vx(i) ymax=vy(i) go to 85 endif qq=dmin1(qq,q) enddo xmin=vx(i) ymin=vy(i) qmin=qq go to 85 endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine liarc(p,dp,q,t,r,npts,al,ang,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + p(2),dp(2),q(2),t(2),al(2),ang(2) c c compute the intersection,if any, between the line c given by p and dp and the arc with center q , radius r c and theta range t. c pi=3.141592653589793d0 rr=dabs(r) x=(p(1)-q(1))/rr y=(p(2)-q(2))/rr dx=dp(1)/rr dy=dp(2)/rr c c solve quadratic c c=x*x+y*y-1.0d0 b=-(x*dx+y*dy) a=dx*dx+dy*dy disc=b*b-a*c c if(disc.gt.0.0d0) then d=dsqrt(disc) npts=2 if(b.ge.0.0d0) then al(1)=(b+d)/a al(2)=c/(b+d) else al(1)=c/(b-d) al(2)=(b-d)/a endif else if(disc.eq.0.0d0) then npts=1 al(1)=b/a else npts=0 return endif c c compute theta values c tmin=dmin1(t(1),t(2)) tmax=dmax1(t(1),t(2)) tol=eps*(tmax-tmin) do i=1,npts x=(p(1)-q(1)+al(i)*dp(1))/rr y=(p(2)-q(2)+al(i)*dp(2))/rr x=dmin1(1.0d0,x) x=dmax1(-1.0d0,x) th=dacos(x)/pi if(y.lt.0.0d0) th=-th do j=1,5 theta=th+dfloat(j-3)*2.0d0 if(dabs(theta-tmin).le.tol) theta=tmin if(theta.ge.tmin) go to 60 enddo 60 if(dabs(theta-tmax).le.tol) theta=tmax ang(i)=theta enddo if(npts.eq.2.and.ang(2).lt.ang(1)) then a=ang(1) ang(1)=ang(2) ang(2)=a a=al(1) al(1)=al(2) al(2)=a endif if(ang(1).gt.tmax) npts=0 if(npts.eq.2.and.ang(2).gt.tmax) npts=1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine lil(p,dp,q,dq,al,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + p(2),dp(2),q(2),dq(2),al(2) c c this routine find the intersection of two lines c if the lines are parallel iflag is set to 1 c d1=p(1)-q(1) d2=p(2)-q(2) det=dp(2)*dq(1)-dp(1)*dq(2) if(det.ne.0.0d0) then al(1)=(d1*dq(2)-d2*dq(1))/det al(2)=(dp(2)*d1-dp(1)*d2)/det iflag=0 else al(1)=0.0d0 al(2)=0.0d0 iflag=1 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function chloc(kb,kv,ka,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + vx(*),vy(*) c c this routine computes the local value of h c x1=vx(ka)-vx(kv) y1=vy(ka)-vy(kv) x2=vx(kb)-vx(kv) y2=vy(kb)-vy(kv) chloc=((x1*x1+y1*y1)*(x2*x2+y2*y2))**0.25d0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function geom(kv,kb,ka,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + vx(*),vy(*) c c this function computes a constant between c zero and one indicative of the quality of a triangle c (geom is neg if verts are given in clockwise order) c x1=vx(ka)-vx(kv) y1=vy(ka)-vy(kv) x2=vx(kb)-vx(kv) y2=vy(kb)-vy(kv) det=x2*y1-x1*y2 dd=x1*x1+y1*y1+x2*x2+y2*y2+(x1-x2)*(x1-x2)+ + (y1-y2)*(y1-y2) geom=det*3.464101616d0/dd return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function ch(kv,kb,ka,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + vx(*),vy(*) c c diameter of circumscribing circle c x1=vx(ka)-vx(kv) y1=vy(ka)-vy(kv) x2=vx(kb)-vx(kv) y2=vy(kb)-vy(kv) d0=dsqrt(dabs(x2*y1-x1*y2)) d1=dsqrt(x1**2+y1**2)/d0 d2=dsqrt(x2**2+y2**2)/d0 d3=dsqrt((x1-x2)**2+(y1-y2)**2)/d0 ch=d0*d1*d2*d3 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function cangmx(kb,kv,ka,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + index(3,3) double precision + vx(*),vy(*),h(3) save index,pi data index/1,2,3,2,3,1,3,1,2/ data pi/3.141592653589793d0/ c c the function computes largest angle of the c triangle defined by the vertices kb,kv,ka c h(1)=(vx(ka)-vx(kb))**2+(vy(ka)-vy(kb))**2 h(2)=(vx(kb)-vx(kv))**2+(vy(kb)-vy(kv))**2 h(3)=(vx(kv)-vx(ka))**2+(vy(kv)-vy(ka))**2 j=1 if(h(2).gt.h(1)) j=2 if(h(3).gt.h(j)) j=3 j2=index(2,j) j3=index(3,j) h(j2)=h(j2)/h(j) h(j3)=h(j3)/h(j) q=(h(j2)+h(j3)-1.0d0)/(2.0d0*dsqrt(h(j2)*h(j3))) q=dmin1(1.0d0,q) q=dmax1(-1.0d0,q) cangmx=dacos(q)/pi return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function cangmn(kb,kv,ka,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + index(3,3) double precision + vx(*),vy(*),h(3) save index,pi data index/1,2,3,2,3,1,3,1,2/ data pi/3.141592653589793d0/ c c the function computes smallest angle of the c triangle defined by the vertices kb,kv,ka c h(1)=(vx(ka)-vx(kb))**2+(vy(ka)-vy(kb))**2 h(2)=(vx(kb)-vx(kv))**2+(vy(kb)-vy(kv))**2 h(3)=(vx(kv)-vx(ka))**2+(vy(kv)-vy(ka))**2 j=1 if(h(2).lt.h(1)) j=2 if(h(3).lt.h(j)) j=3 j2=index(2,j) j3=index(3,j) h(j2)=h(j2)/h(j) h(j3)=h(j3)/h(j) q=(h(j2)+h(j3)-1.0d0)/(2.0d0*dsqrt(h(j2)*h(j3))) q=dmin1(1.0d0,q) q=dmax1(-1.0d0,q) cangmn=dacos(q)/pi return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function cang(kb,kv,ka,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + vx(*),vy(*) save pi data pi/3.141592653589793d0/ c c the function computes the interior angle c given by the segments (kb,kv) and (kv,ka) c x1=vx(ka)-vx(kv) x2=vx(kb)-vx(kv) y1=vy(ka)-vy(kv) y2=vy(kb)-vy(kv) xx=x2*x1+y2*y1 yy=x1*y2-y1*x2 s=xx/dsqrt(xx**2+yy**2) s=dmin1(1.0d0,s) s=dmax1(-1.0d0,s) cang=dacos(s)/pi if(yy.le.0.0d0) cang=2.0d0-cang return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function cang1(ibef,icom,iaft,ieb,iea, + vx,vy,xm,ym,ibndry) c c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*),x(3),y(3) save i1,i2,i3 data i1,i2,i3/1,2,3/ c c a0=cang(ibef,icom,iaft,vx,vy) c c check curved edges c if(ibndry(3,ieb).gt.0) then ic=ibndry(3,ieb) x(1)=vx(ibef) y(1)=vy(ibef) x(2)=vx(icom) y(2)=vy(icom) x(3)=xm(ic) y(3)=ym(ic) a1=cang(i1,i2,i3,x,y) if(a1.lt.1.0d0) then a0=a0+1.0d0/2.0d0-a1 else a0=a0+3.0d0/2.0d0-a1 endif endif if(ibndry(3,iea).gt.0) then ic=ibndry(3,iea) x(1)=xm(ic) y(1)=ym(ic) x(2)=vx(icom) y(2)=vy(icom) x(3)=vx(iaft) y(3)=vy(iaft) a1=cang(i1,i2,i3,x,y) if(a1.lt.1.0d0) then a0=a0+1.0d0/2.0d0-a1 else a0=a0+3.0d0/2.0d0-a1 endif endif if(a0.lt.0.0d0) a0=a0+2.0d0 if(a0.gt.2.0d0) a0=a0-2.0d0 cang1=a0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dvpram(hl,hr,d,rp,al,h,np) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100) c c this routine determines the number of points and the c spacing parameters for dividing up a line segment c epsm=1.0d0-rp(51) grade=rp(16) np=0 al=1.0d0 h=1.0d0 hmax=dmax1(hl,hr)/d if(hmax.ge.epsm) return hmin=dmin1(hl,hr)/d if(hmin*grade.ge.epsm) return c c find np by increasing hmin as quickly as possible c q=hmin 3 np=np+1 hmin=dmin1(hmin*grade,hmax) q=q+hmin if(q.lt.epsm) go to 3 if(q.gt.1.0d0+hmax/2.0d0) np=np-1 c c hr=hl*al**(np+1) and h*(1-al**(np+1))/(1-al)=1 c are the two equations that determine al and h c if(np.eq.0) return r=hr/hl if(dabs(r-1.0d0).lt.1.d-3) then h=1.0d0/dfloat(np+1) else al=r**(1.0d0/dfloat(np+1)) al=dmin1(grade,al) al=dmax1(1.0d0/grade,al) h=(al-1.0d0)/(al**(np+1)-1.0d0) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,xm,ym,itnode, + ibndry,jb,iequv,hloc,list,vx0,vy0,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jb(*),itnode(5,*),ibndry(6,*),iequv(*),list(*) double precision + vx(*),vy(*),hloc(*),rp(100),xm(*),ym(*),vx0(*),vy0(*) c c look for long edges connected to only short edges and divide c hmax=rp(78)*rp(15) grade=rp(16) pi=3.141592653589793d0 factor=1.1d0 c c initialize iequv c call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,jb,list, + vx0,vy0,iflag) if(iflag.ne.0) return call cequv(nvr,nbr,ntr,itnode,jb,ibndry,iequv,iflag) if(iflag.ne.0) return c c initialize hloc using edge lengths c do i=1,nvr hloc(iequv(i))=hmax enddo do i=1,nbr j1=ibndry(1,i) j2=ibndry(2,i) jc=ibndry(3,i) if(jc.gt.0) then call arc(vx(j1),vy(j1),vx(j2),vy(j2), + xm(jc),ym(jc),theta1,theta2,radius,d) else d=dsqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+ + (vy(j1)-vy(j2))*(vy(j1)-vy(j2))) endif if(hloc(iequv(j1)).le.0.0d0) then hloc(iequv(j1))=d else hloc(iequv(j1))=dmin1(d,hloc(iequv(j1))) endif if(hloc(iequv(j2)).le.0.0d0) then hloc(iequv(j2))=d else hloc(iequv(j2))=dmin1(d,hloc(iequv(j2))) endif enddo do i=1,nvr hloc(i)=hloc(iequv(i)) enddo c c now look for long edges on the basis of hloc c nbr0=nbr do 120 i=1,nbr0 iequv(i)=0 j1=ibndry(1,i) j2=ibndry(2,i) jc=ibndry(3,i) c c see if h can be increased near center of interval c if(jc.gt.0) then call arc(vx(j1),vy(j1),vx(j2),vy(j2), + xm(jc),ym(jc),theta1,theta2,radius,d) else d=dsqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2) endif if(d.le.grade*(hloc(j1)+hloc(j2))) go to 120 ds=d*(grade-1.0d0)/grade theta=(hloc(j1)-hloc(j2))/(2.0d0*ds) if(dabs(theta).gt.0.4d0) go to 120 f1=0.5d0-theta f2=0.5d0+theta hmm=(ds+hloc(j1)+hloc(j2))/2.0d0 hmin=f1*hloc(j2)+f2*hloc(j1) hmm=dmin1(hmm,hmax) if(hmm.lt.hmin*factor) go to 120 c c add new point, edge c if(nvr.ge.maxv) then iflag=22 return endif nvr=nvr+1 if(jc.gt.0) then theta=(f1*theta2+f2*theta1)*pi vx(nvr)=xm(jc)+radius*dcos(theta) vy(nvr)=ym(jc)+radius*dsin(theta) else vx(nvr)=f1*vx(j2)+f2*vx(j1) vy(nvr)=f1*vy(j2)+f2*vy(j1) endif if(nbr.ge.maxb) then iflag=24 return endif nbr=nbr+1 iequv(i)=nbr do j=1,6 ibndry(j,nbr)=ibndry(j,i) enddo ibndry(2,i)=nvr ibndry(1,nbr)=nvr 120 continue if(nbr0.lt.nbr) then do i=nbr0+1,nbr if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,k)=-i endif enddo endif c c fix itnode c do i=1,ntr k=itnode(1,i) j=itnode(2,i) if(ibndry(1,j).ne.k.and.ibndry(2,j).ne.k) then jj=iequv(j) if(ibndry(2,jj).ne.k) stop 9328 itnode(2,i)=jj endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode, + jb,list,vx0,vy0,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),list(*) double precision + vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*) c c compute jb array from ibndry, vx vy c iflag=0 c c initialize with list of edges as function of vertex in list c do i=1,nvr list(i+1)=0 enddo do i=1,nbr list(ibndry(1,i)+1)=list(ibndry(1,i)+1)+1 list(ibndry(2,i)+1)=list(ibndry(2,i)+1)+1 if(ibndry(4,i).eq.0) then list(nvr+1+i)=2 else list(nvr+1+i)=1 endif enddo list(1)=nvr+nbr+2 do i=1,nvr list(i+1)=list(i)+list(i+1) enddo do i=1,nbr do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo enddo do i=nvr,2,-1 list(i)=list(i-1) enddo list(1)=nvr+nbr+2 c c jiggle vertices a bit towards the center of their regions c to avoid failed tests due to cracks c itmax=3 eps=1.0d-3 do i=1,nvr vx0(i)=vx(i) vy0(i)=vy(i) enddo do itnum=1,itmax do i=1,nvr xx=0.0d0 yy=0.0d0 do j=list(i),list(i+1)-1 k=list(j) xx=xx+vx0(ibndry(1,k))+vx0(ibndry(2,k)) yy=yy+vy0(ibndry(1,k))+vy0(ibndry(2,k)) enddo vx0(i)=vx0(i)+eps*xx/dfloat(list(i+1)-list(i)) vy0(i)=vy0(i)+eps*yy/dfloat(list(i+1)-list(i)) enddo enddo c c now compute jb c jb(1)=ntr+2 do i=1,ntr iv=itnode(1,i) icur=itnode(2,i) ii=jb(i) istart=icur c 20 if(list(nvr+1+icur).le.0) then iflag=-53 return endif jb(ii)=icur list(nvr+1+icur)=list(nvr+1+icur)-1 if(ibndry(1,icur).ne.iv) then if(ibndry(2,icur).ne.iv) then iflag=-53 return endif ibndry(2,icur)=ibndry(1,icur) ibndry(1,icur)=iv endif jv=ibndry(2,icur) j1=list(jv) j2=list(jv+1)-1 if(j2.eq.j1+1) then next=list(j1) if(next.eq.icur) next=list(j2) else next=0 ang=3.0d0 do kk=j1,j2 k=list(kk) if(k.ne.icur) then kv=ibndry(1,k)+ibndry(2,k)-jv if(max0(ibndry(3,icur),ibndry(3,k)).gt.0) then aa=cang1(iv,jv,kv,icur,k,vx0,vy0, + xm,ym,ibndry) else aa=cang(iv,jv,kv,vx0,vy0) endif if(aa.lt.ang) then ang=aa next=k endif endif enddo endif if(next.eq.istart) then jb(i+1)=ii+1 else icur=next iv=jv ii=ii+1 go to 20 endif enddo c c check for left-over edges c do i=1,nbr if(list(nvr+1+i).ne.0) then iflag=-43 return endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rgen(ip,vx,vy,xm,ym,itnode,ibndry,itedge,ibc, + iequv,vz,jv,area,lenjv,rp,itag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),iequv(*), 1 itedge(3,*),jv(2,*),ibc(*),itag(*) double precision + vx(*),vy(*),xm(*),ym(*),vz(*),area(*),rp(100) c c compute skeleton from current triangle data c and set up input data for trigen c iflag=0 ntf=ip(1) nvf=ip(2) nvf0=nvf nbf=ip(4) c maxt=ip(21) maxv=ip(22) c c construct the jv data structure c call cjv(nvf,ntf,nbf,itnode,itedge,ibndry,vx,vy,vz, + jv,area,maxv,lenjv,ibc,imark,rp,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c c add contour points to triangle edges c call adpt(nvf,nbf,ibndry,vx,vy,vz,xm,ym,jv,lenjv, + maxv,rp,iequv,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c c add contour lines c l0=jv(1,nvf+1) l1=l0+nvf l2=l1+nvf if(l2.gt.lenjv) then ip(25)=20 return endif call aded(ntf,itnode,vx,vy,vz,jv,area,jv(1,l0), + ibc,ntr,maxt,rp,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c c reduce the number of regions by merging regions in the c same contour c call chkrgn(itnode,jv,area,jv(1,l0),rp,nvf,ntr,itag,vx,vy) call tstrgn(itnode,jv,area,jv(1,l0),jv(1,l1),jv(1,l2), + rp,nvf,ntr,itag) c c make contour breaks better if possible c do n=1,nvf if(jv(2,n).gt.2) then i1=jv(1,n)+1 i2=i1+jv(2,n)-1 do 20 j=i1,i2 irgn=jv(2,j) jrgn=jv(2,j-1) if(jv(1,j).le.0) go to 20 if(min0(irgn,jrgn).le.0) go to 20 if(itag(irgn).ne.itag(jrgn)) go to 20 call chkpt0(irgn,jrgn,n,jv(1,l0), + jv(1,l1),jv(1,l2),vx,vy,jv) 20 continue endif enddo c c look at all degree 2 vertices and eliminate c those with angle approximately equal to pi c call chkdg2(nvf,nvf0,vx,vy,xm,ym,jv,rp,ibndry,iequv) c c remove extra short contour edges connecting high degree vertices c call chkdg3(nvf,vx,vy,jv,rp) c c now check vertices along paths to see if any regions c are close to straight lines c do n=1,nvf if(jv(2,n).gt.2) then i1=jv(1,n)+1 i2=i1+jv(2,n)-1 do j=i1,i2 irgn=jv(2,j) jrgn=jv(2,j-1) if(jv(1,j).gt.0) then ity=1 else ity=0 endif if(min0(irgn,jrgn).gt.0) then call chkpth(irgn,jrgn,n,jv(1,l0), + jv(1,l1),jv(1,l2),vx,vy,jv,rp,ity) endif enddo endif enddo ip(2)=nvf call cds(ip,jv,itnode,ibndry,jv(1,l1),vx,vy,xm,ym,itedge, + jv(1,l0),itag,imark,iequv) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xybox(nbf,vx,vy,xm,ym,ibndry, + xmin,xmax,ymin,ymax,diam) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*) c c find a box containing domain c xmin=vx(ibndry(1,1)) ymin=vy(ibndry(1,1)) xmax=xmin ymax=ymin do i=1,nbf xmin=dmin1(xmin,vx(ibndry(1,i)),vx(ibndry(2,i))) ymin=dmin1(ymin,vy(ibndry(1,i)),vy(ibndry(2,i))) xmax=dmax1(xmax,vx(ibndry(1,i)),vx(ibndry(2,i))) ymax=dmax1(ymax,vy(ibndry(1,i)),vy(ibndry(2,i))) c c check for curved edges c if(ibndry(3,i).gt.0) then xc=xm(ibndry(3,i)) yc=ym(ibndry(3,i)) x1=vx(ibndry(1,i))-xc y1=vy(ibndry(1,i))-yc x2=vx(ibndry(2,i))-xc y2=vy(ibndry(2,i))-yc rad=dsqrt(x1**2+y1**2) if(x1*x2.lt.0.0d0) then al=x1/(x1-x2) if(y1+al*(y2-y1).gt.0.0d0) then ymax=dmax1(ymax,yc+rad) else ymin=dmin1(ymin,yc-rad) endif endif if(y1*y2.lt.0.0d0) then al=y1/(y1-y2) if(x1+al*(x2-x1).gt.0.0d0) then xmax=dmax1(xmax,xc+rad) else xmin=dmin1(xmin,xc-rad) endif endif endif enddo c c compute diameter c diam=dsqrt((xmax-xmin)**2+(ymax-ymin)**2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,vz,xm,ym, + cx,cy,cz,zmin,zmax) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*), 1 index(3,3) double precision + vx(*),vy(*),vz(*),xm(*),ym(*),c(3),f(3) save index data index/1,2,3,2,3,1,3,1,2/ c c find min and max function values-- continuous case c zmin=cx*vx(1)+cy*vy(1)+cz*vz(1) zmax=zmin do i=1,nvf zz=cx*vx(i)+cy*vy(i)+cz*vz(i) zmin=dmin1(zmin,zz) zmax=dmax1(zmax,zz) enddo c c check for curved edge c do 10 ib=1,nbf if(ibndry(3,ib).le.0) go to 10 if(ibndry(4,ib).eq.0) go to 10 k=ibndry(3,ib) i=ibedge(1,ib)/4 j1=ibedge(1,ib)-4*i j2=itnode(index(2,j1),i) j3=itnode(index(3,j1),i) do j=1,3 jj=itnode(j,i) f(j)=cx*vx(jj)+cy*vy(jj)+cz*vz(jj) enddo call grad(zx,zy,vx,vy,f,itnode(1,i),1) r=zx**2+zy**2 if(r.le.0.0d0) go to 10 r=dsqrt(((vx(j2)-xm(k))**2+(vy(j2)-ym(k))**2)/r) c c look at radii of the circle parallel to grad(z) c xx=xm(k)+zx*r yy=ym(k)+zy*r dd=(vx(j3)-vx(j2))**2+(vy(j3)-vy(j2))**2 do ic=1,2 d2=(vx(j2)-xx)**2+(vy(j2)-yy)**2 d3=(vx(j3)-xx)**2+(vy(j3)-yy)**2 if(dmax1(d2,d3).lt.dd) then call bari(xx,yy,vx,vy,itnode(1,i),c) zz=c(1)*f(1)+c(2)*f(2)+c(3)*f(3) zmin=dmin1(zmin,zz) zmax=dmax1(zmax,zz) endif xx=xm(k)-zx*r yy=ym(k)-zy*r enddo 10 continue c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine zdbox(ntf,nbf,itnode,ibndry,ibedge,vx,vy,vz, + xm,ym,cx,cy,cz,zmin,zmax) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*), 1 index(3,3) double precision + vx(*),vy(*),vz(3,*),xm(*),ym(*),c(3),f(3) save index data index/1,2,3,2,3,1,3,1,2/ c c find min and max function values-- discontinuous case c zmin=cx*vx(itnode(1,1))+cy*vy(itnode(1,1))+cz*vz(1,1) zmax=zmin do i=1,ntf do j=1,3 jj=itnode(j,i) f(j)=cx*vx(jj)+cy*vy(jj)+cz*vz(j,i) enddo zmin=dmin1(zmin,f(1),f(2),f(3)) zmax=dmax1(zmax,f(1),f(2),f(3)) enddo c c check for curved edge c do 10 ib=1,nbf if(ibndry(3,ib).le.0) go to 10 k=ibndry(3,ib) do 5 ie=1,2 i=ibedge(ie,ib)/4 if(i.le.0) go to 5 j1=ibedge(ie,ib)-4*i j2=itnode(index(2,j1),i) j3=itnode(index(3,j1),i) do j=1,3 jj=itnode(j,i) f(j)=cx*vx(jj)+cy*vy(jj)+cz*vz(j,i) enddo call grad(zx,zy,vx,vy,f,itnode(1,i),1) r=zx**2+zy**2 if(r.le.0.0d0) go to 5 r=dsqrt(((vx(j2)-xm(k))**2+(vy(j2)-ym(k))**2)/r) c c look at radii of the circle parallel to grad(z) c xx=xm(k)+zx*r yy=ym(k)+zy*r dd=(vx(j3)-vx(j2))**2+(vy(j3)-vy(j2))**2 do ic=1,2 d2=(vx(j2)-xx)**2+(vy(j2)-yy)**2 d3=(vx(j3)-xx)**2+(vy(j3)-yy)**2 if(dmax1(d2,d3).lt.dd) then call bari(xx,yy,vx,vy,itnode(1,i),c) zz=c(1)*f(1)+c(2)*f(2)+c(3)*f(3) zmin=dmin1(zmin,zz) zmax=dmax1(zmax,zz) endif xx=xm(k)-zx*r yy=ym(k)-zy*r enddo 5 enddo 10 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine zvbox(ntf,itnode,ibndry,itedge,vx,vy,ut,vt, + xm,ym,cx,cy,cz,zmin,zmax) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibdy(192),itedge(3,*), 1 index(3,3) double precision + vx(*),vy(*),ut(3,*),vt(3,*),xm(*),ym(*), 1 c(3,192),q(3,3),x(3),y(3),zu(3),zv(3),cc(3) save index data index/1,2,3,2,3,1,3,1,2/ c c find min and max function values-- discontinuous vector case c this is not exact, but is used only for scaling parameters c do i=1,3 do j=1,3 q(i,j)=0.0d0 enddo q(i,i)=1.0d0 enddo zz=dsqrt(ut(1,1)**2+vt(1,1)**2) zmin=cx*vx(itnode(1,1))+cy*vy(itnode(1,1))+cz*zz zmax=zmin do i=1,ntf c call tbdy(c,ibdy,ntri,i,itnode,ibndry,itedge, + vx,vy,xm,ym,q,0) iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) do itri=1,3*ntri,3 do j=1,3 m=j+itri-1 x(j)=c(1,m)*vx(iv1)+c(2,m)*vx(iv2)+c(3,m)*vx(iv3) y(j)=c(1,m)*vy(iv1)+c(2,m)*vy(iv2)+c(3,m)*vy(iv3) zu(j)=c(1,m)*ut(1,i)+c(2,m)*ut(2,i) + +c(3,m)*ut(3,i) zv(j)=c(1,m)*vt(1,i)+c(2,m)*vt(2,i) + +c(3,m)*vt(3,i) zz=cx*x(j)+cy*y(j)+cz*dsqrt(zu(j)**2+zv(j)**2) zmin=dmin1(zmin,zz) zmax=dmax1(zmax,zz) enddo c c check bari center c do j=1,3 j2=index(2,j) j3=index(3,j) cc(j)=zu(j2)*zv(j3)-zu(j3)*zv(j2) enddo det=cc(1)+cc(2)+cc(3) if(det.ne.0.0d0) then do j=1,3 cc(j)=cc(j)/det enddo if(dmax1(cc(1),cc(2),cc(3)).le.1.0d0.and. + dmin1(cc(1),cc(2),cc(3)).ge.0.0d0) then xx=cc(1)*x(1)+cc(2)*x(2)+cc(3)*x(3) yy=cc(1)*y(1)+cc(2)*y(2)+cc(3)*y(3) zz=cx*xx+cy*yy zmin=dmin1(zmin,zz) endif endif c c look on edges c do j=1,3 j2=index(2,j) j3=index(3,j) u2=zu(j2)-zu(j3) v2=zv(j2)-zv(j3) aa=u2**2+v2**2 if(aa.gt.0.0d0) then c2=-(u2*zu(j3)+v2*zv(j3))/aa if(c2.ge.0.0d0.and.c2.le.1.0d0) then uu=zu(j3)+c2*u2 vv=zv(j3)+c2*v2 xx=x(j3)+c2*(x(j2)-x(j3)) yy=y(j3)+c2*(y(j2)-y(j3)) zz=cx*xx+cy*yy+cz*dsqrt(uu**2+vv**2) zmin=dmin1(zmin,zz) endif endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rinit(ip,rp,itnode,ibndry,vx,vy,vz,xm,ym,u,ux,uy,z, + itedge,ibedge,iequv,list,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),index(3,3),ip(100),ibedge(2,*), 1 iequv(*),itedge(3,*),list(*) double precision + vx(*),vy(*),vz(*),xm(*),ym(*),u(*),z(*),rp(100), 1 qv(6),ux(*),uy(*) save index external qxy data index/1,2,3,2,3,1,3,1,2/ c c tolerances for removing points c cc hmin=amax1(rp(51),rp(17)) hmin=dmax1(.001d0,rp(17)) hmin=dmin1(0.1d0,hmin) rp(17)=hmin c c other tolerances c rp(81)= tola (tola for removing points in chkdg2) c rp(82)= arcmin c rp(83)= arcmax c rp(84)= tolz (tol for contour close to function value) c rp(85)= tolf (relative tolerance for arc/lines in chkpth) c rp(81)=1.0d-2 cc rp(82)=1.0e0/16.0e0-1.0e-2 cc rp(83)=1.0e0/4.0e0+1.0e-2 rp(82)=1.0d0/64.0d0-1.0d-2 rp(83)=1.0d0/16.0d0+1.0d-2 tolz=1.d-5 rp(84)=tolz rp(85)=8.0d0 ip(25)=0 c c initialize vz c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=ip(6) nrgn=max0(ip(29),0) iadapt=ip(26) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,list,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c if(iadapt.ge.0) then do i=1,nvf vz(i)=u(i) enddo else c c user supplied function c do i=1,nvf vz(i)=0.0d0 z(i)=0.0d0 enddo rl=rp(21) if(iprob.eq.6) rl=rp(46) do i=1,ntf call eleufn(i,itnode,vx,vy,u,ux,uy,rl,qv,4,0,qxy) x2=vx(itnode(2,i))-vx(itnode(1,i)) y2=vy(itnode(2,i))-vy(itnode(1,i)) x3=vx(itnode(3,i))-vx(itnode(1,i)) y3=vy(itnode(3,i))-vy(itnode(1,i)) det=dabs(x2*y3-x3*y2) do j=1,3 ivj=itnode(j,i) z(ivj)=z(ivj)+det vz(ivj)=vz(ivj)+det*qv(j) enddo enddo do i=1,nvf vz(i)=vz(i)/z(i) enddo endif c c find min and max function values c call cequv1(nvf,nbf,ibndry,iequv,1) do i=1,nvf vz(i)=vz(iequv(i)) enddo cx=0.0d0 cy=0.0d0 cz=1.0d0 call zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,vz,xm,ym, + cx,cy,cz,az,bz) c scale=0.0d0 nn=nrgn if(bz.gt.az) scale=1.0d0/(bz-az) c c adust nrgn with respect to hmin c fact=hmin*rp(78) if(nrgn.gt.0) then do i=1,ntf do j=1,3 dx=vx(itnode(index(2,j),i))-vx(itnode(index(3,j),i)) dy=vy(itnode(index(2,j),i))-vy(itnode(index(3,j),i)) ih=idint(dsqrt(dx**2+dy**2)/fact) v2=(vz(itnode(index(2,j),i))-az)*scale v3=(vz(itnode(index(3,j),i))-az)*scale vmin=dmin1(v2,v3) vmax=dmin1(v2,v3) 10 cmin=vmin*dfloat(nn) cmax=vmax*dfloat(nn) minc=idint(cmin)+1 if(dabs(dfloat(minc)-cmin).lt.tolz*dfloat(minc)) + minc=minc+1 maxc=idint(cmax) if(dabs(dfloat(maxc)-cmax).lt.tolz*dfloat(maxc)) + maxc=maxc-1 if(maxc-minc.gt.ih) then nn=max0(nn-1,0) go to 10 endif enddo enddo endif scale=dfloat(nn)*scale do i=1,nvf vz(i)=(vz(i)-az)*scale ivz=idint(vz(i)+0.5d0) if(dabs(dfloat(ivz)-vz(i)).lt.tolz*dfloat(ivz+1)) then vz(i)=dfloat(ivz) endif vz(iequv(i))=vz(i) enddo call cequv1(nvf,nbf,ibndry,iequv,0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cjv(nvf,ntf,nbf,itnode,itedge,ibndry,vx,vy,vz, + jv,area,maxv,lenjv,ibc,imark,rp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jv(2,*),ibc(*), 1 itedge(3,*),index(3,3) double precision + vx(*),vy(*),vz(*),area(*),c(3),rp(100) save index data index/1,2,3,2,3,1,3,1,2/ c c begin construction of jv array using the triangular mesh c c make list of triangles as a function of vertex c tolz=rp(84) iflag=0 imark=0 c c mark boundary vertices c do i=1,nvf jv(1,i)=2 ibc(i)=0 enddo do i=1,nbf if(ibndry(4,i).ne.0) then jv(1,ibndry(1,i))=3 jv(1,ibndry(2,i))=3 ibc(ibndry(1,i))=1 ibc(ibndry(2,i))=1 endif enddo c c areat=0.0d0 do 20 i=1,ntf do j=1,3 ii=itnode(j,i) c(j)=vz(ii) jv(1,ii)=jv(1,ii)+1 enddo c c compute area c iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) area(i)=dabs(x2*y3-x3*y2)/2.0d0 areat=areat+area(i) c c look for future incoming contour line for middle edge c kmin=1 if(c(2).le.c(1)) kmin=2 kmax=3-kmin if(c(3).le.c(kmin)) kmin=3 if(c(3).gt.c(kmax)) kmax=3 kmid=6-kmin-kmax c minc=idint(c(kmin))+1 if(dabs(dfloat(minc)-c(kmin)).lt.tolz*dfloat(minc+1)) + minc=minc+1 maxc=idint(c(kmax)) if(dabs(dfloat(maxc)-c(kmax)).lt.tolz*dfloat(maxc+1)) + maxc=maxc-1 if(minc.gt.maxc) go to 20 maxm=idint(c(kmid)) minm=maxm+1 if(dabs(dfloat(maxm)-c(kmid)).lt.tolz*dfloat(maxm+1)) + maxm=maxm-1 if(dabs(dfloat(minm)-c(kmid)).lt.tolz*dfloat(minm+1)) + minm=minm+1 c c compute number of points to be added on each edge c nmid=maxc-minc+1 nmax=max0(0,maxm-minc+1) nmin=max0(0,maxc-minm+1) if(nmid.eq.nmax+nmin) go to 20 imid=itnode(kmid,i) jv(1,imid)=jv(1,imid)+1 20 continue c c initailize pointers c nn=maxv+2 do i=1,nvf ii=jv(1,i) jv(1,i)=nn jv(2,i)=nn+1 nn=nn+ii enddo jv(1,nvf+1)=nn if(nn.gt.lenjv+1) then iflag=20 return endif c do i=1,ntf do j=1,3 ii=itnode(j,i) k=jv(2,ii) jv(2,ii)=k+1 jv(1,k)=i enddo enddo c c convert this list to a circular list of vertices c (jv(1,*)) and triangles (jv(2,*)) c in counter clockwise order (first and last c vertices are the same for interior points) c do 80 n=1,nvf i1=jv(1,n)+1 i2=jv(2,n)-1 if(i1.gt.i2) go to 80 i=jv(1,i1) if(ibc(n).eq.0) go to 60 c c starting element for a boundary point c do ii=i1,i2 i=jv(1,ii) if(min0(itedge(1,i),itedge(2,i),itedge(3,i)) + .le.0) then j1=1 if(itnode(2,i).eq.n) j1=2 if(itnode(3,i).eq.n) j1=3 j2=index(2,j1) j3=index(3,j1) if(itedge(j3,i).le.0) go to 60 endif enddo c c compute list for knot n c 60 do ii=i1,i2 j1=1 if(itnode(2,i).eq.n) j1=2 if(itnode(3,i).eq.n) j1=3 j2=index(2,j1) j3=index(3,j1) jv(1,ii)=itnode(j2,i) jv(1,ii+1)=itnode(j3,i) if(itedge(j3,i).gt.0) then jv(2,ii-1)=itedge(j3,i)/4 else jv(2,ii-1)=itedge(j3,i) endif jv(2,ii)=i if(itedge(j2,i).gt.0) then jv(2,ii+1)=itedge(j2,i)/4 else jv(2,ii+1)=itedge(j2,i) endif i=jv(2,ii+1) enddo if(ibc(n).eq.1) then jv(1,i1-1)=0 jv(1,i2+2)=0 jv(2,i2+2)=0 else i=jv(1,i2) jv(1,i1-1)=i endif 80 continue c c compute degrees c do i=1,nvf ideg=jv(2,i)-jv(1,i)-1 if(ibc(i).eq.1) ideg=ideg+1 jv(2,i)=ideg enddo c c find largest label value (for cds) c do i=1,ntf imark=max0(imark,iabs(itnode(5,i))) enddo imark=imark+1 c c mark interfaces specified by user c do n=1,nvf i1=jv(1,n)+1 i2=i1+jv(2,n)-1 if(i1.le.i2) then do i=i1,i2 irgn=jv(2,i-1) jrgn=jv(2,i) if(min0(irgn,jrgn).le.0) then jv(1,i)=-jv(1,i) else if(itnode(5,irgn).ne.itnode(5,jrgn)) + jv(1,i)=-jv(1,i) endif enddo endif enddo rp(80)=areat return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine adpt(nvf,nbf,ibndry,vx,vy,vz,xm,ym,jv,lenjv, + maxv,rp,iequv,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jv(2,*),iv(3),iequv(*) double precision + vx(*),vy(*),vz(*),xm(*),ym(*),ang(2),rp(100), 1 p(2),dp(2),q(2),al(2),theta(2) c c add points along triangle edges corresponding to c coutour lines (these will ultimately be degree 3 or 4 vertices) c tolz=rp(84) eps=1.0d-4 c iflag=0 nvf0=nvf do 130 n=1,nvf0 if(jv(2,n).lt.2) go to 130 i1=jv(1,n)+1 i2=i1+jv(2,n)-1 c c we compute points on edges for which vz(n) is the c minimum endpoint c minc=idint(vz(n))+1 if(dabs(dfloat(minc)-vz(n)).lt.tolz*dfloat(minc+1)) + minc=minc+1 do 120 ii=i1,i2 i=iabs(jv(1,ii)) if(i.gt.nvf) go to 120 if(vz(n).gt.vz(i)) go to 120 maxc=idint(vz(i)) if(dabs(dfloat(maxc)-vz(i)).lt.tolz*dfloat(maxc+1)) + maxc=maxc-1 if(minc.gt.maxc) go to 90 c iaft=jv(2,ii) ibef=jv(2,ii-1) ix=6 icen=0 c c check for (curved) boundary edge c if(min0(iaft,ibef).ge.0) go to 30 if(iaft.lt.0) then ix=5 if(ibndry(3,-iaft).gt.0) then icen=-iaft iz=iabs(jv(1,ii-1)) go to 20 endif endif if(ibef.lt.0) then ix=5 if(ibndry(3,-ibef).gt.0) then icen=-ibef iz=iabs(jv(1,ii+1)) go to 20 endif endif go to 30 20 kc=ibndry(3,icen) iv(1)=iz iv(2)=i iv(3)=n call grad(gy,gx,vx,vy,vz,iv,0) call arc(vx(n),vy(n),vx(i),vy(i), + xm(kc),ym(kc),theta(1),theta(2),radius,alen) q(1)=xm(kc) q(2)=ym(kc) gg=dsqrt(gx*gx+gy*gy) dp(1)=-gx/gg dp(2)=gy/gg c c the main loop over contours for this edge c 30 dx=vx(i)-vx(n) dy=vy(i)-vy(n) dz=vz(i)-vz(n) nvsv=nvf+1 if(jv(1,ii).lt.0) nvsv=-nvsv c c the new points are initialized as degree 2 vertices c do m=minc,maxc nvf=nvf+1 if(nvf.gt.maxv) then iflag=22 return endif jv(1,nvf+1)=jv(1,nvf)+ix if(jv(1,nvf+1).gt.lenjv+1) then iflag=20 return endif jv(2,nvf)=2 c l=jv(1,nvf) jv(1,l)=nvf-1 if(m.eq.minc) jv(1,l)=n if(jv(1,ii).lt.0) jv(1,l)=-jv(1,l) jv(1,l+1)=nvf+1 if(m.eq.maxc) jv(1,l+1)=i if(jv(1,ii).lt.0) jv(1,l+1)=-jv(1,l+1) jv(1,l+2)=jv(1,l) jv(1,l+3)=jv(1,l+1) jv(2,l)=ibef jv(2,l+1)=iaft jv(2,l+2)=ibef jv(2,l+3)=iaft c c check for boundary edges and adjust as necessary c if(ibef.le.0) go to 45 if(iaft.gt.0) go to 50 do k=1,2 jv(k,l)=jv(k,l+1) jv(k,l+1)=jv(k,l+2) jv(k,l+2)=jv(k,l) enddo 45 jv(2,l+3)=0 jv(1,l+3)=0 jv(1,l)=0 c 50 qq=(dfloat(m)-vz(n))/dz vx(nvf)=vx(n)+qq*dx vy(nvf)=vy(n)+qq*dy vz(nvf)=dfloat(m) c c adjust for curved boundary edge c if(icen.gt.0) then p(1)=vx(nvf) p(2)=vy(nvf) call liarc(p,dp,q,theta,radius,npts,al,ang,eps) if(npts.eq.1) then vx(nvf)=vx(nvf)+dp(1)*al(1) vy(nvf)=vy(nvf)+dp(2)*al(1) c* vx(nvf)=xm(icen)+radius*cos(ang(1)) c* vy(nvf)=ym(icen)+radius*sin(ang(1)) endif endif enddo c c fixup original edges connecting n to i c jv(1,ii)=nvsv if(jv(2,i1-1).gt.0) then jv(1,i2+1)=jv(1,i1) jv(1,i1-1)=jv(1,i2) endif c k1=jv(1,i)+1 k2=k1+jv(2,i)-1 do kk=k1,k2 if(iabs(jv(1,kk)).eq.n) go to 80 enddo 80 jv(1,kk)=nvf if(jv(1,ii).lt.0) jv(1,kk)=-nvf if(jv(2,k1-1).le.0) go to 120 jv(1,k2+1)=jv(1,k1) jv(1,k1-1)=jv(1,k2) go to 120 c c see if this edge is a contour edge and mark if necessary c 90 if(maxc+2.ne.minc) go to 120 qq=dfloat(minc-1) if(dabs(qq-vz(n)).ge.tolz*(qq+1.0d0)) go to 120 if(dabs(qq-vz(i)).ge.tolz*(qq+1.0d0)) go to 120 c c if the bef and aft points are also contour pts, then skip it c ibef=iabs(jv(1,ii-1)) iaft=iabs(jv(1,ii+1)) if(ibef.eq.0.or.iaft.eq.0) go to 120 qq=dmax1(dabs(qq-vz(ibef)),dabs(qq-vz(iaft))) if(qq.le.tolz*(qq+1.0d0)) go to 120 jv(1,ii)=-i k1=jv(1,i)+1 k2=k1+jv(2,i)-1 do kk=k1,k2 if(iabs(jv(1,kk)).eq.n) go to 110 enddo 110 jv(1,kk)=-n 120 continue 130 continue c c periodic boundary conditions c if(nvf0.eq.nvf) return do i=nvf0+1,nvf iequv(i)=i enddo do 150 i=1,nbf if(ibndry(4,i).ge.0) go to 150 j=-ibndry(4,i) if(j.lt.i) go to 150 iv1=ibndry(1,i) iv2=ibndry(2,i) jv1=ibndry(1,j) jv2=ibndry(2,j) c i1=jv(1,iv1)+1 i1=iabs(jv(1,i1)) if(i1.eq.iv2) go to 150 i2=jv(1,iv2)+jv(2,iv2) i2=iabs(jv(1,i2)) c j1=jv(1,jv1)+1 j1=iabs(jv(1,j1)) j2=jv(1,jv2)+jv(2,jv2) j2=iabs(jv(1,j2)) if(iabs(i1-i2).ne.iabs(j1-j2)) stop 3322 c if(i1.gt.i2) then inc=-1 else inc=1 endif if(j1.gt.j2) then jnc=1 else jnc=-1 endif do ii=i1,i2,inc iequv(ii)=j2 iequv(j2)=ii j2=j2+jnc enddo 150 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine aded(ntf,itnode,vx,vy,vz,jv,area,list, + ibc,ntr,maxt,rp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jv(2,*),list(2,*),ibc(*), 1 loc(3),num(3),istart(3) double precision + vx(*),vy(*),vz(*),area(*),c(3),p(2),dp(2),q(2), 1 dq(2),al(2),rp(100) c c add contour edges to the jv array c tolz=rp(84) ntr=ntf c iflag=0 c c the main loop c do 150 i=1,ntf c c read vertices and function values, initailize loc c g=geom(itnode(1,i),itnode(2,i), + itnode(3,i),vx,vy) do j=1,3 jj=itnode(j,i) c(j)=vz(jj) num(j)=0 istart(j)=0 k1=jv(1,jj)+1 k2=k1+jv(2,jj)-1 do kk=k1,k2 if(jv(2,kk).eq.i) go to 20 enddo 20 loc(j)=kk enddo c c order values c(kmin).le.c(kmid).le.c(kmax) c kmin=1 if(c(2).le.c(1)) kmin=2 kmax=3-kmin if(c(3).le.c(kmin)) kmin=3 if(c(3).gt.c(kmax)) kmax=3 kmid=6-kmin-kmax c c find min and max contour values for this triangle c minc=idint(c(kmin))+1 if(dabs(dfloat(minc)-c(kmin)).lt.tolz*dfloat(minc+1)) + minc=minc+1 maxc=idint(c(kmax)) if(dabs(dfloat(maxc)-c(kmax)).lt.tolz*dfloat(maxc+1)) + maxc=maxc-1 if(minc.gt.maxc) go to 150 c c find starting indices and number of contours for each side c do j=1,3 j1=j+1 if(j.eq.3) j1=1 if(g.lt.0) j1=6-j-j1 j2=6-j-j1 n2=itnode(j2,i) k1=loc(j1) k2=loc(j2)+1 k1=iabs(jv(1,k1)) if(k1.ne.n2) then k2=iabs(jv(1,k2)) istart(j)=min0(k1,k2) num(j)=iabs(k1-k2)+1 endif enddo c c determine if a countour will pass through middle point c imid=0 if(num(kmin)+num(kmax).ne.maxc-minc+1) imid=1 c c compute unit vector in direction of gradient c call grad(gx,gy,vx,vy,vz,itnode(1,i),0) dd=dsqrt(gx*gx+gy*gy) dp(1)=gx/dd dp(2)=gy/dd dq(1)=-dp(2) dq(2)=dp(1) c c match up end points and define new regions from stack c do 80 ic=1,2 if(ic.eq.1) then if(num(kmax).le.0) go to 80 i1=istart(kmid) i2=istart(kmax) i3=i1+num(kmax)-1 else if(num(kmin).le.0) go to 80 i1=istart(kmid)+num(kmid)-num(kmin) i2=istart(kmin) i3=i1+num(kmin)-1 endif do j=i1,i3 list(1,j)=i2 i2=i2+1 if(ntr.ge.maxt) then iflag=21 return endif ntr=ntr+1 itnode(4,ntr)=itnode(4,i) itnode(5,ntr)=itnode(5,i) list(2,j)=ntr enddo 80 continue c c the middle point c if(imid.ne.0) then jmid=istart(kmid)+num(kmax) list(1,jmid)=itnode(kmid,i) if(ntr.ge.maxt) then iflag=21 return endif ntr=ntr+1 itnode(4,ntr)=itnode(4,i) itnode(5,ntr)=itnode(5,i) list(2,jmid)=ntr endif c c compute areas c q(1)=vx(itnode(kmin,i)) q(2)=vy(itnode(kmin,i)) qd=0.0d0 it=i i1=istart(kmid) i2=i1+num(kmid)-1 do ii=i1,i2 p(1)=q(1) p(2)=q(2) pd=qd j=list(1,ii) q(1)=(vx(ii)+vx(j))/2.0d0 q(2)=(vy(ii)+vy(j))/2.0d0 dx=vx(ii)-vx(j) dy=vy(ii)-vy(j) qd=dsqrt(dx*dx+dy*dy) call lil(p,dp,q,dq,al,iflag) area(it)=dabs(al(1))*(qd+pd)/2.0d0 it=list(2,ii) enddo p(1)=vx(itnode(kmax,i)) p(2)=vy(itnode(kmax,i)) call lil(p,dp,q,dq,al,iflag) area(it)=dabs(al(1))*qd/2.0d0 c c fixup odd region near kmid c if(imid.ne.1) then jmid=i1+num(kmax)-1 k1=itnode(kmid,i) k2=itnode(kmin,i) if(num(kmax).gt.0) k2=list(1,jmid) it=i if(num(kmax).gt.0) it=list(2,jmid) k3=itnode(kmax,i) if(num(kmin).gt.0) k3=list(1,jmid+1) x2=vx(k2)-vx(k1) y2=vy(k2)-vy(k1) x3=vx(k3)-vx(k1) y3=vy(k3)-vy(k1) area(it)=area(it)+dabs(x2*y3-x3*y2)/2.0d0 endif c c now add edges c if(kmin.eq.kmax+1) g=-g if(kmin.eq.1.and.kmax.eq.3) g=-g i1=istart(kmid) i2=i1+num(kmid)-1 icur=i do j1=i1,i2 j2=list(1,j1) ilast=icur icur=list(2,j1) j=j1 if(g.lt.0.0d0) j=j2 do ll=1,2 k1=jv(1,j)+1 k2=k1+jv(2,j) jv(2,j)=jv(2,j)+1 c c shift jv array to make a hole for the new edge c do kk=k2,k1,-1 jv(1,kk+1)=jv(1,kk) jv(2,kk+1)=jv(2,kk) if(jv(2,kk).eq.i.and.kk.ne.k2) go to 110 enddo c c add the new edge c 110 j=j1+j2-j jv(1,kk+1)=-j jv(2,kk+ll-1)=icur jv(2,kk+2-ll)=ilast if(jv(2,k1-1).gt.0) then jv(2,k1-1)=jv(2,k2) jv(1,k1-1)=jv(1,k2) jv(2,k2+1)=jv(2,k1) jv(1,k2+1)=jv(1,k1) endif enddo enddo c c fixup kmax c j=itnode(kmax,i) kk=loc(kmax) jv(2,kk)=icur if(ibc(j).ne.1) then k1=jv(1,j)+1 k2=k1+jv(2,j)-1 if(jv(2,k1-1).eq.i) jv(2,k1-1)=jv(2,k2) if(jv(2,k2+1).eq.i) jv(2,k2+1)=jv(2,k1) endif c c fixup kmid c if(imid.eq.1) go to 150 if(num(kmax).eq.0) go to 150 j=itnode(kmid,i) kk=loc(kmid) icur=i1+num(kmax)-1 icur=list(2,icur) jv(2,kk)=icur if(ibc(j).eq.1) go to 150 k1=jv(1,j)+1 k2=k1+jv(2,j)-1 if(jv(2,k1-1).eq.i) jv(2,k1-1)=jv(2,k2) if(jv(2,k2+1).eq.i) jv(2,k2+1)=jv(2,k1) 150 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine areahp(i,len,itnode,area) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + area(*) c c this routine makes a heap with root at vertex i, assuming its c sons are already roots of heaps c k=i 10 kson=2*k if(kson.gt.len) return if(kson.lt.len) then is0=itnode(1,kson) is1=itnode(1,kson+1) if(area(is0).gt.area(is1)) kson=kson+1 endif is0=itnode(1,kson) ik=itnode(1,k) if(area(is0).gt.area(ik)) return itnode(1,k)=is0 itnode(2,is0)=k itnode(1,kson)=ik itnode(2,ik)=kson k=kson go to 10 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine chkrgn(itnode,jv,area,list,rp,nvf,ntr,mark,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jv(2,*),list(2,*),itnode(5,*),mark(*),iv(10),ir(10), 1 itype(10) double precision + area(*),rp(100),vx(*),vy(*),d(10) c c merge long thin boundary regions, even if it means ignoring some c contour lines c do i=1,ntr mark(i)=0 enddo diam=rp(78) hmin=rp(17)*diam/2.0d0 c c mark regions to merged c do 20 n=1,nvf if(jv(2,n).le.2) go to 20 i1=jv(1,n)+1 i2=i1+jv(2,n)-1 do 10 jj=i1,i2 irgn=jv(2,jj) if(irgn.le.0) go to 10 if(mark(irgn).ne.0) go to 10 mark(irgn)=n call getrgn(irgn,n,length,list,jv) if(length.ge.5) go to 10 is=n ncon=0 do ii=1,length kk=list(2,is) krgn=jv(2,kk-1) ks=list(1,is) iv(ii)=ks ir(ii)=krgn d(ii)=dsqrt((vx(is)-vx(ks))**2+(vy(is)-vy(ks))**2) if(krgn.le.0) then itype(ii)=-1 else if(jv(1,kk).gt.0) then itype(ii)=0 else if(itnode(5,irgn).ne.itnode(5,krgn)) then itype(ii)=-1 else itype(ii)=1 ncon=ncon+1 iedge=ii endif is=ks enddo if(ncon.ne.1) go to 10 do ii=1,length iv(ii+length)=iv(ii) ir(ii+length)=ir(ii) d(ii+length)=d(ii) itype(ii+length)=itype(ii) enddo if(iedge.le.2) iedge=length+iedge ccccc if(amin1(d(iedge+1),d(iedge-1)).gt.hmin) go to 10 if(dmax1(d(iedge+1),d(iedge-1)).gt.hmin) go to 10 if(length.eq.4) then if(itype(iedge-2).ne.-1) go to 10 if(d(iedge).le.dmin1(d(iedge+1),d(iedge-1))) + go to 10 mark(irgn)=-ir(iedge) else if(itype(iedge-1).eq.-1.and. + itype(iedge+1).eq.-1) then mark(irgn)=-ir(iedge) else if(itype(iedge-1).eq.-1) then if(d(iedge+1).gt.hmin) go to 10 if(d(iedge+1)*2.0d0.gt.d(iedge)) go to 10 mark(irgn)=-ir(iedge) else if(itype(iedge+1).eq.-1) then if(d(iedge-1).gt.hmin) go to 10 if(d(iedge-1)*2.0d0.gt.d(iedge)) go to 10 mark(irgn)=-ir(iedge) else if(2.0d0*dmax1(d(iedge+1),d(iedge-1)) + .gt.hmin) go to 10 m=iv(iedge+1) m1=jv(1,m)+1 if(jv(2,m1-1).lt.0) then mark(irgn)=-ir(iedge) go to 10 endif m2=m1+jv(2,m)-1 do mm=m1,m2 k1=jv(2,mm-1) k2=jv(2,mm) if(itnode(5,k1).ne.itnode(5,k2)) then mark(irgn)=-ir(iedge) go to 10 endif enddo endif 10 continue 20 continue c c reset mark c do irgn=1,ntr if(mark(irgn).gt.0) then n=mark(irgn) if(n.le.0) stop 9988 call getrgn(irgn,n,length,list,jv) kount=0 is=n do ii=1,length kk=list(2,is) krgn=jv(2,kk-1) if(mark(krgn).lt.0) kount=kount+1 is=list(1,is) enddo if(kount.lt.2) mark(irgn)=0 endif enddo c c merge regions c do 40 n=1,nvf if(jv(2,n).le.2) go to 40 i1=jv(1,n)+1 i2=i1+jv(2,n)-1 do 30 jj=i1,i2 irgn=jv(2,jj) if(irgn.le.0) go to 30 if(mark(irgn).ge.0) go to 30 mark(irgn)=-mark(irgn) jrgn=mark(irgn) if(mark(jrgn).gt.0) go to 30 call getrgn(irgn,n,length,list,jv) is=n do ii=1,length kk=list(2,is) krgn=jv(2,kk-1) ks=list(1,is) iv(ii)=ks ir(ii)=krgn if(krgn.le.0) then itype(ii)=-1 else if(jv(1,kk).gt.0) then itype(ii)=0 else if(itnode(5,irgn).ne.itnode(5,krgn)) then itype(ii)=-1 else itype(ii)=1 iedge=ii endif is=ks iv(ii+length)=iv(ii) ir(ii+length)=ir(ii) itype(ii+length)=itype(ii) enddo if(iedge.le.2) iedge=length+iedge if(ir(iedge).ne.jrgn) stop 3469 jseed=iv(iedge-1) iseed=iv(iedge) c c fixup vertices jseed and iseed c m=jseed do mm=1,2 i1=jv(1,m)+1 i2=i1+jv(2,m)-1 jv(2,m)=jv(2,m)-1 im=list(2,m) jv(2,im)=jrgn im=im+mm-1 if(im.gt.i2) im=i1 do k=im,i2 jv(1,k)=jv(1,k+1) jv(2,k)=jv(2,k+1) enddo if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2-1) jv(2,i1-1)=jv(2,i2-1) jv(1,i2)=jv(1,i1) jv(2,i2)=jv(2,i1) endif m=iseed enddo c c fixup rest of list c len1=length-2 is=iseed if(len1.gt.0) then do lz=1,len1 is=list(1,is) im=list(2,is) jv(2,im)=jrgn i1=jv(1,is) if(jv(2,i1).gt.0) then i2=i1+jv(2,is)+1 if(jv(2,i1).eq.irgn) jv(2,i1)=jrgn if(jv(2,i2).eq.irgn) jv(2,i2)=jrgn endif enddo endif c c marke psuedo contour edges c if(itype(iedge-1).eq.0) then krgn=ir(iedge-1) if(mark(krgn).eq.0) then is=iv(iedge-1) js=iv(iedge-2) do mm=1,2 i1=jv(1,is)+1 i2=i1+jv(2,is)-1 if(jv(2,i1-1).gt.0) then i1=i1-1 i2=i2+1 endif do k=i1,i2 if(jv(1,k).eq.js) jv(1,k)=-js enddo js=iv(iedge-1) is=iv(iedge-2) enddo endif endif if(itype(iedge+1).eq.0) then krgn=ir(iedge+1) if(mark(krgn).eq.0) then is=iv(iedge) js=iv(iedge+1) do mm=1,2 i1=jv(1,is)+1 i2=i1+jv(2,is)-1 if(jv(2,i1-1).gt.0) then i1=i1-1 i2=i2+1 endif do k=i1,i2 if(jv(1,k).eq.js) jv(1,k)=-js enddo js=iv(iedge) is=iv(iedge+1) enddo endif endif c c fixup area c area(jrgn)=area(jrgn)+area(irgn) 30 continue 40 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tstrgn(itnode,jv,area,list,jlist,vmark, + rp,nvf,ntr,itag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jv(2,*),list(2,*),itnode(5,*),itag(*),vmark(*), 1 jlist(2,*) double precision + area(*),rp(100) c c initial itnode with order (itnode(1,*)), inverse order c (itnode(2,*)), seed vertex (itnode(3,*)), marker array c (itnode(5,*)), and label (itag(*)) c areat=rp(80) hmin=rp(17) fa=areat*(hmin**2) do i=1,ntr itnode(2,i)=0 enddo ntr=0 do 40 n=1,nvf vmark(n)=0 if(jv(2,n).le.2) go to 40 i1=jv(1,n)+1 i2=i1+jv(2,n)-1 do jj=i1,i2 irgn=jv(2,jj) if(irgn.gt.0) then if(itnode(2,irgn).eq.0) then ntr=ntr+1 itnode(1,ntr)=irgn itnode(2,irgn)=ntr itnode(3,irgn)=n itag(irgn)=itnode(5,irgn) itnode(5,irgn)=0 endif endif enddo 40 continue c c make a heap c nn=ntr/2 do i=nn,1,-1 call areahp(i,ntr,itnode,area) enddo c c the main loop c nn=ntr do 200 i=1,ntr-1 irgn=itnode(1,1) itnode(1,1)=itnode(1,nn) nn=nn-1 itnode(2,itnode(1,1))=1 call areahp(1,nn,itnode,area) c call getrgn(irgn,itnode(3,irgn),length,list,jv) is=itnode(3,irgn) do ii=1,length vmark(is)=i is=list(1,is) enddo c c decide which region to merge with irgn c mrgn=0 movrlp=0 mseed=0 krgn=0 kovrlp=0 kseed=0 is=itnode(3,irgn) do ii=1,length jj=list(2,is) jrgn=jv(2,jj-1) if(jrgn.le.0) go to 70 if(itnode(5,jrgn).eq.irgn) go to 70 itnode(5,jrgn)=irgn if(itag(irgn).ne.itag(jrgn)) go to 70 c c call getrgn(jrgn,itnode(3,jrgn),jlngth,jlist,jv) c jseed=0 jend=0 js=is do jj=1,jlngth jnew=jlist(1,js) if(vmark(jnew).eq.i.and.vmark(js).ne.i) then if(jend.ne.0) go to 70 jend=jnew else if(vmark(js).eq.i.and.vmark(jnew).ne.i) then if(jseed.ne.0) go to 70 jseed=js endif js=jnew enddo js=jseed jovrlp=1 do mm=1,length jj=list(2,js) jr1=jv(2,jj-1) if(jr1.ne.jrgn) go to 70 jnew=list(1,js) if(jnew.ne.jend) then jovrlp=jovrlp+1 else go to 65 endif js=jnew enddo 65 jj=list(2,jseed) if(jv(1,jj).lt.0) then if(area(irgn).gt.fa) go to 70 if(jovrlp.lt.movrlp) then go to 70 else if(jovrlp.gt.movrlp) then movrlp=jovrlp mseed=jseed mrgn=jrgn else if(area(mrgn).le.area(jrgn)) go to 70 movrlp=jovrlp mseed=jseed mrgn=jrgn endif else if(jovrlp.lt.kovrlp) then go to 70 else if(jovrlp.gt.kovrlp) then kovrlp=jovrlp kseed=jseed krgn=jrgn else if(area(krgn).le.area(jrgn)) go to 70 kovrlp=jovrlp kseed=jseed krgn=jrgn endif endif 70 is=list(1,is) enddo if(krgn.gt.0) then jrgn=krgn jovrlp=kovrlp jseed=kseed else if(area(irgn).le.fa.and.mrgn.gt.0) then jrgn=mrgn jovrlp=movrlp jseed=mseed else go to 200 endif c c delete degree two vertices separating irgn and jrgn c is=jseed if(jovrlp.gt.1) then do ii=2,jovrlp is=list(1,is) jv(2,is)=0 enddo endif is=list(1,is) c c fixup vertices jseed and is c iv=jseed do mm=1,2 i1=jv(1,iv)+1 i2=i1+jv(2,iv)-1 jv(2,iv)=jv(2,iv)-1 im=list(2,iv) jv(2,im)=jrgn im=im+mm-1 if(im.gt.i2) im=i1 do k=im,i2 jv(1,k)=jv(1,k+1) jv(2,k)=jv(2,k+1) enddo if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2-1) jv(2,i1-1)=jv(2,i2-1) jv(1,i2)=jv(1,i1) jv(2,i2)=jv(2,i1) endif iv=is enddo c c fixup rest of list c len1=length-jovrlp-1 if(len1.gt.0) then do lz=1,len1 is=list(1,is) im=list(2,is) jv(2,im)=jrgn i1=jv(1,is) if(jv(2,i1).gt.0) then i2=i1+jv(2,is)+1 if(jv(2,i1).eq.irgn) jv(2,i1)=jrgn if(jv(2,i2).eq.irgn) jv(2,i2)=jrgn endif enddo endif c c fixup area and update heap c itnode(3,jrgn)=jseed area(jrgn)=area(jrgn)+area(irgn) jj=itnode(2,jrgn) call areahp(jj,nn,itnode,area) 200 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine chkdg2(nvf,nvf0,vx,vy,xm,ym,jv,rp,ibndry,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jv(2,*),it(2),jt(2),iequv(*) double precision + vx(*),vy(*),rp(100),xm(*),ym(*) c c look at all degree 2 vertices and eliminate c those with angle approximately equal to pi c tola=rp(81) tolb=tola*1.d-2 tolc=tola*4.0d0 hmin=dmin1(1.0d-2,rp(17))*rp(78)/4.0d0 arcmax=rp(83) c 5 ichng=0 do 130 i=1,nvf i1=jv(1,i)+1 iv1=iabs(jv(1,i1)) iv2=iabs(jv(1,i1+1)) ibdy=0 c gg=dabs(geom(iv1,i,iv2,vx,vy)) d1=dsqrt((vx(iv1)-vx(i))**2+(vy(iv1)-vy(i))**2) d2=dsqrt((vx(iv2)-vx(i))**2+(vy(iv2)-vy(i))**2) dmn=dmin1(d1,d2) dmx=dmax1(d1,d2) c if(iequv(i).eq.i) then if(jv(2,i).le.1) go to 120 if(jv(2,i).gt.2) go to 130 else if(iequv(i).lt.i) then j=iequv(i) if(jv(2,j).le.1) then if(jv(2,i).gt.1) stop 6532 go to 120 else if(jv(2,i).le.1) stop 6533 go to 130 endif else j=iequv(i) if(jv(2,i).le.1.and.jv(2,j).gt.1) stop 6534 if(jv(2,j).le.1.and.jv(2,i).gt.1) stop 6535 if(jv(2,i).le.1) go to 120 if(jv(2,i).gt.2.or.jv(2,j).gt.2) go to 130 j1=jv(1,j)+1 jv1=iabs(jv(1,j1)) jv2=iabs(jv(1,j1+1)) if(iequv(j).ne.i) go to 130 if(iequv(jv1).ne.iv2) go to 130 if(iequv(jv2).ne.iv1) go to 130 if(iequv(iv1).ne.jv2) go to 130 if(iequv(iv2).ne.jv1) go to 130 k1=iabs(jv(2,i1-1)) k2=iabs(jv(2,i1+1)) if(ibndry(4,k2).ne.ibndry(4,k1)) ibdy=1 endif if(jv(2,i1-1).gt.0) then id=max0(jv(2,iv1),jv(2,iv2)) if(dmn.gt.hmin.or.id.lt.2) then if(gg.gt.tola) go to 130 else if(gg.gt.tolc) go to 130 endif go to 20 endif c c boundary point c k1=iabs(jv(2,i1-1)) k2=iabs(jv(2,i1+1)) jsw=0 do j=3,6 if(ibndry(j,k1).ne.ibndry(j,k2)) jsw=1 enddo if(jsw.eq.0.and.ibndry(3,k1).ne.0) jsw=-1 if(jsw.ge.0.and.gg.gt.tolb) go to 130 c c make sure there are at least 3 points on the boundary c m1=jv(1,iv1)+1 mv1=iabs(jv(1,m1)) if(mv1.eq.iv2) go to 130 if(mv1.eq.iequv(i)) go to 130 c c other possible boundary disqualifications c isw=0 if(ibndry(6,k1).ne.ibndry(6,k2)) isw=1 if(ibndry(4,k1).ge.0) then if(ibndry(4,k1).ne.ibndry(4,k2)) isw=1 else if(ibndry(4,k2).ge.0) isw=1 endif icen1=ibndry(3,k1) icen2=ibndry(3,k2) if(icen1.gt.0.and.icen2.le.0) isw=1 if(icen1.le.0.and.icen2.gt.0) isw=1 if(icen1.gt.0.and.icen2.gt.0.and.jsw.ge.0) then qn=(xm(icen1)-xm(icen2))**2+ + (ym(icen1)-ym(icen2))**2 r1=(vx(i)-xm(icen1))**2+(vy(i)-ym(icen1))**2 r2=(vx(i)-xm(icen2))**2+(vy(i)-ym(icen2))**2 if(qn.ge.tola*(r1+r2)) isw=1 call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(icen1),ym(icen1),theta1,theta2,r2,alen) if(dabs(theta1-theta2).ge.arcmax) isw=1 endif if(isw.eq.0) go to 20 c c this section tries to eliminate the case of boundary contour points c very near a boundary corner c if(max0(iv1,iv2).le.nvf0) then go to 130 else if(iv2.le.nvf0) then dd=d1 ivv=iv1 else if(iv1.le.nvf0) then dd=d2 ivv=iv2 else dd=dmn if(d1.lt.d2) then ivv=iv1 else ivv=iv2 endif endif if(dd.gt.hmin) then if(gg.gt.tola) go to 130 else if(dd.gt.dmax1(hmin,dmx)/10.0d0) go to 130 endif vx(ivv)=vx(i) vy(ivv)=vy(i) if(iequv(i).ne.i) then vx(iequv(ivv))=vx(iequv(i)) vy(iequv(ivv))=vy(iequv(i)) endif c c delete this point c 20 ichng=ichng+1 do ll=1,2 it(ll)=0 jt(ll)=0 i1=jv(1,iv1)+1 i2=i1+jv(2,iv1)-1 do m=i1,i2 if(iabs(jv(1,m)).eq.i) it(ll)=m if(iabs(jv(1,m)).eq.iv2) jt(ll)=m enddo m=it(ll) k=jv(1,m) jv(1,m)=iv2 if(k.lt.0) jv(1,m)=-iv2 if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2) jv(1,i2+1)=jv(1,i1) else if(ll.eq.1.and.ibdy.eq.1) then if(jv(2,i2).eq.-k1) jv(2,i2)=-k2 endif endif ii=iv1 iv1=iv2 iv2=ii enddo c c ckeck for two sided region c if(jt(1)+jt(2).eq.0) go to 110 c c fixup vertex iv1 c do ll=1,2 i1=jv(1,iv1)+1 i2=i1+jv(2,iv1)-1 c m1=min0(jt(ll),it(ll)) m2=jt(ll)+it(ll)-m1 if(m1.eq.i1.and.m2.eq.i2) m1=i2 c jv(2,iv1)=jv(2,iv1)-1 do k=m1,i2 jv(1,k)=jv(1,k+1) jv(2,k)=jv(2,k+1) enddo if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2-1) jv(2,i1-1)=jv(2,i2-1) jv(1,i2)=jv(1,i1) jv(2,i2)=jv(2,i1) endif c ii=iv1 iv1=iv2 iv2=ii enddo 110 if(iequv(i).eq.i) go to 120 do ll=1,2 it(ll)=0 jt(ll)=0 i1=jv(1,jv1)+1 i2=i1+jv(2,jv1)-1 do m=i1,i2 if(iabs(jv(1,m)).eq.j) it(ll)=m if(iabs(jv(1,m)).eq.jv2) jt(ll)=m enddo m=it(ll) k=jv(1,m) jv(1,m)=jv2 if(k.lt.0) jv(1,m)=-jv2 if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2) jv(1,i2+1)=jv(1,i1) else if(ll.eq.2.and.ibdy.eq.1) then jv(2,i1-1)=ibndry(4,k2) endif endif ii=jv1 jv1=jv2 jv2=ii enddo c c ckeck for two sided region c if(jt(1)+jt(2).eq.0) go to 115 c c fixup vertex jv1 c do ll=1,2 i1=jv(1,jv1)+1 i2=i1+jv(2,jv1)-1 c m1=min0(jt(ll),it(ll)) m2=jt(ll)+it(ll)-m1 if(m1.eq.i1.and.m2.eq.i2) m1=i2 c jv(2,jv1)=jv(2,jv1)-1 do k=m1,i2 jv(1,k)=jv(1,k+1) jv(2,k)=jv(2,k+1) enddo if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2-1) jv(2,i1-1)=jv(2,i2-1) jv(1,i2)=jv(1,i1) jv(2,i2)=jv(2,i1) endif c ii=jv1 jv1=jv2 jv2=ii enddo 115 jv(2,j)=0 c 120 jv(2,i)=0 130 continue if(ichng.gt.0) go to 5 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine chkdg3(nvf,vx,vy,jv,rp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jv(2,*),isv(2,10),jsv(2,20) double precision + vx(*),vy(*),rp(100) c c look for very short contour edges connected to c vertices of degree greater than or equal to 3 c hmin=dmin1(1.0d-2,rp(17))*rp(78)/2.0d0 c do 130 i=1,nvf i1=jv(1,i)+1 if(jv(2,i1-1).le.0) go to 130 if(jv(2,i).le.2) go to 130 i2=i1+jv(2,i)-1 isize=jv(1,i+1)-jv(1,i)-2 do 120 ii=i1,i2 j=-jv(1,ii) if(j.le.0) go to 120 j1=jv(1,j)+1 if(jv(2,j1-1).le.0) go to 120 if(jv(2,j).le.2) go to 120 ilen=jv(2,i)+jv(2,j)-2 if(ilen.gt.min0(isize,10)) go to 120 dd=dsqrt((vx(i)-vx(j))**2+(vy(i)-vy(j))**2) if(dd.gt.hmin) go to 120 if(ii.lt.i2) then do k=ii+1,i2 isv(1,k-ii)=jv(1,k) isv(2,k-ii)=jv(2,k) enddo endif jlen=jv(2,j) m=0 do k=1,jlen jsv(1,k)=jv(1,j1+k-1) jsv(2,k)=jv(2,j1+k-1) jsv(1,k+jlen)=jsv(1,k) jsv(2,k+jlen)=jsv(2,k) if(iabs(jsv(1,k)).eq.i) m=k enddo if(m.eq.0) stop 7654 kk=ii do k=m+1,m+jlen-1 jv(1,kk)=jsv(1,k) jv(2,kk)=jsv(2,k) mm=iabs(jv(1,kk)) kk=kk+1 m1=jv(1,mm)+1 m2=m1+jv(2,mm)-1 do ms=m1,m2 if(iabs(jv(1,ms)).eq.j) then if(jv(1,ms).lt.0) then jv(1,ms)=-i else jv(1,ms)=i endif endif enddo if(jv(2,m1-1).gt.0) then jv(1,m1-1)=jv(1,m2) jv(1,m2+1)=jv(1,m1) endif enddo if(ii.lt.i2) then do k=ii+1,i2 jv(1,kk)=isv(1,k-ii) jv(2,kk)=isv(2,k-ii) kk=kk+1 enddo endif jv(2,i)=ilen jv(1,i1-1)=jv(1,kk-1) jv(2,i1-1)=jv(2,kk-1) jv(1,kk)=jv(1,i1) jv(2,kk)=jv(2,i1) jv(2,j)=0 go to 130 120 continue 130 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine chkpth(irgn,jrgn,iseed,list,ilist,jlist, + vx,vy,jv,rp,ity) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(2,*),jv(2,*),ilist(2,*),jlist(2,*) double precision + vx(*),vy(*),p(2),dp(2),q(2),dq(3),al(2),ang(2), 1 c(2),t(2),rp(100) c c check interior vertices on the path to see if any can be c eliminated and replace by a circular arc c arcmax=rp(83) arcmin=rp(82) tolf=rp(85) eps=1.d-3 epsa=rp(51) c* hmin=amin1(1.0e-2,rp(17))*rp(78)/2.0e0 call getpth(irgn,iseed,length,list,jv) if(length.le.1) return c c check each path going in only one direction c last=iseed do ii=1,length last=list(1,last) enddo if(last.lt.iseed) return c c find the rest of the two affected regions c call getrgn(irgn,iseed,ilen,ilist,jv) istart=iseed if(list(1,iseed).eq.ilist(1,iseed)) istart=last istart=ilist(1,istart) ilen=ilen-length-1 c call getrgn(jrgn,iseed,jlen,jlist,jv) jstart=iseed if(list(1,iseed).eq.jlist(1,iseed)) jstart=last jstart=jlist(1,jstart) jlen=jlen-length-1 c minmrk=0 if(ilen.lt.1.or.jlen.lt.1) minmrk=1 c c the main loop c llen=length ileft=iseed c c find iright c 20 iright=ileft do lrlen=1,llen iright=list(1,iright) if(list(2,iright).eq.1) go to 40 enddo 40 if(lrlen.le.1) go to 250 c c compute coordinates c 50 p(1)=vx(ileft) p(2)=vy(ileft) dp(1)=vx(iright)-vx(ileft) dp(2)=vy(iright)-vy(ileft) dq(1)=-dp(2) dq(2)=dp(1) c c look at intermediate vertices, finding the c largest perpendicular deviation from a straight line c and compute center of circle by least squares c dmln=0.0d0 msave=0 lsave=0 mm=ileft lm=lrlen-1 xx=(vx(ileft)+vx(iright))/2.0d0 yy=(vy(ileft)+vy(iright))/2.0d0 dd=(dq(1)*dq(1)+dq(2)*dq(2))/4.0d0 r=0.0d0 rr=0.0d0 do lz=1,lm mm=list(1,mm) c rr=rr+((vx(mm)-xx)**2+(vy(mm)-yy)**2-dd) r=r+dq(1)*(vx(mm)-xx)+dq(2)*(vy(mm)-yy) c q(1)=vx(mm) q(2)=vy(mm) call lil(p,dp,q,dq,al,iflag) if(dabs(al(2)).ge.dmln) then dmln=dabs(al(2)) msave=mm lsave=lz endif enddo if(minmrk.gt.0) go to 240 c c ckeck the rest of the region for straight line c do 150 iz=1,2 if(iz.eq.1) then if(ilen.le.0) go to 150 ll=ilen i1=ilist(1,istart) else if(jlen.le.0) go to 150 ll=jlen i1=jlist(1,jstart) endif do lz=1,ll if(iz.eq.1) then i2=ilist(1,i1) else i2=jlist(1,i1) endif q(1)=vx(i1) q(2)=vy(i1) dq(1)=-dp(2) dq(2)=dp(1) call lil(p,dp,q,dq,al,iflag) if(al(1).le.1.0d0-eps.and.al(1).ge.eps) then if(dabs(al(2)).lt.dmln*tolf) go to 160 endif if(lz.lt.ll) then dq(1)=vx(i2)-vx(i1) dq(2)=vy(i2)-vy(i1) call lil(p,dp,q,dq,al,iflag) if(iflag.eq.0) then if(dmax1(al(1),al(2)).le.1.0d0+eps.and. + dmin1(al(1),al(2)).ge.-eps) go to 160 endif endif i1=i2 enddo 150 continue c c accept straight line c go to 250 c** if(dmln.le.hmin) go to 250 c c compute parameterization in terms of (r,theta) c 160 if(r.eq.0.0d0.or.ity.eq.1) go to 240 r=rr/(2.0d0*r) xcen=xx-r*dp(2) ycen=yy+r*dp(1) call arc(vx(ileft),vy(ileft),vx(iright),vy(iright), + xcen,ycen,theta1,theta2,rad,alen) if(dabs(theta1-theta2).le.arcmin) go to 240 if(dabs(theta1-theta2).ge.arcmax) go to 240 c c check deviation from proposed arc c dmarc=0.0d0 mm=ileft icen=0 do lz=1,lrlen ms=mm mm=list(1,mm) rr=(vx(mm)-xcen)**2+(vy(mm)-ycen)**2 rr=dsqrt(rr)/rad if(dabs(rr-1.0d0).ge.dmarc.and.lz.le.lm) then dmarc=dabs(rr-1.0d0) icen=mm endif xx=(vx(mm)+vx(ms))/2.0d0 yy=(vy(mm)+vy(ms))/2.0d0 rr=(xx-xcen)**2+(yy-ycen)**2 rr=dsqrt(rr)/rad if(dabs(rr-1.0d0).ge.dmarc) then dmarc=dabs(rr-1.0d0) icen=ms if(lz.eq.1) icen=mm endif enddo c c ckeck the rest of the region c c(1)=xcen c(2)=ycen t(1)=dmin1(theta1,theta2) t(2)=dmax1(theta1,theta2) tm=(theta1+theta2)/2.0d0 xx=xcen+rad*dcos(tm) yy=xcen+rad*dsin(tm) do 230 iz=1,2 if(iz.eq.1) then if(ilen.le.0) go to 230 ll=ilen i1=ilist(1,istart) else if(jlen.le.0) go to 230 ll=jlen i1=jlist(1,jstart) endif do lz=1,ll if(iz.eq.1) then i2=ilist(1,i1) else i2=jlist(1,i1) endif q(1)=vx(i1) q(2)=vy(i1) rr=dsqrt((q(1)-xcen)**2+(q(2)-ycen)**2)/rad if(dabs(rr-1.0d0).lt.dmarc*tolf) then dq(1)=-dp(2) dq(2)=dp(1) cc call lil(p,dp,q,dq,al,iflag) cc if(al(1).le.1.0e0+eps.and.al(1).ge.-eps) then cc if(abs(al(2)).lt.dmln*tolf) go to 240 cc endif call liarc(q,dq,c,t,rad,npts,al,ang,epsa) if(npts.eq.2) go to 240 if(npts.eq.1) then qq=dabs(al(1))*dsqrt(dq(1)**2+dq(2)**2)/rad if(qq.lt.2.0d0*dmarc*tolf) go to 240 endif endif if(lz.lt.ll) then dq(1)=vx(i2)-vx(i1) dq(2)=vy(i2)-vy(i1) call liarc(q,dq,c,t,rad,npts,al,ang,epsa) if(npts.ge.1) then if(al(1).le.1.0d0+eps.and.al(1).ge.-eps + .and.ang(1).lt.t(2)+eps) go to 240 endif if(npts.eq.2) then if(al(2).le.1.0d0+eps.and.al(2).ge.-eps + .and.ang(2).lt.t(2)+eps) go to 240 endif endif i1=i2 enddo 230 continue c c accept the circle, store center in (vx(icen),vy(icen)) c list(2,icen)=-1 vx(icen)=xcen vy(icen)=ycen go to 250 c 240 list(2,msave)=1 lrlen=lsave iright=msave minmrk=minmrk-1 if(lrlen.gt.1) go to 50 c 250 ileft=iright llen=llen-lrlen if(llen.gt.1) go to 20 c c delete unmarked degree 2 vertices c i=iseed ileft=i llen=length-1 do 300 lz=1,llen iv1=ileft i=list(1,i) iv2=list(1,i) ileft=i if(list(2,i).lt.0) jv(2,i)=-2 if(list(2,i).ne.0) go to 300 ileft=iv1 jv(2,i)=0 do ll=1,2 i1=jv(1,iv1)+1 i2=i1+iabs(jv(2,iv1))-1 do j=i1,i2 k=jv(1,j) if(iabs(k).eq.i) go to 270 enddo 270 jv(1,j)=iv2 if(k.lt.0) jv(1,j)=-iv2 if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2) jv(1,i2+1)=jv(1,i1) endif ii=iv1 iv1=iv2 iv2=ii enddo 300 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine chkpt0(irgn,jrgn,iseed,list,ilist,jlist,vx,vy,jv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(2,*),jv(2,*),ilist(2,*),jlist(2,*), 1 mlen(4),mseed(4),mvert(4),mrgn(4) double precision + vx(*),vy(*) c c check vertices on paths breaking up contours which are not c simply connected and try to replace by straight line c angmax=0.95d0 angmin=0.15d0 c call getpth(irgn,iseed,length,list,jv) c jseed=iseed do ii=1,length jseed=list(1,jseed) enddo c c find the rest of the two affected regions c call getrgn(irgn,iseed,ilen,ilist,jv) call getrgn(jrgn,iseed,jlen,jlist,jv) c c compute the paths of degree 2 vertices leading up and away from c iseed and jseed c is=jseed isir=0 jsir=0 do i=1,ilen-length-1 is=ilist(1,is) if(jv(2,is).ne.2) then if(jsir.eq.0) then jsir=is mlen(1)=i-1 else isir=is mlen(2)=ilen-length-i-1 endif endif enddo is=iseed jsjr=0 isjr=0 do i=1,jlen-length-1 is=jlist(1,is) if(jv(2,is).ne.2) then if(isjr.eq.0) then isjr=is mlen(3)=i-1 else jsjr=is mlen(4)=jlen-length-i-1 endif endif enddo mseed(1)=jseed mseed(2)=isir mseed(3)=iseed mseed(4)=jsjr mvert(1)=iseed mvert(2)=jseed mvert(3)=jseed mvert(4)=iseed mrgn(1)=irgn mrgn(2)=jrgn mrgn(3)=jrgn mrgn(4)=irgn c c look for short link (iseed,kk) or (kk,jseed) c dd=(vx(iseed)-vx(jseed))**2+(vy(iseed)-vy(jseed))**2 kk=0 icase=0 do k=1,4 is=mseed(k) m=mvert(k) if(mlen(k).gt.0) then do i=1,mlen(k) ibef=is if(k.le.2) then is=ilist(1,is) iaft=ilist(1,is) else is=jlist(1,is) iaft=jlist(1,is) endif d1=(vx(m)-vx(is))**2+(vy(m)-vy(is))**2 if(d1.lt.dd) then kbef=ibef kk=is kaft=iaft dd=d1 icase=k endif enddo endif enddo c c we can shorten this eventually c ibef=iseed do i=1,ilen-1 ibef=ilist(1,ibef) enddo iaft=ilist(1,jseed) c jbef=jseed do i=1,jlen-1 jbef=jlist(1,jbef) enddo jaft=jlist(1,iseed) c c compute angles c if(icase.eq.0) then bi=cang(iseed,jseed,iaft,vx,vy) bj=cang(jbef,jseed,iseed,vx,vy) ti=cang(ibef,iseed,jseed,vx,vy) tj=cang(jseed,iseed,jaft,vx,vy) else if(icase.eq.1.or.icase.eq.4) then bi=cang(iseed,kk,kaft,vx,vy) bj=cang(kbef,kk,iseed,vx,vy) ti=cang(ibef,iseed,kk,vx,vy) tj=cang(kk,iseed,jaft,vx,vy) else bi=cang(kk,jseed,iaft,vx,vy) bj=cang(jbef,jseed,kk,vx,vy) ti=cang(kbef,kk,jseed,vx,vy) tj=cang(jseed,kk,kaft,vx,vy) endif angmn=dmin1(bi,bj,ti,tj) angmx=dmax1(bi,bj,ti,tj) if(angmn.lt.angmin) return if(angmx.gt.angmax) return c c delete all interior vertices on path c if(length.gt.1) then i=iseed ileft=i do 300 lz=1,length-1 iv1=ileft i=list(1,i) iv2=list(1,i) ileft=i if(list(2,i).ne.0) go to 300 ileft=iv1 jv(2,i)=0 do ll=1,2 i1=jv(1,iv1)+1 i2=i1+iabs(jv(2,iv1))-1 do j=i1,i2 k=jv(1,j) if(iabs(k).eq.i) go to 270 enddo 270 jv(1,j)=iv2 if(k.lt.0) jv(1,j)=-iv2 if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2) jv(1,i2+1)=jv(1,i1) endif ii=iv1 iv1=iv2 iv2=ii enddo 300 continue endif if(icase.eq.0) return c c c mi=mvert(icase) mj=iseed+jseed-mi ir=mrgn(icase) jr=irgn+jrgn-ir c c fixup mi c i1=jv(1,mi)+1 if(jv(2,mi).lt.0) stop 101 i2=i1+jv(2,mi)-1 do j=i1,i2 if(iabs(jv(1,j)).eq.mj) go to 320 enddo stop 111 320 jv(1,j)=kk if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2) jv(1,i2+1)=jv(1,i1) endif c c fixup mj c i1=jv(1,mj)+1 i2=i1+jv(2,mj)-1 if(jv(2,mj).lt.0) stop 102 jv(2,mj)=jv(2,mj)-1 do j=i1,i2 if(iabs(jv(1,j)).eq.mi) go to 330 enddo stop 113 330 if(jv(2,j-1).ne.ir) stop 103 if(icase.eq.1.or.icase.eq.3) then if(j.eq.i1) then jv(2,i2)=jr else jv(2,j-1)=jr endif endif do k=j,i2 jv(1,k)=jv(1,k+1) jv(2,k)=jv(2,k+1) enddo if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2-1) jv(2,i1-1)=jv(2,i2-1) jv(1,i2)=jv(1,i1) jv(2,i2)=jv(2,i1) endif c c fixup kk c i1=jv(1,kk)+1 i2=i1+2 if(jv(2,kk).ne.2) stop 104 jv(2,kk)=3 if(icase.eq.1.or.icase.eq.3) then if(jv(2,i1).eq.ir) then jv(1,i2)=jv(1,i2-1) jv(2,i2)=jv(2,i2-1) jv(1,i2-1)=mi jv(2,i2-1)=jr else jv(1,i2)=mi jv(2,i2)=jr endif else if(jv(2,i1).eq.jr) then jv(1,i2)=jv(1,i2-1) jv(2,i2)=jv(2,i2-1) jv(1,i2-1)=mi jv(2,i2-1)=jr jv(2,i1)=ir else jv(1,i2)=mi jv(2,i2)=jr jv(2,i2-1)=ir endif endif if(jv(2,i1-1).gt.0) then jv(1,i1-1)=jv(1,i2) jv(2,i1-1)=jv(2,i2) jv(1,i2+1)=jv(1,i1) jv(2,i2+1)=jv(2,i1) endif c c fixup degree 2 verties that switch regions c if(icase.eq.1.or.icase.eq.2) then if(icase.eq.1) then is=jseed it=kk else is=kk it=iseed endif 500 is=ilist(1,is) if(is.ne.it) then i1=jv(1,is) if(jv(2,i1).eq.irgn) then jv(2,i1)=jrgn if(jv(2,i1-1).gt.0) jv(2,i1+2)=jrgn else if(jv(2,i1+1).ne.irgn) stop 9854 jv(2,i1+1)=jrgn if(jv(2,i1-1).gt.0) jv(2,i1-1)=jrgn endif go to 500 endif endif if(icase.eq.3.or.icase.eq.4) then if(icase.eq.3) then is=iseed it=kk else is=kk it=jseed endif 510 is=jlist(1,is) if(is.ne.it) then i1=jv(1,is) if(jv(2,i1).eq.jrgn) then jv(2,i1)=irgn if(jv(2,i1-1).gt.0) jv(2,i1+2)=irgn else if(jv(2,i1+1).ne.jrgn) stop 9855 jv(2,i1+1)=irgn if(jv(2,i1-1).gt.0) jv(2,i1-1)=irgn endif go to 510 endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine getrgn(irgn,iseed,length,list,jv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(2,*),jv(2,*) c c compute boundary for region irgn c length=0 i=iseed ii=iseed 10 i1=jv(1,i)+1 i2=i1+iabs(jv(2,i))-1 c do j=i1,i2 if(jv(2,j).eq.irgn) go to 30 enddo 30 k=iabs(jv(1,j)) if(i.eq.ii) list(2,ii)=j c c skip midpoint vertices for interior curved edges c if(jv(2,k).ne.-2) then list(1,ii)=k length=length+1 ii=k endif i=k if(i.ne.iseed) go to 10 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine getpth(irgn,iseed,length,list,jv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(2,*),jv(2,*) c c compute path starting from vertex iseed c length=0 i=iseed c c follow a region c if(irgn.gt.0) then 10 i1=jv(1,i)+1 i2=i1+iabs(jv(2,i))-1 do j=i1,i2 if(jv(2,j).eq.irgn) go to 30 enddo 30 list(1,i)=iabs(jv(1,j)) list(2,i)=0 i=list(1,i) length=length+1 if(iabs(jv(2,i)).le.2) go to 10 c c follow the boundary c else 50 i1=jv(1,i)+1 i2=i1+iabs(jv(2,i))-1 list(1,i)=iabs(jv(1,i2)) list(2,i)=0 i=list(1,i) length=length+1 if(iabs(jv(2,i)).le.2) go to 50 endif c c mark first and last vertices c list(2,iseed)=1 list(1,i)=0 list(2,i)=1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cds(ip,jv,itnode,ibndry,jb,vx,vy,xm,ym,jbndry, + list,itag,imark,iequv) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),jv(2,*),jbndry(6,*), 1 list(2,*),ip(100),itag(*),iequv(*) double precision + vx(*),vy(*),xm(*),ym(*) c c compute skeleton data structures from the jv array c nvr=ip(2) ncr=ip(3) nbr=ip(4) maxv=ip(22) maxc=ip(23) maxb=ip(24) c do i=1,nbr do j=1,6 jbndry(j,i)=ibndry(j,i) enddo enddo nbr0=nbr nbr=0 ntr=0 iflag=0 c c make initial form of jb c do 70 i=1,nvr c c associate an edge with higher numbered vertex c if(jv(2,i).le.1) go to 70 i1=jv(1,i)+1 i2=i1+jv(2,i)-1 do j=i1,i2 k=iabs(jv(1,j)) it=i if(jv(2,k).eq.-2) then it=k k1=jv(1,it)+1 k=iabs(jv(1,k1)) if(k.eq.i) k=iabs(jv(1,k1+1)) endif if(k.lt.i) then c c initial form of ibndry for a new edge c if(nbr.ge.maxb) then iflag=24 go to 200 endif nbr=nbr+1 k1=jv(1,k)+1 k2=k1+jv(2,k)-1 do l=k1,k2 if(iabs(jv(1,l)).eq.it) go to 50 enddo 50 ibndry(1,nbr)=j ibndry(2,nbr)=l ibndry(3,nbr)=i ibndry(4,nbr)=k ibndry(5,nbr)=0 ibndry(6,nbr)=0 kk=-min0(jv(2,j-1),jv(2,j)) if(kk.gt.0) ibndry(6,nbr)=kk if(it.ne.i) ibndry(6,nbr)=-it endif enddo 70 continue c c now find regions c itnode(1,1)=1 do 100 i=1,nvr if(jv(2,i).lt.2) go to 100 i1=jv(1,i)+1 i2=i1+jv(2,i)-1 do 90 j=i1,i2 iseed=i irgn=jv(2,j) if(irgn.le.0) go to 90 if(itag(irgn).eq.imark) go to 90 call getrgn(irgn,iseed,length,list,jv) c c initialize itnode, mark region as found c k=itnode(1,ntr+1) ntr=ntr+1 itnode(1,ntr+1)=k+length itnode(2,ntr)=k+length-1 itnode(3,ntr)=0 itnode(4,ntr)=0 itnode(5,ntr)=itag(irgn) itag(irgn)=imark c c initial form of jb for a new region c m=iseed do jj=1,length jb(k)=list(2,m) k=k+1 m=list(1,m) enddo 90 continue 100 continue c c compute vx,vy and xm,ym for interior curved edges c nvr0=nvr nvr=0 do i=1,nvr0 if(jv(2,i).gt.1) then c c a new vertex c nvr=nvr+1 jv(1,i)=nvr vx(nvr)=vx(i) vy(nvr)=vy(i) c else if(jv(2,i).eq.-2) then c c a new circle center c if(ncr.ge.maxc) then iflag=23 go to 200 endif ncr=ncr+1 jv(1,i)=ncr xm(ncr)=vx(i) ym(ncr)=vy(i) endif enddo c c final form of ibndry c do i=1,nvr jv(2,i)=0 enddo do i=1,nbr jbndry(1,i)=0 jbndry(2,i)=0 enddo do i=1,nbr do j=1,2 m=ibndry(j,i) jv(1,m)=i m=ibndry(j+2,i) ibndry(j,i)=jv(1,m) jv(2,jv(1,m))=m enddo kk=ibndry(6,i) ibndry(3,i)=0 ibndry(4,i)=0 ibndry(5,i)=0 ibndry(6,i)=0 if(kk.lt.0) ibndry(3,i)=jv(1,-kk) c c a boundary edge c if(kk.gt.0) then jbndry(1,i)=kk jbndry(2,i)=-jbndry(4,kk) ibndry(3,i)=jbndry(3,kk) ibndry(4,i)=jbndry(4,kk) ibndry(5,i)=jbndry(5,kk) ibndry(6,i)=jbndry(6,kk) endif enddo c c periodic bc first fixup iequv c do i=1,nvr if(jv(2,i).eq.0) then iequv(i)=i else j=iequv(jv(2,i)) iequv(i)=jv(1,j) endif enddo do i=1,nvr if(iequv(i).gt.0) then next=iequv(i) last=i 110 iequv(last)=-i if(next.ne.i) then last=next next=iequv(next) go to 110 endif endif enddo do i=1,nvr iequv(i)=-iequv(i) enddo c c now match up periodic boundaries c jbndry(1,*),jbndry(2,*) contain lines between old bdy edges for c new periodic edges c c jbndry(3,*),jbndry(4,*) is a linked list of jbndry(1,*) as a c function of old boundary edge number c nbb=max0(nbr,nbr0) do i=1,nbb jbndry(3,i)=0 jbndry(4,i)=0 enddo do i=1,nbr if(jbndry(1,i).ne.0) then k=jbndry(1,i) jbndry(3,i)=jbndry(4,k) jbndry(4,k)=i endif if(ibndry(4,i).lt.0) ibndry(4,i)=-(nbr+1) enddo do 150 i=1,nbr if(ibndry(4,i).ge.-nbr) go to 150 k=jbndry(2,i) m=4 120 k=jbndry(m,k) m=3 if(k.eq.0) stop 8877 if(jbndry(2,k).ne.jbndry(1,i)) go to 120 i1=iequv(ibndry(1,i)) i2=iequv(ibndry(2,i)) k1=iequv(ibndry(1,k)) k2=iequv(ibndry(2,k)) if(i1.ne.k1.and.i1.ne.k2) go to 120 if(i2.ne.k1.and.i2.ne.k2) go to 120 ibndry(4,i)=-k ibndry(4,k)=-i 150 continue c c final form of jb c l=itnode(2,ntr) do i=1,l m=jb(i) jb(i)=jv(1,m) enddo c c look for crack tips c call tstjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,jb,jv) c c final form of itnode c do i=1,ntr i1=itnode(1,i) i2=itnode(2,i) j1=jb(i1) j2=jb(i2) k=ibndry(1,j1) if(k.ne.ibndry(1,j2).and.k.ne.ibndry(2,j2)) k=ibndry(2,j1) if(k.ne.ibndry(1,j2).and.k.ne.ibndry(2,j2)) stop 3457 itnode(1,i)=k itnode(2,i)=j1 enddo c c divide long curved edges c call dvedge(ntr,nvr,nbr,maxv,maxb,vx,vy,xm,ym, + ibndry,itnode,list,iflag) c 200 ip(1)=ntr ip(2)=nvr ip(3)=ncr ip(4)=nbr ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tstjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,jb,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),list(*) double precision + vx(*),vy(*),p(2),dp(2),q(2),dq(2),al(2),xm(*),ym(*) c c compute jb array from ibndry, vx vy c fudge=2.0d0 c c initialize with list of edges as function of vertex in list c do i=1,nvr list(i+1)=0 enddo do i=1,nbr list(ibndry(1,i)+1)=list(ibndry(1,i)+1)+1 list(ibndry(2,i)+1)=list(ibndry(2,i)+1)+1 if(ibndry(4,i).eq.0) then list(nvr+1+i)=2 else list(nvr+1+i)=1 endif enddo list(1)=nvr+nbr+2 do i=1,nvr list(i+1)=list(i)+list(i+1) enddo do i=1,nbr do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo enddo do i=nvr,2,-1 list(i)=list(i-1) enddo list(1)=nvr+nbr+2 c c now check jb for cracks...make sure points are c properly positioned above and below the crack. c do i=1,ntr i1=itnode(1,i) i2=itnode(2,i) do j=i1,i2 ie1=jb(j) if(j.eq.i1) then ie2=jb(i2) else ie2=jb(j-1) endif icom=ibndry(1,ie1) if(icom.ne.ibndry(1,ie2).and.icom.ne.ibndry(2,ie2)) + icom=ibndry(2,ie1) iaft=ibndry(1,ie1)+ibndry(2,ie1)-icom ibef=ibndry(1,ie2)+ibndry(2,ie2)-icom if(max0(ibndry(3,ie1),ibndry(3,ie2)).gt.0) then a0=cang1(ibef,icom,iaft,ie2,ie1,vx,vy, + xm,ym,ibndry) else a0=cang(ibef,icom,iaft,vx,vy) endif j1=list(icom) j2=list(icom+1)-1 if(j2.eq.j1+1) then if(a0.eq.0.0d0) then dx1=vx(iaft)-vx(icom) dy1=vy(iaft)-vy(icom) dd1=dsqrt(dx1**2+dy1**2) p(1)=vx(icom) p(2)=vy(icom) dp(1)=dx1/dd1 dp(2)=dy1/dd1 dq(1)=-dp(2) dq(2)=dp(1) q(1)=vx(ibef) q(2)=vy(ibef) call lil(p,dp,q,dq,al,jflag) vx(ibef)=vx(ibef)+al(2)*fudge*dq(1) vy(ibef)=vy(ibef)+al(2)*fudge*dq(2) endif else do kk=j1,j2 k=list(kk) if(k.ne.ie1.and.k.ne.ie2) then next=ibndry(1,k)+ibndry(2,k)-icom if(max0(ibndry(3,k),ibndry(3,ie2)).gt.0) + then aa=cang1(ibef,icom,next,ie2,k,vx,vy, + xm,ym,ibndry) else aa=cang(ibef,icom,next,vx,vy) endif if(aa.le.a0) then dx1=vx(iaft)-vx(icom) dy1=vy(iaft)-vy(icom) dd1=dsqrt(dx1**2+dy1**2) dx2=vx(next)-vx(icom) dy2=vy(next)-vy(icom) dd2=dsqrt(dx2**2+dy2**2) p(1)=vx(icom) p(2)=vy(icom) dp(1)=dx1/dd1+dx2/dd2 dp(2)=dy1/dd1+dy2/dd2 dq(1)=-dp(2) dq(2)=dp(1) c c fixup iaft and next c ix=iaft do jj=1,2 q(1)=vx(ix) q(2)=vy(ix) call lil(p,dp,q,dq,al,jflag) vx(ix)=vx(ix)+al(2)*fudge*dq(1) vy(ix)=vy(ix)+al(2)*fudge*dq(2) ix=next enddo endif endif enddo endif enddo enddo return end c***************************** file: mg3.f ***************************** c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine triplt(vx,vy,xm,ym,itnode,ibndry, + ip,rp,sp,w,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),jp(25), 1 kdist(22),ia(3) double precision + vx(*),vy(*),xm(*),ym(*),w(*),q(3,3),t(25),tl(25), 1 rp(100),red(256),green(256),blue(256) character*80 + sp(100) external qxy c c i jp(i) t(i) tl(i) c c 1 ntf xshift xshift c 2 nvf yshift yshift c 3 nbf scale scale c 4 icplt zratio zratio c 5 ncolor zshift zshift c 6 ierrsw c 7 iprob/ispd eps eps c 8 nrgn/iordsw xl xl from t c 9 inplsw xr xr from t c 10 igrsw yb yb from t c 11 lvl yt yt from t c 12 mpisw rmag 1.0e0 c 13 nx c 14 ny size size c 15 nz xcen xcen c 16 nshade ycen ycen c 17 mxcolr zcen zcen c 18 maplen c 19 iscale zmin zmin c 20 lines zmax zmax c 21 numbrs good good c 22 i3d fair fair c 23 nproc poor poor c 24 worst worst c 25 average average c c c storage allocation c if(ip(5).ne.0) then call stor(ip) endif c c error flags c ip(25)=0 if(itnode(3,1).eq.0) then iflag=25 go to 10 endif c c array pointers...in the order that they c occur in the w array c lenw=ip(20) iuu=ip(83) iux=ip(84) iuy=ip(85) iu0=ip(86) iudot=ip(87) iu0dot=ip(88) iudl=ip(89) ievr=ip(90) ievl=ip(91) jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) c ivx0=iudot ivy0=iu0dot c c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=iabs(ip(6)) mxcolr=max0(2,ip(51)) mxcolr=min0(256,mxcolr) icrsn=ip(68) itrgt=ip(69) mpisw=ip(48) nproc=ip(49) irgn=ip(50) c c temporary storage space c ibegin=iz iend=lenw c c initialize data structures c if(mpisw.eq.1) then if(icrsn.eq.1) then ia(1)=max0(4*itrgt,ntf) ia(2)=max0(2*itrgt,nbf) ia(3)=max0(2*itrgt,nvf) else ia(1)=ntf*nproc ia(2)=nbf*nproc ia(3)=nvf*nproc endif call exsze(ia,0) lent=ia(1) lenb=ia(2) lenv=ia(3) else lent=ntf lenb=nbf lenv=nvf endif call memptr(jtnode,5*lent,'head',ibegin,iend,iflag) call memptr(itedge,3*lent,'head',ibegin,iend,iflag) call memptr(iut,3*lent,'head',ibegin,iend,iflag) call memptr(ivt,3*lent,'head',ibegin,iend,iflag) call memptr(jbndry,6*lenb,'head',ibegin,iend,iflag) call memptr(ibedge,2*lenb,'head',ibegin,iend,iflag) call memptr(ivx0,lenv,'head',ibegin,iend,iflag) call memptr(ivy0,lenv,'head',ibegin,iend,iflag) c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(iua,nvf,'head',ibegin,iend,iflag) call memptr(iva,nvf,'head',ibegin,iend,iflag) if(icrsn.eq.1) then llen=nvf+3*nbf+6*ntf+1 else llen=3*ntf+nvf+nbf endif call memptr(jzz,llen,'head',ibegin,iend,iflag) if(iflag.ne.0) go to 10 c c comput function to be displayed c ifun=iabs(ip(52)) rl=rp(21) if(iprob.eq.6) rl=rp(46) c ivu=iuu iv1=iux iv2=iuy ierrsw=0 icont=0 itype=0 if(ifun.eq.1) then itype=9 else if(ifun.eq.2) then itype=8 else if(ifun.eq.3) then itype=3 if(ip(57).eq.1) icont=1 else if(ifun.eq.4) then itype=4 if(ip(57).eq.1) icont=1 else if(ifun.eq.5) then itype=5 if(ip(57).eq.1) icont=1 if(icont.eq.0.and.mpisw.ne.1.and.icrsn.ne.1) ierrsw=1 else if(ifun.eq.6) then ivu=iudot else if(ifun.eq.7) then ivu=ievr else if(ifun.eq.8) then ivu=ievl else if(ifun.eq.9) then ivu=iudot else if(ifun.eq.10) then ivu=iu0 else if(ifun.eq.11) then ivu=iudl else if(ifun.eq.12) then iv1=iu0 iv2=iuu rl=dmax1(rp(47),rp(48)) if(rl.gt.0.0d0) rl=1.0d0/rl itype=6 else if(ifun.eq.13) then iv1=ivx0 iv2=ivy0 rl=dmax1(rp(47),rp(48)) if(rl.gt.0.0d0) rl=1.0d0/rl itype=7 endif call setfun(ntf,nvf,itype,icont,icplt,w(ivu),w(iv1),w(iv2), + w(iee),vx,vy,w(iut),w(ivt),itnode,w(iua), 1 w(iva),w(jzz),rl,qxy) call plinit(ip,rp,w(jtnode),w(jbndry),w(itedge),w(ibedge), + w(ivx0),w(ivy0),w(iut),w(ivt),xm,ym,icplt,ierrsw,w(iee), 1 kdist,q,t,tl,jp,w(jzz),itnode,ibndry,vx,vy, 2 w(iua),w(iva)) call memptr(isv,0,'free',ibegin,iend,iflag) c c if(mpisw.eq.1) then ia(1)=jp(1) ia(2)=jp(2) ia(3)=jp(3) call exsze(ia,1) ntf=ia(1) nvf=ia(2) nbf=ia(3) iflag=0 if(ntf.gt.lent) iflag=20 if(nvf.gt.lenv) iflag=20 if(nbf.gt.lenb) iflag=20 if(iflag.ne.0) go to 10 llen=11*ntf+2*nvf+6*nbf+3 call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibuff,llen,'head',ibegin,iend,iflag) if(iflag.ne.0) go to 10 call glbpix(w(ivx0),w(ivy0),w(jbndry),w(jtnode), + ia,w(iut),w(ivt),jp,w(ibuff),1) if(irgn.eq.1) then call cedge1(nvf,ntf,nbf,w(jtnode),w(jbndry),w(itedge), + w(ibedge),w(ivx0),w(ivy0),w(ibuff),iflag) endif call memptr(isv,0,'free',ibegin,iend,iflag) if(irgn.ne.1) return endif c c ordering c call memptr(iord,ntf,'head',ibegin,iend,iflag) call memptr(isv,0,'mark',ibegin,iend,iflag) ll=max0(ntf,nbf) call memptr(nblock,ll,'head',ibegin,iend,iflag) icen=nblock llen=(iend-ibegin+1-(ntf+1))/3 call memptr(itlist,2*llen,'head',ibegin,iend,iflag) call memptr(list,llen+ntf+1,'head',ibegin,iend,iflag) if(iflag.ne.0) go to 10 c call torder(jp,w(jtnode),w(itedge),w(iord),w(nblock), + llen,w(list),w(itlist),w(ivx0),w(ivy0),w(icen),q,iflag) if(iflag.ne.0) go to 10 call memptr(isv,0,'free',ibegin,iend,iflag) c c colormap c call clrmap(red,green,blue,jp) call pltutl(jp(18),red,green,blue) c c main plot c call pframe(4) call title0(sp(1),0) call pframe(-4) call pframe(5) if(icplt.eq.1) then call cplot(jp,w(jtnode),w(jbndry),w(itedge),w(iord), + w(ivx0),w(ivy0),w(iut),xm,ym,q,t) else call vplot(jp,w(jtnode),w(jbndry),w(itedge),w(iord), + w(ivx0),w(ivy0),w(iut),w(ivt),xm,ym,q,t) endif c c numbers c if(jp(21).eq.1) call tlabel(jp,w(jtnode),w(ivx0),w(ivy0),q,t) if(jp(21).eq.2.or.jp(21).eq.8) then call memptr(irad,jp(2),'head',ibegin,iend,iflag) call memptr(ivtype,jp(2),'head',ibegin,iend,iflag) if(jp(21).eq.8) then angmin=1.0d-3 arcmax=0.26d0 call cvtype(jp(1),jp(3),jp(2),ip(7),w(jtnode), + w(jbndry),w(ivx0),w(ivy0),xm,ym,w(itedge), 1 w(ibedge),w(ivtype),w(irad),angmin,arcmax) endif call vlabel(jp,w(jtnode),w(ivx0),w(ivy0),w(irad), + w(ivtype),q,t) endif if(jp(21).ge.3.and.jp(21).le.6) then call blabel(jp,w(jtnode),w(jbndry), + w(ibedge),w(ivx0),w(ivy0),xm,ym,q,t) endif if(jp(21).eq.7) then call memptr(ixc,nproc,'head',ibegin,iend,iflag) call memptr(iyc,nproc,'head',ibegin,iend,iflag) call memptr(irad,nproc,'head',ibegin,iend,iflag) call dlabel(jp,w(jtnode),w(ixc),w(iyc),w(irad), + w(ivx0),w(ivy0),q,t) endif call pframe(-5) c c legend c call pframe(2) if(icplt.eq.1) then call legnd4(jp,tl,kdist) else call legnd3(jp,tl) endif call pframe(-2) c c small plot c call pframe(3) jp(20)=1 if(t(12).le.1.0d0) jp(22)=0 if(icplt.eq.1) then jp(16)=0 call cplot(jp,w(jtnode),w(jbndry),w(itedge),w(iord), + w(ivx0),w(ivy0),w(iut),xm,ym,q,tl) else call vplot(jp,w(jtnode),w(jbndry),w(itedge),w(iord), + w(ivx0),w(ivy0),w(iut),w(ivt),xm,ym,q,tl) endif call legnd0(t) call pframe(-3) c call pltutl(-1,red,green,blue) iflag=0 10 if(iflag.eq.0) then sp(11)='triplt: ok' else if(iflag.eq.25) then sp(11)='triplt: wrong data structure' else sp(11)='triplt: insufficient storage' iflag=20 endif ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine inplt(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),jp(25),kdist(22),ia(3) double precision + vx(*),vy(*),xm(*),ym(*),w(*),t(25),tl(25),q(3,3), 1 rp(100),red(256),green(256),blue(256) character*80 + sp(100) c c draw input data c ntf=ip(1) nvf=ip(2) nbf=ip(4) lenw=ip(20) inplsw=ip(53) icrsn=ip(68) itrgt=ip(69) mpisw=ip(48) nproc=ip(49) irgn=ip(50) c ibegin=max0(ip(99),ip(22),0)+1 iend=lenw ip(25)=0 c c initialize c if(itnode(3,1).eq.0) then if(mpisw.eq.1.and.irgn.ne.1) return if(inplsw.eq.1) then iclrsw=1 else if(inplsw.eq.2) then iclrsw=2 else iclrsw=0 endif c ncc=0 do i=1,nbf if(ibndry(3,i).gt.0) ncc=ncc+3 enddo nvv=nvf+ncc ntt=2*nvv call memptr(iclr,ntt,'head',ibegin,iend,iflag) jclr=iclr call memptr(jtnode,5*ntt,'head',ibegin,iend,iflag) call memptr(itedge,3*ntt,'head',ibegin,iend,iflag) call memptr(ibedge,3*nbf,'head',ibegin,iend,iflag) call memptr(jbb,2*nbf+ntf+1,'head',ibegin,iend,iflag) call memptr(jtt,ntf+1,'head',ibegin,iend,iflag) call memptr(isv,0,'mark',ibegin,iend,iflag) llist=nvv+nbf+3*ntt+1 call memptr(list,llist,'head',ibegin,iend,iflag) call memptr(indx,nvv,'head',ibegin,iend,iflag) call memptr(ivx0,nvf,'head',ibegin,iend,iflag) call memptr(ivy0,nvf,'head',ibegin,iend,iflag) if(iflag.ne.0) then iflag=20 go to 10 endif call mktris(ip,vx,vy,ibndry,itnode,xm,ym,w(jbb),w(jtt), + w(jtnode),w(itedge),w(indx),w(list),llist,ntt,iclrsw, 1 w(ivx0),w(ivy0)) iflag=ip(25) if(iflag.ne.0) go to 10 call cedge3(nvf,ntt,nbf,w(jtnode),ibndry,w(ibedge), + w(list),iflag) if(iflag.ne.0) go to 10 call binits(ip,rp,vx,vy,xm,ym,w(jtnode),ibndry,t,tl,q,jp, + w(iclr),ntt) call memptr(isv,0,'free',ibegin,iend,iflag) else if(mpisw.eq.1) then if(icrsn.eq.1) then ia(1)=max0(4*itrgt,ntf) ia(2)=max0(2*itrgt,nbf) ia(3)=max0(2*itrgt,nvf) else ia(1)=ntf*nproc ia(2)=nbf*nproc ia(3)=nvf*nproc endif call exsze(ia,0) lent=ia(1) lenb=ia(2) lenv=ia(3) else lent=ntf lenb=nbf lenv=nvf endif call memptr(jtnode,5*lent,'head',ibegin,iend,iflag) call memptr(itedge,3*lent,'head',ibegin,iend,iflag) call memptr(iclr,lent,'head',ibegin,iend,iflag) call memptr(jbndry,6*lenb,'head',ibegin,iend,iflag) call memptr(ibedge,2*lenb,'head',ibegin,iend,iflag) call memptr(ivx0,lenv,'head',ibegin,iend,iflag) call memptr(ivy0,lenv,'head',ibegin,iend,iflag) if(ip(5).eq.0) then jstat=ip(96) iee=ip(97) else call memptr(iee,lent,'head',ibegin,iend,iflag) call memptr(jstat,10*nproc,'head',ibegin,iend,iflag) endif call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(jclr,lent,'head',ibegin,iend,iflag) llist=nvf+nbf+3*ntf call memptr(list,llist,'head',ibegin,iend,iflag) if(iflag.ne.0) then iflag=20 go to 10 endif call binitt(ip,rp,w(jtnode),w(itedge),w(jbndry),w(ibedge), + w(ivx0),w(ivy0),xm,ym,itnode,ibndry,vx,vy,w(iee), 1 w(jclr),w(iclr),w(jstat),kdist,w(list),t,tl,q,jp) call memptr(isv,0,'free',ibegin,iend,iflag) endif c if(mpisw.eq.1.and.itnode(3,1).ne.0) then ia(1)=jp(1) ia(2)=jp(2) ia(3)=jp(3) call exsze(ia,1) ntf=ia(1) nvf=ia(2) nbf=ia(3) iflag=0 if(ntf.gt.lent) iflag=20 if(nvf.gt.lenv) iflag=20 if(nbf.gt.lenb) iflag=20 if(iflag.ne.0) go to 10 llen=6*ntf+2*nvf+6*nbf+3 call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibuff,llen,'head',ibegin,iend,iflag) if(iflag.ne.0) then iflag=20 go to 10 endif call glbpix(w(ivx0),w(ivy0),w(jbndry),w(jtnode), + w(iclr),xm,ym,jp,w(ibuff),0) if(irgn.eq.1) then call cedge1(nvf,ntf,nbf,w(jtnode),w(jbndry),w(itedge), + w(ibedge),w(ivx0),w(ivy0),w(ibuff),iflag) endif call memptr(isv,0,'free',ibegin,iend,iflag) if(irgn.ne.1) return endif c call clrmap(red,green,blue,jp) call pltutl(jp(18),red,green,blue) c c main plot c call pframe(4) call title0(sp(2),0) call pframe(-4) call pframe(5) if(itnode(3,1).eq.0) then call tplot(vx,vy,ibndry,w(jtnode),xm,ym,t,jp, + w(itedge),w(iclr)) if(jp(21).eq.1) call rlabel(jp,w(jtnode),w(jtt),vx,vy,q,t) if(jp(21).eq.2) Then call memptr(irad,jp(2),'head',ibegin,iend,iflag) call memptr(ivtype,jp(2),'head',ibegin,iend,iflag) call vlabel(jp,w(jtnode),w(ivx0),w(ivy0),w(irad), + w(ivtype),q,t) endif if(jp(21).ge.3) call blabel(jp,w(jtnode),ibndry, + w(ibedge),vx,vy,xm,ym,q,t) else call tplot(w(ivx0),w(ivy0),w(jbndry),w(jtnode),xm,ym, + t,jp,w(itedge),w(iclr)) if(jp(21).eq.1) call tlabel(jp,w(jtnode), + w(ivx0),w(ivy0),q,t) if(jp(21).eq.2.or.jp(21).eq.8) then call memptr(irad,jp(2),'head',ibegin,iend,iflag) call memptr(ivtype,jp(2),'head',ibegin,iend,iflag) if(jp(21).eq.8) then angmin=1.0d-3 arcmax=0.26d0 call cvtype(jp(1),jp(3),jp(2),ip(7),w(jtnode), + w(jbndry),w(ivx0),w(ivy0),xm,ym,w(itedge), 1 w(ibedge),w(ivtype),w(irad),angmin,arcmax) endif call vlabel(jp,w(jtnode),w(ivx0),w(ivy0),w(irad), + w(ivtype),q,t) endif if(jp(21).ge.3.and.jp(21).le.6) then call blabel(jp,w(jtnode),w(jbndry), + w(ibedge),w(ivx0),w(ivy0),xm,ym,q,t) endif if(jp(21).eq.7) then call memptr(ixc,nproc,'head',ibegin,iend,iflag) call memptr(iyc,nproc,'head',ibegin,iend,iflag) call memptr(irad,nproc,'head',ibegin,iend,iflag) call dlabel(jp,w(jtnode),w(ixc),w(iyc),w(irad), + w(ivx0),w(ivy0),q,t) endif endif call pframe(-5) c c legend c call pframe(2) if(jp(9).le.0) then call legnd1(jp) else if(jp(9).eq.1) then if(jp(23).gt.1) then call legnd7(jp,w(jstat)) else call legnd1(jp) endif else if(jp(9).eq.5.or.jp(9).eq.6) then call legnd4(jp,tl,kdist) else call legnd2(jp,tl) endif call pframe(-2) c c small plot c call pframe(3) jp(20)=1 if(itnode(3,1).eq.0) then call tplot(vx,vy,ibndry,w(jtnode),xm,ym,tl,jp, + w(itedge),w(iclr)) else call tplot(w(ivx0),w(ivy0),w(jbndry),w(jtnode),xm,ym, + tl,jp,w(itedge),w(iclr)) endif call legnd0(t) call pframe(-3) c call pltutl(-1,red,green,blue) iflag=0 10 if(iflag.eq.0) then sp(11)='inplt: ok' else if(iflag.eq.20) then sp(11)='inplt: insufficient storage' else sp(11)='inplt: input data error' endif ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine setfun(ntf,nvf,itype,icont,icplt,u,v1,v2,e, + vx,vy,ut,vt,itnode,ua,va,z,rl,qxy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),u(*),v1(*),v2(*),e(*),ut(3,*),vt(3,*), 1 z(*),ua(*),va(*),qv(6),qu(6) external qxy c c scalar function defined at vertices c do i=1,ntf do j=1,3 ut(j,i)=0.0d0 vt(j,i)=0.0d0 enddo enddo if(itype.le.0.or.itype.gt.9) then icplt=1 do i=1,ntf do j=1,3 ut(j,i)=u(itnode(j,i)) enddo enddo c c scalar function defined at vertices, plot | grad u | c else if(itype.eq.1) then icplt=1 do i=1,ntf call grad(ux,uy,vx,vy,u,itnode(1,i),0) xx=(vx(itnode(1,i))+vx(itnode(2,i)) + +vx(itnode(3,i)))/3.0d0 yy=(vy(itnode(1,i))+vy(itnode(2,i)) + +vy(itnode(3,i)))/3.0d0 ss=dsqrt(ux**2+uy**2) do j=1,3 ivj=itnode(j,i) ut(j,i)=-uy*(vx(ivj)-xx)+ux*(vy(ivj)-yy)+ss enddo enddo c c scalar function defined at vertices, plot grad u c else if(itype.eq.2) then icplt=0 do i=1,ntf call grad(ux,uy,vx,vy,u,itnode(1,i),0) do j=1,3 ut(j,i)=ux vt(j,i)=uy enddo enddo c c scalar user function qxy c else if(itype.eq.3) then icplt=1 do i=1,ntf call eleufn(i,itnode,vx,vy,u,v1,v2,rl,qu,1,0,qxy) do j=1,3 ut(j,i)=qu(j) enddo enddo c c vector user function qxy c else if(itype.eq.4) then icplt=0 do i=1,ntf call eleufn(i,itnode,vx,vy,u,v1,v2,rl,qu,2,0,qxy) call eleufn(i,itnode,vx,vy,u,v1,v2,rl,qv,3,0,qxy) do j=1,3 ut(j,i)=qu(j) vt(j,i)=qv(j) enddo enddo c c scalar function defined on elements c else if(itype.eq.5) then icplt=1 do i=1,ntf do j=1,3 ut(j,i)=e(i) enddo enddo c c scalar function (time) derivative c else if(itype.eq.6) then icplt=1 do i=1,ntf do j=1,3 ivj=itnode(j,i) ut(j,i)=(v2(ivj)-v1(ivj))*rl enddo enddo c c vector function (x-dot,ydot) c else if(itype.eq.7) then icplt=0 do i=1,ntf do j=1,3 ivj=itnode(j,i) ut(j,i)=(vx(ivj)-v1(ivj))*rl vt(j,i)=(vy(ivj)-v2(ivj))*rl enddo enddo c c vector function c else if(itype.eq.8) then icplt=0 do i=1,ntf do j=1,3 ivj=itnode(j,i) ut(j,i)=v1(ivj) vt(j,i)=v2(ivj) enddo enddo c c absolute value of vector function c else if(itype.eq.9) then icplt=1 do i=1,ntf do j=1,3 ivj=itnode(j,i) ut(j,i)=dsqrt(v1(ivj)**2+v2(ivj)**2) enddo enddo endif c c average discontinuous function c if(icont.eq.0) return if(icplt.eq.1) then do i=1,nvf ua(i)=0.0d0 z(i)=0.0d0 enddo do i=1,ntf area=dabs((vx(itnode(2,i))-vx(itnode(1,i)))* + (vy(itnode(3,i))-vy(itnode(1,i)))- 1 (vx(itnode(3,i))-vx(itnode(1,i)))* 2 (vy(itnode(2,i))-vy(itnode(1,i)))) do j=1,3 ivj=itnode(j,i) z(ivj)=z(ivj)+area ua(ivj)=ua(ivj)+area*ut(j,i) enddo enddo do i=1,nvf ua(i)=ua(i)/z(i) enddo do i=1,ntf do j=1,3 ivj=itnode(j,i) ut(j,i)=ua(ivj) enddo enddo else do i=1,nvf ua(i)=0.0d0 va(i)=0.0d0 z(i)=0.0d0 enddo do i=1,ntf area=dabs((vx(itnode(2,i))-vx(itnode(1,i)))* + (vy(itnode(3,i))-vy(itnode(1,i)))- 1 (vx(itnode(3,i))-vx(itnode(1,i)))* 2 (vy(itnode(2,i))-vy(itnode(1,i)))) do j=1,3 ivj=itnode(j,i) z(ivj)=z(ivj)+area ua(ivj)=ua(ivj)+area*ut(j,i) va(ivj)=va(ivj)+area*vt(j,i) enddo enddo do i=1,nvf ua(i)=ua(i)/z(i) va(i)=va(i)/z(i) enddo do i=1,ntf do j=1,3 ivj=itnode(j,i) ut(j,i)=ua(ivj) vt(j,i)=va(ivj) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function fqual(i,vx,vy,ua,va,icplt,vtype, + vlist,len,qmax) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vtype(*),vlist(500),corner(9) double precision + vx(*),vy(*),ua(*),va(*) save corner data corner/0,0,1,0,1,0,1,0,1/ c c c fqual=-qmax if(corner(vtype(i)).eq.1) return if(len.gt.10) return a11=0.0d0 a12=0.0d0 a22=0.0d0 b1=0.0d0 b2=0.0d0 do kk=2,len+1 k=vlist(kk) x=vx(k)-vx(i) y=vy(k)-vy(i) z=ua(k)-ua(i) a11=a11+x**2 a12=a12+x*y a22=a22+y**2 b1=b1+x*z b2=b2+y*z enddo det=a11*a22-a12**2 c1=(b1*a22-b2*a12)/det c2=(a11*b2-a12*b1)/det sum=0.0d0 do kk=2,len+1 k=vlist(kk) x=vx(k)-vx(i) y=vy(k)-vy(i) z=ua(k)-ua(i) sum=sum+(z-c1*x-c2*y)**2 enddo fqual=-sum if(icplt.eq.1) return b1=0.0d0 b2=0.0d0 do kk=2,len+1 k=vlist(kk) x=vx(k)-vx(i) y=vy(k)-vy(i) z=va(k)-va(i) b1=b1+x*z b2=b2+y*z enddo c1=(b1*a22-b2*a12)/det c2=(a11*b2-a12*b1)/det sum=0.0d0 do kk=2,len+1 k=vlist(kk) x=vx(k)-vx(i) y=vy(k)-vy(i) z=va(k)-va(i) sum=sum+(z-c1*x-c2*y)**2 enddo fqual=fqual-sum return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine crsn1(ntf,nvf,nbf,nvtrgt,icplt,itnode,ibndry,vx,vy, + xm,ym,ut,vt,vz,va,itedge,ibedge,vtype,p,q,qual,iseed,ibase) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),ibedge(2,*), 1 vtype(*),iseed(*),p(*),q(*),corner(9), 2 elist(500),tlist(500),vlist(500),blist(500),vsv(500) double precision + vz(*),xm(*),ym(*),vx(*),vy(*),bump(3),e(3),qual(*), 1 ut(3,*),vt(3,*),va(*) save corner data corner/0,0,1,0,1,0,1,0,1/ c c check to see if we have solved problem on current finest grid c idbcpt=0 lenb=3 hmin=0.0d0 coeff=0.0d0 angmin=1.0d-3 arcmax=0.26d0 c c initailize iseed, vtype c call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c qmax=0.0d0 do i=1,nvf call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) qq=fqual(i,vx,vy,vz,va,icplt,vtype,vlist,len,qmax) qmax=dmax1(qmax,dabs(qq)) enddo qmax=100.0d0*qmax do i=1,nvf p(i)=i q(i)=i call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) qual(i)=fqual(i,vx,vy,vz,va,icplt,vtype,vlist,len,qmax) enddo c c initialize heap c nn=nvf/2 do k=nn,1,-1 call updhp(k,nvf,p,q,qual,0) enddo last=nvf c c main elimination loop c call cedge5(nbf,itedge,ibedge,1) do nn=nvf,1,-1 if(last.le.nvtrgt) go to 60 i=p(1) if(qual(i).le.-qmax) go to 60 p(1)=p(last) p(last)=i q(p(last))=last q(p(1))=1 last=last-1 call updhp(1,last,p,q,qual,0) c c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) lvsv=0 do j=2,len+1 if(corner(vtype(vlist(j))).ne.1) then lvsv=lvsv+1 vsv(lvsv)=vlist(j) endif enddo c c reduce to degree 3 or 4 by edge swapping c call reduc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,hmin,coeff,0,iflag) c c if(corner(vtype(i)).eq.1) stop 6235 if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist,len, 1 hmin,coeff,ibase,0) else last=last+1 qual(i)=-qmax endif c c update vertices in connected to i c do jj=1,lvsv j=vsv(jj) qual(j)=-qmax call cirlst(j,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) if(vtype(j).ne.1) then call tstvty(j,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) endif qual(j)=fqual(j,vx,vy,vz,va,icplt,vtype,vlist,len,qmax) kk=q(j) call updhp(kk,last,p,q,qual,1) enddo enddo 60 call clnup1(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge,vx,vy, + vz,va,icplt,iseed) c c improve geometry c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,vtype,jflag) call cedge5(nbf,itedge,ibedge,1) call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,0) call cedge5(nbf,itedge,ibedge,0) c do i=1,ntf do j=1,3 ut(j,i)=vz(itnode(j,i)) enddo enddo if(icplt.ne.1) then do i=1,ntf do j=1,3 vt(j,i)=va(itnode(j,i)) enddo enddo endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clnup1(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,vz,va,icplt,mark) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ibedge(2,*),mark(*) double precision + vx(*),vy(*),vz(*),va(*) c c clean up data structure after vertex elimination c c fixup itnode, itedge, bump c ntnew=0 do i=1,ntf if(itnode(1,i).ne.0) then ntnew=ntnew+1 mark(i)=ntnew do j=1,5 itnode(j,ntnew)=itnode(j,i) enddo do j=1,3 itedge(j,ntnew)=itedge(j,i) enddo else mark(i)=0 endif enddo do i=1,nbf ibedge(1,i)=0 ibedge(2,i)=0 enddo do i=1,ntnew do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 ke=itedge(j,i)-4*k itedge(j,i)=4*mark(k)+ke else m=-itedge(j,i) if(ibedge(1,m).gt.0) then ibedge(2,m)=4*i+j else ibedge(1,m)=4*i+j endif endif enddo enddo ntf=ntnew c c fixup ibndry...note internal interface edges are put in itedge c nbnew=0 do i=1,nbf if(ibndry(1,i).ne.0) then nbnew=nbnew+1 mark(i)=nbnew do j=1,6 ibndry(j,nbnew)=ibndry(j,i) enddo ibedge(1,nbnew)=ibedge(1,i) ibedge(2,nbnew)=ibedge(2,i) k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew).gt.0) then k=ibedge(2,nbnew)/4 ke=ibedge(2,nbnew)-4*k itedge(ke,k)=-nbnew endif else mark(i)=0 endif enddo nbf=nbnew c c periodic edges c do i=1,nbf if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,i)=-mark(k) endif enddo c c now fix vertex arrays c do i=1,nvf mark(i)=0 enddo do i=1,ntf do j=1,3 mark(itnode(j,i))=1 enddo enddo nvnew=0 do i=1,nvf if(mark(i).ne.0) then nvnew=nvnew+1 mark(i)=nvnew vx(nvnew)=vx(i) vy(nvnew)=vy(i) vz(nvnew)=vz(i) if(icplt.ne.1) va(nvnew)=va(i) endif enddo nvf=nvnew do i=1,ntf do j=1,3 itnode(j,i)=mark(itnode(j,i)) enddo enddo do i=1,nbf do j=1,2 ibndry(j,i)=mark(ibndry(j,i)) enddo enddo c c orient triangles c do i=1,ntf r=geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) if(r.lt.0.0d0) then itemp=itnode(2,i) itnode(2,i)=itnode(3,i) itnode(3,i)=itemp endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cvz(ntf,nvf,icplt,vx,vy,ut,vt,itnode,vz,va,z) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) double precision + vx(*),vy(*),ut(3,*),vt(3,*),z(*),vz(*),va(*) c if(icplt.eq.1) then do i=1,nvf vz(i)=0.0d0 z(i)=0.0d0 enddo do i=1,ntf area=dabs((vx(itnode(2,i))-vx(itnode(1,i)))* + (vy(itnode(3,i))-vy(itnode(1,i)))- 1 (vx(itnode(3,i))-vx(itnode(1,i)))* 2 (vy(itnode(2,i))-vy(itnode(1,i)))) do j=1,3 ivj=itnode(j,i) z(ivj)=z(ivj)+area vz(ivj)=vz(ivj)+area*ut(j,i) enddo enddo do i=1,nvf vz(i)=vz(i)/z(i) enddo else do i=1,nvf vz(i)=0.0d0 va(i)=0.0d0 z(i)=0.0d0 enddo do i=1,ntf area=dabs((vx(itnode(2,i))-vx(itnode(1,i)))* + (vy(itnode(3,i))-vy(itnode(1,i)))- 1 (vx(itnode(3,i))-vx(itnode(1,i)))* 2 (vy(itnode(2,i))-vy(itnode(1,i)))) do j=1,3 ivj=itnode(j,i) z(ivj)=z(ivj)+area vz(ivj)=vz(ivj)+area*ut(j,i) va(ivj)=va(ivj)+area*vt(j,i) enddo enddo do i=1,nvf vz(i)=vz(i)/z(i) va(i)=va(i)/z(i) enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cplot(jp,itnode,ibndry,itedge,order, + vx,vy,ut,xm,ym,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),jp(25),ibndry(6,*), 1 ibdy(192),order(*),ccolor,index(3,3) double precision + vx(*),vy(*),ut(3,*),q(3,3),t(25),xm(*),ym(*),x(9), 1 y(9),z(9),f(9),bx(3),by(3),bz(3),bf(3),c(3,192), 2 x0(9),y0(9),z0(9),f0(9) save index data index/1,2,3,2,3,1,3,1,2/ c c color surface plot c initialize c ntf=jp(1) ncolor=jp(5) nshade=jp(16) ishade=0 iscale=jp(19) lines=jp(20) i3d=jp(22) c pi=3.141592653589793d0 xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) if(i3d.eq.0) then zratio=0.0d0 else zratio=t(4) endif eps=t(7) smin=t(19) smax=t(20) zmin=fscale(smin,iscale,0) zmax=fscale(smax,iscale,0) smin=smin-dabs(smin)*eps smax=smax+dabs(smax)*eps if(zmax.gt.zmin) then zscale=(1.0d0-eps)*dfloat(ncolor)/(zmax-zmin) else zscale=0.0d0 endif c c shading (reset (dxx,dyy,dzz) for a different light source) c if(nshade.gt.0) then dxx=q(1,3) dyy=q(2,3) dzz=q(3,3) dd=dsqrt(dxx*dxx+dyy*dyy+dzz*dzz) dxx=dxx/dd dyy=dyy/dd dzz=dzz/dd endif c c c the main loop c do ii=1,ntf it=order(ii) iv1=itnode(1,it) iv2=itnode(2,it) iv3=itnode(3,it) c c compute the shade c if(nshade.gt.0) then x2=vx(iv2)-vx(iv1) y2=vy(iv2)-vy(iv1) z2=(ut(2,it)-ut(1,it))*zratio x3=vx(iv3)-vx(iv1) y3=vy(iv3)-vy(iv1) z3=(ut(3,it)-ut(1,it))*zratio xx=y2*z3-y3*z2 yy=z2*x3-z3*x2 zz=x2*y3-x3*y2 qq=dsqrt(xx*xx+yy*yy+zz*zz) aa=(dxx*xx+dyy*yy+dzz*zz)/qq aq=(q(1,3)*xx+q(2,3)*yy+q(3,3)*zz)/qq if(aa*aq.lt.0.0d0) then ishade=-nshade else aa=dmin1(1.0d0,dabs(aa)) aa=(1.0d0-4.0d0*dacos(aa)/pi)*dfloat(nshade+1) ishade=min0(idint(dabs(aa)),nshade) if(aa.lt.0.0d0) ishade=-ishade endif endif c c compute triangle boundary c call tbdy(c,ibdy,ntri,it,itnode,ibndry,itedge, + vx,vy,xm,ym,q,i3d) c c set up coordinates, scale bv to lie on (0,ncolor) c do itri=1,3*ntri,3 do mm=1,3 m=mm+itri-1 xx=c(1,m)*vx(iv1)+c(2,m)*vx(iv2)+c(3,m)*vx(iv3) yy=c(1,m)*vy(iv1)+c(2,m)*vy(iv2)+c(3,m)*vy(iv3) zz=c(1,m)*ut(1,it)+c(2,m)*ut(2,it)+c(3,m)*ut(3,it) if(zz.ge.smin.and.zz.le.smax) then bf(mm)=(fscale(zz,iscale,0)-zmin)*zscale else if(zz.lt.smin) then bf(mm)=-1.0d0 else bf(mm)=dfloat(ncolor+1) endif xxm=q(1,1)*xx+q(2,1)*yy yym=q(1,2)*xx+q(2,2)*yy+q(3,2)*zz*zratio zzm=q(1,3)*xx+q(2,3)*yy+q(3,3)*zz*zratio bx(mm)=xxm*scale+xshift by(mm)=yym*scale+yshift bz(mm)=zzm*scale+zshift enddo c c order function values c kmin=1 if(bf(kmin).gt.bf(2)) kmin=2 if(bf(kmin).gt.bf(3)) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(bf(kmid).gt.bf(kmax)) kmid=kmax kmax=6-kmin-kmid c c find min and max color values for this triangle c minc=idint(bf(kmin))+1 maxc=idint(bf(kmax))+1 if(bf(kmax).eq.dfloat(maxc-1)) maxc=max0(maxc-1,minc) c do mm=minc,maxc do m=1,3 x(m)=bx(m) y(m)=by(m) z(m)=bz(m) f(m)=bf(m) enddo len=3 cc=-1.0d0 do j=mm-1,mm cc=-cc len0=len len=0 do m=1,len0 x0(m)=x(m) y0(m)=y(m) z0(m)=z(m) f0(m)=f(m) enddo do m=1,len0 sm=(f0(m)-dfloat(j))*cc if(sm.ge.0.0d0) then len=len+1 x(len)=x0(m) y(len)=y0(m) z(len)=z0(m) f(len)=f0(m) else k=m-1 if(m.eq.1) k=len0 kaft=m+1 if(m.eq.len0) kaft=1 do kba=1,2 sk=(f0(k)-dfloat(j))*cc if(sk.gt.0.0d0) then len=len+1 s=sk/(sk-sm) x(len)=x0(m)*s+x0(k)*(1.0d0-s) y(len)=y0(m)*s+y0(k)*(1.0d0-s) z(len)=z0(m)*s+z0(k)*(1.0d0-s) f(len)=f0(m)*s+f0(k)*(1.0d0-s) endif k=kaft enddo endif enddo enddo if(len.gt.2) then mc=ccolor(mm,ishade,jp) call pwindw(x,y,z,len,t,mc) endif enddo c c contour lines c if(lines.ne.3) go to 10 if(bf(kmin).ge.bf(kmax)) go to 10 minc=idint(bf(kmin))+1 if(bf(kmin).gt.dfloat(minc-1)) minc=minc+1 maxc=min0(ncolor,idint(bf(kmax)))+1 c c move boundary edges slightly into the interior... c do m=minc,maxc s=(bf(kmax)-dfloat(m-1))/(bf(kmax)-bf(kmin)) s=dmax1(0.02d0,s) s=dmin1(0.98d0,s) x(1)=bx(kmin)*s+bx(kmax)*(1.0d0-s) y(1)=by(kmin)*s+by(kmax)*(1.0d0-s) z(1)=bz(kmin)*s+bz(kmax)*(1.0d0-s) if(bf(kmid).gt.dmax1(bf(kmin),dfloat(m-1)))then s=(bf(kmid)-dfloat(m-1))/(bf(kmid)-bf(kmin)) s=dmax1(0.02d0,s) s=dmin1(0.98d0,s) x(2)=bx(kmin)*s+bx(kmid)*(1.0d0-s) y(2)=by(kmin)*s+by(kmid)*(1.0d0-s) z(2)=bz(kmin)*s+bz(kmid)*(1.0d0-s) else if(bf(kmid).lt.bf(kmax)) then s=(bf(kmax)-dfloat(m-1))/(bf(kmax)-bf(kmid)) s=dmax1(0.02d0,s) s=dmin1(0.98d0,s) x(2)=bx(kmid)*s+bx(kmax)*(1.0d0-s) y(2)=by(kmid)*s+by(kmax)*(1.0d0-s) z(2)=bz(kmid)*s+bz(kmax)*(1.0d0-s) else x(2)=bx(kmid) y(2)=by(kmid) z(2)=bz(kmid) endif call lwindw(x,y,z,2,t,2) enddo c c line drawing c 10 do m=1,3 k=ibdy(itri+m-1) isw=0 if(lines.eq.-1) then isw=1 else if(lines.eq.0.and.k.ge.0) then isw=1 else if(k.eq.1) then isw=1 else if(k.gt.1) then if(lines.eq.1) then if(k.eq.2.or.k.eq.5) isw=1 else if(lines.eq.2) then if(k.eq.3.or.k.eq.5) isw=1 endif endif if(isw.eq.1) then x(1)=bx(index(2,m)) y(1)=by(index(2,m)) z(1)=bz(index(2,m)) x(2)=bx(index(3,m)) y(2)=by(index(3,m)) z(2)=bz(index(3,m)) call lwindw(x,y,z,2,t,2) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine vplot(jp,itnode,ibndry,itedge,order, + vx,vy,ut,vt,xm,ym,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),itedge(3,*), 1 ccolor,ibdy(192),ibndry(6,*),order(*),index(3,3) double precision + vx(*),vy(*),ut(3,*),vt(3,*),xm(*),ym(*),q(3,3), 1 x(10),y(10),t(25),c(3,192),z1(3),z2(3),vm(3),rl(3), 2 bu(8),bv(8),b(3,8),bx(8),by(8),bz(8),z(10) save index data index/1,2,3,2,3,1,3,1,2/ c c vector plots c i3d=jp(22) xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) rmin=t(19) rmax=t(20) eps=t(7) if(i3d.eq.0) then zratio=0.0d0 else zratio=t(4) endif c ntf=jp(1) ncolor=jp(5) nshade=jp(16) iscale=jp(19) lines=jp(20) zmin=fscale(rmin,iscale,0) zmax=fscale(rmax,iscale,0) c pi=3.141592653589793d0 pi2=2.0d0*pi if(nshade.gt.0.and.zmin.ne.zmax) then zscale=(1.0d0-eps)*dfloat(2*nshade+1)/(zmax-zmin) else zscale=0.0d0 endif zs=(zmax-zmin)/dfloat(2*nshade+1) if(ncolor.gt.0) then nr=max0(64/ncolor,1) nnr=ncolor*nr dtheta=pi2/dfloat(nnr) else dtheta=2.0d0*pi2 nr=1 nnr=1 endif c c color triangles c do ij=1,ntf i=order(ij) c c lay out polygon c call tbdy(c,ibdy,ntri,i,itnode,ibndry,itedge, + vx,vy,xm,ym,q,i3d) call trnk(irank,i,ut,vt,rmax,eps) iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) do k=1,3 vm(k)=dsqrt(ut(k,i)**2+vt(k,i)**2)*zratio enddo c c do itri=1,3*ntri,3 do mm=1,3 m=mm+itri-1 x(mm)=c(1,m)*vx(iv1)+c(2,m)*vx(iv2)+c(3,m)*vx(iv3) y(mm)=c(1,m)*vy(iv1)+c(2,m)*vy(iv2)+c(3,m)*vy(iv3) c c rl is used in 3-d pictures. the linear interpolant of the c magnitude is the vector function plotted as the z coordinate. c this means that all triangles are flat. c c irank=1 is a special case because of roundoff problems in gbx c if(irank.eq.1) then rl(mm)=vm(1) z1(mm)=ut(1,i) z2(mm)=vt(1,i) else rl(mm)=c(1,m)*vm(1)+c(2,m)*vm(2)+c(3,m)*vm(3) z1(mm)=c(1,m)*ut(1,i)+c(2,m)*ut(2,i) + +c(3,m)*ut(3,i) z2(mm)=c(1,m)*vt(1,i)+c(2,m)*vt(2,i) + +c(3,m)*vt(3,i) endif enddo c call gbx(z1,z2,gmin,gmax,tmin,tmax,eps) irmin=idint((fscale(gmin,iscale,0)-zmin)*zscale)+1 irmax=idint((fscale(gmax,iscale,0)-zmin)*zscale)+1 itmin=idint(tmin/dtheta)+1 itmax=idint(tmax/dtheta)+1 if(irank.eq.1.or.irmax-irmin+itmax-itmin.eq.0) then jrank=1 else jrank=0 irmin=max0(1,irmin) irmax=min0(2*nshade+1,irmax) if(irmin.gt.irmax) go to 20 itmin=max0(1,itmin-1) itmax=itmax+1 endif c do ir=irmin,irmax do 10 it=itmin,itmax c c compute color index c icolor=it-1 if(icolor.ge.nnr) icolor=icolor-nnr icolor=(icolor/nr)+1 ishade=ir-nshade-1 ii=ccolor(icolor,ishade,jp) c c rank 1 case c if(jrank.eq.1) then do j=1,3 msides=3 do k=1,3 b(k,j)=0.0d0 enddo b(j,j)=1.0d0 enddo else c c set up box c t1=dfloat(it-1)*dtheta t2=dfloat(it)*dtheta c1=dcos(t1) c2=dcos(t2) s1=dsin(t1) s2=dsin(t2) rr1=zmin+dfloat(ir-1)*zs r1=dmax1(fscale(rr1,iscale,1),gmin*0.99d0) rr2=zmin+dfloat(ir)*zs r2=dmin1(fscale(rr2,iscale,1),gmax*1.05d0) bu(1)=r1*c1 bv(1)=r1*s1 bu(2)=r2*c1 bv(2)=r2*s1 bu(3)=r2*c2 bv(3)=r2*s2 bu(4)=r1*c2 bv(4)=r1*s2 c if(irank.eq.3) then call tribx3(b,msides,bu,bv,z1,z2) else call tribx2(b,msides,bu,bv,z1,z2) endif endif if(msides.le.2) go to 10 do j=1,msides xx=b(1,j)*x(1)+b(2,j)*x(2) + +b(3,j)*x(3) yy=b(1,j)*y(1)+b(2,j)*y(2) + +b(3,j)*y(3) zz=b(1,j)*rl(1)+b(2,j)*rl(2) + +b(3,j)*rl(3) c* zu=b(1,j)*z1(1)+b(2,j)*z1(2) c* + +b(3,j)*z1(3) c* zv=b(1,j)*z2(1)+b(2,j)*z2(2) c* + +b(3,j)*z2(3) c* zz=sqrt(zu**2+zv**2)*zratio xr=q(1,1)*xx+q(2,1)*yy yr=q(1,2)*xx+q(2,2)*yy+q(3,2)*zz zr=q(1,3)*xx+q(2,3)*yy+q(3,3)*zz bx(j)=xr*scale+xshift by(j)=yr*scale+yshift bz(j)=zr*scale+zshift enddo call pwindw(bx,by,bz,msides,t,ii) 10 continue enddo c c line drawing options c 20 do m=1,3 bx(m)=q(1,1)*x(m)+q(2,1)*y(m) by(m)=q(1,2)*x(m)+q(2,2)*y(m)+q(3,2)*rl(m) bz(m)=q(1,3)*x(m)+q(2,3)*y(m)+q(3,3)*rl(m) bx(m)=bx(m)*scale+xshift by(m)=by(m)*scale+yshift bz(m)=bz(m)*scale+zshift enddo do m=1,3 k=ibdy(itri+m-1) isw=0 if(lines.eq.-1) then isw=1 else if(lines.eq.0.and.k.ge.0) then isw=1 else if(k.eq.1) then isw=1 else if(k.gt.1) then if(lines.eq.1) then if(k.eq.2.or.k.eq.5) isw=1 else if(lines.eq.2) then if(k.eq.3.or.k.eq.5) isw=1 endif endif if(isw.eq.1) then x(1)=bx(index(2,m)) y(1)=by(index(2,m)) z(1)=bz(index(2,m)) x(2)=bx(index(3,m)) y(2)=by(index(3,m)) z(2)=bz(index(3,m)) call lwindw(x,y,z,2,t,2) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine torder(jp,itnode,itedge,order,nblock,ilen,list, + tlist,vx,vy,cen,q,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),itedge(3,*),order(*), 1 nblock(*),list(*),tlist(2,*),tblock double precision + vx(*),vy(*),q(3,3),cen(*) data ibit/0/ c c color surface plot c iflag=0 eps=ceps(ibit) eps1=dmax1(1.0d-4,eps*8.0d0) iordsw=jp(8) ntf=jp(1) c do i=1,ntf order(i)=i enddo if(iordsw.eq.1) return if(ntf.le.1) return c c find boundary interference list c call bblock(ntf,itnode,itedge,ilen,list,tlist, + vx,vy,q,cen,eps,iflag) if(iflag.ne.0) return c c set up nblock c do i=1,ntf nblock(i)=0 enddo do i=1,ntf do iside=1,3 j=itedge(iside,i)/4 if(j.gt.i) then it=tblock(itnode,i,iside,vx,vy,q,eps1) if(it.eq.1) nblock(i)=nblock(i)+1 if(it.eq.-1) nblock(j)=nblock(j)+1 endif enddo do jj=list(i),list(i+1)-1 j=list(jj) nblock(j)=nblock(j)+1 enddo enddo c c now compute order c mpt=1 do i=1,ntf if(nblock(i).eq.0) then order(mpt)=i nblock(i)=-mpt mpt=mpt+1 endif enddo if(mpt.gt.ntf) go to 20 c do m=1,ntf if(m.ge.mpt) stop 1123 i=order(m) c c update nblock c if(list(i).lt.list(i+1)) then do jj=list(i),list(i+1)-1 j=list(jj) nblock(j)=nblock(j)-1 if(nblock(j).eq.0) then order(mpt)=j nblock(j)=-mpt mpt=mpt+1 if(mpt.gt.ntf) go to 20 endif enddo endif c do 10 iside =1,3 j=itedge(iside,i)/4 if(j.gt.0) then if(nblock(j).lt.0) go to 10 it=tblock(itnode,i,iside,vx,vy,q,eps1) if(it.ne.-1) go to 10 nblock(j)=nblock(j)-1 if(nblock(j).eq.0) then order(mpt)=j nblock(j)=-mpt mpt=mpt+1 if(mpt.gt.ntf) go to 20 endif endif 10 continue enddo 20 if(jp(1).ge.ntf) return mpt=0 newntf=jp(1) do i=1,ntf if(order(i).le.newntf) then mpt=mpt+1 order(mpt)=order(i) endif enddo if(mpt.ne.newntf) stop 2255 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine plinit(ip,rp,itnode,ibndry,itedge,ibedge,vx,vy, + ut,vt,xm,ym,icplt,ierrsw,e,kdist,q,t,tl,jp,z, 1 jtnode,jbndry,vx0,vy0,ua,va) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibedge(2,*),ibndry(6,*), 1 jp(25),ip(100),kdist(*),jtnode(5,*),jbndry(6,*) double precision + vx(*),vy(*),ut(3,*),vt(3,*),xm(*),ym(*),vx0(*),vy0(*), 1 q(3,3),t(25),tl(25),rp(100),e(*),bmin(5),bmax(5),z(*), 2 ua(*),va(*) c c check control parameters in ip c mpisw=ip(48) nproc=ip(49) irgn=ip(50) do i=1,25 jp(i)=0 enddo call linit(t,q) call zoombx(rp,t) rmag=t(12) ntf=ip(1) nvf=ip(2) nbf=ip(4) icrsn=ip(68) itrgt=ip(69) ibase=ip(70) c c copy arrays c do i=1,ntf do j=1,5 itnode(j,i)=jtnode(j,i) enddo enddo do i=1,nvf vx(i)=vx0(i) vy(i)=vy0(i) enddo do i=1,nbf do j=1,6 ibndry(j,i)=jbndry(j,i) enddo enddo c if(mpisw.eq.1) then call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) call cedge5(nbf,itedge,ibedge,1) call cutr1(ntf,nvf,nbf,irgn,itnode,ibndry,vx,vy, + bmin,ut,vt,ibedge,z,1) else if(icrsn.eq.1) then newnbf=0 do i=1,nbf if(ibndry(4,i).ne.0) then newnbf=newnbf+1 do j=1,6 ibndry(j,newnbf)=ibndry(j,i) enddo ibndry(4,newnbf)=1 endif enddo nbf=newnbf endif call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) c c coarsen the mesh c if(icrsn.eq.1) then if(mpisw.eq.1) then nvtrgt=max0(3,itrgt/nproc) else nvtrgt=max0(3,itrgt) endif c call cvz(ntf,nvf,icplt,vx,vy,ut,vt,itnode,ua,va,z) ivtype=1 iseed=ivtype+nvf ipp=iseed+nvf iqq=ipp+nvf iqual=iqq+nvf c call crsn1(ntf,nvf,nbf,nvtrgt,icplt,itnode,ibndry, + vx,vy,xm,ym,ut,vt,ua,va,itedge,ibedge,z(ivtype), 1 z(ipp),z(iqq),z(iqual),z(iseed),ibase) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) endif c iscale=ip(58) if(iscale.lt.0.or.iscale.gt.2) iscale=0 lines=ip(59) if(lines.lt.-1.or.lines.gt.3) lines=0 if(icrsn.eq.1.and.lines.eq.0) lines=1 numbrs=ip(60) if(numbrs.lt.0.or.numbrs.gt.8) numbrs=0 if(mpisw.eq.1.and.numbrs.ne.7) numbrs=0 if(icrsn.eq.1.and.numbrs.ne.7 ) numbrs=0 nx=ip(61) ny=ip(62) nz=ip(63) mxcolr=max0(2,ip(51)) mxcolr=min0(256,mxcolr) ncolor=max0(1,ip(56)) i3d=1 if(numbrs.ne.0) i3d=0 c c set up jp c jp(1)=ntf jp(2)=nvf jp(3)=nbf jp(4)=icplt jp(5)=ncolor jp(6)=ierrsw jp(12)=mpisw c jp(13)=nx jp(14)=ny jp(15)=nz c jp(17)=mxcolr jp(20)=lines jp(21)=numbrs jp(23)=nproc c c find a box containing the solution c call xybox(nbf,vx,vy,xm,ym,ibndry,bmin(1),bmax(1), + bmin(2),bmax(2),diam) cx=0.0d0 cy=0.0d0 cz=1.0d0 if(icplt.eq.0) then call zvbox(ntf,itnode,ibndry,itedge,vx,vy,ut,vt, + xm,ym,cx,cy,cz,bmin(3),bmax(3)) bmin(3)=dmax1(bmin(3),0.0d0) else call zdbox(ntf,nbf,itnode,ibndry,ibedge,vx,vy,ut, + xm,ym,cx,cy,cz,bmin(3),bmax(3)) endif c if(mpisw.eq.1) call exbox(bmin,bmax,3) c if(rp(9).le.rp(8)) then t(19)=bmin(3) t(20)=bmax(3) else t(19)=rp(8) t(20)=rp(9) endif if(bmax(3).gt.bmin(3)) then t(4)=dmax1(bmax(1)-bmin(1),bmax(2)-bmin(2))/ + dmax1(t(20)-t(19),bmax(3)-bmin(3)) else t(4)=0.0d0 endif if(dmin1(bmin(3),t(19)).le.0.0d0.and.iscale.eq.1) iscale=2 jp(19)=iscale c c if(t(4).eq.0.0d0) i3d=0 if(i3d.eq.0) then zratio=0.0d0 else zratio=t(4) endif jp(22)=i3d iordsw=0 if(i3d.eq.0) iordsw=1 if(nx.eq.0.and.ny.eq.0) iordsw=1 jp(8)=iordsw c if(mxcolr.eq.2.or.ncolor.eq.0) then maplen=2 nshade=0 else if(ncolor.ge.mxcolr-2) then nshade=0 maplen=mxcolr else nshade=(mxcolr-2)/ncolor nshade=(nshade-1)/2 if(icplt.ne.0) then if(nx.eq.0.and.ny.eq.0) nshade=0 if(numbrs.ne.0) nshade=0 if(zratio.le.0.0d0) nshade=0 else nshade=min0(nshade,5) if(dmax1(dabs(t(19)),dabs(t(20))).eq.0.0d0) nshade=0 endif maplen=2+ncolor*(2*nshade+1) endif endif jp(16)=nshade jp(18)=maplen c c find a box containing the rotated solution c call mkrot(nx,ny,nz,q) cz=0.0d0 call zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,ut,xm,ym, + q(1,1),q(2,1),cz,bmin(1),bmax(1)) call zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,ut,xm,ym, + q(1,2),q(2,2),cz,bmin(4),bmax(4)) call zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,ut,xm,ym, + q(1,3),q(2,3),cz,bmin(5),bmax(5)) c if(icplt.eq.0) then cz=q(3,2)*zratio call zvbox(ntf,itnode,ibndry,itedge,vx,vy,ut,vt, + xm,ym,q(1,2),q(2,2),cz,bmin(2),bmax(2)) cz=q(3,3)*zratio call zvbox(ntf,itnode,ibndry,itedge,vx,vy,ut,vt, + xm,ym,q(1,3),q(2,3),cz,bmin(3),bmax(3)) else cz=q(3,2)*zratio call zdbox(ntf,nbf,itnode,ibndry,ibedge,vx,vy,ut, + xm,ym,q(1,2),q(2,2),cz,bmin(2),bmax(2)) cz=q(3,3)*zratio call zdbox(ntf,nbf,itnode,ibndry,ibedge,vx,vy,ut, + xm,ym,q(1,3),q(2,3),cz,bmin(3),bmax(3)) endif c if(mpisw.eq.1) call exbox(bmin,bmax,5) c size=t(14) xs=t(15) ys=t(16) zs=t(17) scale=size/dmax1(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmax(1)+bmin(1))/2.0d0 t(2)=ys-scale*(bmax(2)+bmin(2))/2.0d0 t(5)=zs-scale*(bmax(3)+bmin(3))/2.0d0 t(3)=scale c c parameters for legend plot c if(ierrsw.eq.1) then jp(1)=ip(1) call cdist(jp,t,e,kdist) jp(1)=ntf num=2*min0(ncolor,11) if(mpisw.eq.1) call exdist(kdist,num) endif do i=1,25 tl(i)=t(i) enddo if(rmag.le.1.0d0.or.jp(22).eq.0) then tl(2)=ys-scale*(bmax(4)+bmin(4))/2.0d0 tl(5)=zs-scale*(bmax(5)+bmin(5))/2.0d0 endif tl(12)=1.0d0 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tribx3(c,len,bu,bv,ut,vt) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + c(3,*),c0(3,7),vt(3),ut(3),bu(8),bv(8) c c compute intersection of triangle and box c c compute baricentric coords of box c c c1 + c2 + c3 =1 c c1 * ut(1) + c2 * ut(2) +c3 * ut(3) = bu c c1 * vt(1) + c2 * vt(2) +c3 * vt(3) = bv c x2=ut(2)-ut(1) y2=vt(2)-vt(1) x3=ut(3)-ut(1) y3=vt(3)-vt(1) det=x2*y3-x3*y2 do j=1,4 xr=bu(j)-ut(1) yr=bv(j)-vt(1) c(2,j)=(xr*y3-x3*yr)/det c(3,j)=(x2*yr-xr*y2)/det c(1,j)=1.0d0-c(2,j)-c(3,j) enddo c c now compute the polygon inside the triangle c len=4 do i=1,3 len0=len len=0 do k=1,len0 do j=1,3 c0(j,k)=c(j,k) enddo enddo c do k=1,len0 if(c0(i,k).ge.0.0d0) then len=len+1 do j=1,3 c(j,len)=c0(j,k) enddo else kbef=k-1 if(k.eq.1) kbef=len0 kaft=k+1 if(k.eq.len0) kaft=1 m=kbef do mba=1,2 if(c0(i,m).gt.0.0d0) then len=len+1 s=c0(i,m)/(c0(i,m)-c0(i,k)) do j=1,3 c(j,len)=c0(j,k)*s+c0(j,m)*(1.0d0-s) enddo endif m=kaft enddo endif enddo if(len.le.2) then len=0 return endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tribx2(c,len,bu,bv,ut,vt) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + c(3,*),c0(3,7),vt(3),ut(3),bu(8),bv(8),at(3),a(3),f(4) c c compute intersection of triangle and box c c c1 + c2 + c3 = 1 c c1 * ut(1) + c2 * ut(2) +c3 * ut(3) = bu c c1 * vt(1) + c2 * vt(2) +c3 * vt(3) = bv c c kmin=1 kmid=2 kmax=3 d12=(ut(2)-ut(1))**2+(vt(2)-vt(1))**2 d23=(ut(2)-ut(3))**2+(vt(2)-vt(3))**2 d13=(ut(3)-ut(1))**2+(vt(3)-vt(1))**2 if(d12.ge.dmax1(d23,d13)) then kmin=1 kmid=3 kmax=2 endif if(d23.ge.dmax1(d12,d13)) then kmin=2 kmid=1 kmax=3 endif c c compute kernal of a-transpose c at(1)=ut(kmax)*vt(kmin)-vt(kmax)*ut(kmin) at(2)=vt(kmax)-vt(kmin) at(3)=ut(kmin)-ut(kmax) dd=dmax1(dabs(at(1)),dabs(at(2)),dabs(at(3))) do j=1,3 at(j)=at(j)/dd enddo c c evaluate at * (1,bu,bv) at each corner of box c do j=1,4 f(j)=at(1)+at(2)*bu(j)+at(3)*bv(j) enddo c c compute kernal of a c au=(ut(1)+ut(2)+ut(3))/3.0d0 av=(vt(1)+vt(2)+vt(3))/3.0d0 qu=dsqrt((ut(1)-au)**2+(ut(2)-au)**2+(ut(3)-au)**2) qv=dsqrt((vt(1)-av)**2+(vt(2)-av)**2+(vt(3)-av)**2) tol=1.0d-2 if(qv.lt.tol*qu) then a(1)=ut(3)-ut(2) a(2)=ut(1)-ut(3) a(3)=ut(2)-ut(1) else a(1)=vt(3)-vt(2) a(2)=vt(1)-vt(3) a(3)=vt(2)-vt(1) endif if(a(kmid).eq.0.0d0) stop 7333 dd=a(kmid) do j=1,3 a(j)=a(j)/dd enddo c c all these points are in the range of a c x2=ut(kmax)-ut(kmin) y2=vt(kmax)-vt(kmin) len=0 kbef=4 do k=1,4 if(f(kbef)*f(k).lt.0.0d0) then len=len+1 s=f(k)/(f(k)-f(kbef)) bbu=bu(kbef)*s+bu(k)*(1.0d0-s) bbv=bv(kbef)*s+bv(k)*(1.0d0-s) c c solve 2 x 2 system based on kmax,kmin c if(dabs(x2).gt.dabs(y2)) then c(kmax,len)=(bbu-ut(kmin))/x2 else c(kmax,len)=(bbv-vt(kmin))/y2 endif c(kmin,len)=1.0d0-c(kmax,len) c(kmid,len)=0.0d0 endif kbef=k enddo if(len.le.1) then len=0 return endif if(len.gt.2) stop 7434 c c now make a box using kernal of a c do k=2,1,-1 len=len+1 do j=1,3 c(j,len)=c(j,k)+a(j) enddo enddo c c now compute the polygon inside the triangle c do i=1,3 len0=len len=0 do k=1,len0 do j=1,3 c0(j,k)=c(j,k) enddo enddo c do k=1,len0 if(c0(i,k).ge.0.0d0) then len=len+1 do j=1,3 c(j,len)=c0(j,k) enddo else kbef=k-1 if(k.eq.1) kbef=len0 kaft=k+1 if(k.eq.len0) kaft=1 m=kbef do mba=1,2 if(c0(i,m).gt.0.0d0) then len=len+1 s=c0(i,m)/(c0(i,m)-c0(i,k)) do j=1,3 c(j,len)=c0(j,k)*s+c0(j,m)*(1.0d0-s) enddo endif m=kaft enddo endif enddo if(len.le.2) then len=0 return endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine gbx(wu,wv,gmin,gmax,tmin,tmax,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + index(3,3) double precision + wu(*),wv(*),rr(3),ang(3),tu(3),tv(3),cc(3) save index data index/1,2,3,2,3,1,3,1,2/ c c compute min and max of vector function modulus on triangle c pi2=3.141592653589793d0*2.0d0 c c check vertices c do j=1,3 tu(j)=wu(j) tv(j)=wv(j) rr(j)=dsqrt(tu(j)**2+tv(j)**2) enddo gmax=rr(1) gmin=gmax tmin=pi2 tmax=0.0d0 do j=1,3 gmax=dmax1(gmax,rr(j)) gmin=dmin1(gmin,rr(j)) ang(j)=0.0d0 if(rr(j).gt.0.0d0) then arg=dmin1(tu(j)/rr(j),1.0d0) arg=dmax1(-1.0d0,arg) theta=dacos(arg) if(tv(j).lt.0.0d0) theta=pi2-theta tmin=dmin1(tmin,theta) tmax=dmax1(tmax,theta) ang(j)=theta endif enddo if(gmax.le.0.0d0) then tmin=0.0d0 tmax=0.0d0 return endif c c check bari center c do j=1,3 j2=index(2,j) j3=index(3,j) cc(j)=tu(j2)*tv(j3)-tu(j3)*tv(j2) enddo det=cc(1)+cc(2)+cc(3) if(det.ne.0.0d0) then do j=1,3 cc(j)=cc(j)/det enddo if(dmax1(cc(1),cc(2),cc(3)).le.1.0d0+eps.and. + dmin1(cc(1),cc(2),cc(3)).gt.-eps) then gmin=0.0d0 tmin=0.0d0 tmax=pi2 return endif endif c c look on edges c umax=0.0d0 do j=1,3 j2=index(2,j) j3=index(3,j) u1=tu(j2)-tu(j3) v1=tv(j2)-tv(j3) c c check for min radius c a1=u1*u1+v1*v1 if(a1.gt.0.0d0) then c1=-(u1*tu(j3)+v1*tv(j3))/a1 if(c1.ge.0.0d0.and.c1.le.1.0d0) then ut=tu(j3)+c1*u1 vt=tv(j3)+c1*v1 s=dsqrt(ut*ut+vt*vt) gmin=dmin1(gmin,s) endif endif c c check for crossing of positive x axis c if(v1.ne.0.0d0) then c1=-tv(j3)/v1 if(c1.ge.0.0d0.and.c1.le.1.0d0) + umax=dmax1(umax,tu(j3)+c1*u1) endif c enddo if(umax.gt.eps*gmax) then do j=1,3 if(tv(j).ge.0.0d0) ang(j)=ang(j)+pi2 enddo tmin=dmin1(ang(1),ang(2),ang(3)) tmax=dmax1(ang(1),ang(2),ang(3)) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine trnk(irank,i,ut,vt,rmax,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + uu(3),vv(3),ut(3,*),vt(3,*),ua(3),va(3) c c compute rank of 3 x 3 matrix, if irank=3, compute inverse c tol=dmax1(1.0d-3,eps) do j=1,3 uu(j)=ut(j,i)/rmax vv(j)=vt(j,i)/rmax enddo au=(uu(1)+uu(2)+uu(3))/3.0d0 av=(vv(1)+vv(2)+vv(3))/3.0d0 do j=1,3 ua(j)=uu(j)-au va(j)=vv(j)-av enddo qu=dsqrt(ua(1)**2+ua(2)**2+ua(3)**2) qv=dsqrt(va(1)**2+va(2)**2+va(3)**2) uv=dabs(ua(1)*va(1)+ua(2)*va(2)+ua(3)*va(3)) if(qu*qv.gt.0.0d0) then dp=dmax1(0.0d0,1.0d0-uv/(qu*qv)) else dp=0.0d0 endif c c test for rank 1 c if(dmax1(qu,qv).lt.tol) then irank=1 c c test for rank 3 c else if(dmin1(qv,qu,dp).gt.eps) then irank=3 c c test for rank 2 c else if(qu.lt.tol.and.qv.gt.tol) then irank=2 else if(qv.lt.tol.and.qu.gt.tol) then irank=2 else if(dp.lt.tol) then irank=2 c c default is rank 3 c else irank=3 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tinit(jp,itnode,iclr,vx,vy,num,val) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),iclr(*),mcic(3,6),num(4) double precision + vx(*),vy(*),val(2) save mcic data mcic/2,2,1,1,3,2,2,1,3,3,2,4,3,2,5,4,2,6/ c c set colors for element quality, min angle, max angle c ntf=jp(1) inplsw=jp(9) mxcolr=jp(17) c pi=3.141592653589793d0 if(mxcolr.ge.3.and.mxcolr.lt.8) then ic=mxcolr-2 else ic=6 endif ngood=0 npoor=0 if(inplsw.eq.2) then qgood=dsqrt(3.0d0)/2.0d0-1.0d-4 qpoor=0.6d0+1.0d-4 qmin=1.0d0 qave=0.0d0 do i=1,ntf r=dabs(geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)) qmin=dmin1(qmin,r) qave=qave+r iclr(i)=mcic(2,ic) if(r.ge.qgood) then ngood=ngood+1 iclr(i)=mcic(1,ic) else if(r.le.qpoor) then npoor=npoor+1 iclr(i)=mcic(3,ic) endif enddo c else if(inplsw.eq.3) then agood=1.0d0/2.0d0+1.0d-4 apoor=2.0d0/3.0d0-1.0d-4 angmx=0.0d0 amxave=0.0d0 do i=1,ntf r=cangmx(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) angmx=dmax1(angmx,r) amxave=amxave+r iclr(i)=mcic(2,ic) if(r.le.agood) then ngood=ngood+1 iclr(i)=mcic(1,ic) else if(r.ge.apoor) then npoor=npoor+1 iclr(i)=mcic(3,ic) endif enddo qmin=-180.0d0*angmx qave=180.0d0*amxave c else if(inplsw.eq.4) then bgood=dacos(4.0d0/5.0d0)/pi-1.0d-4 bpoor=dacos(13.0d0/14.0d0)/pi+1.0d-4 angmn=1.0d0 amnave=0.0d0 do i=1,ntf r=cangmn(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) angmn=dmin1(angmn,r) amnave=amnave+r iclr(i)=mcic(2,ic) if(r.ge.bgood) then ngood=ngood+1 iclr(i)=mcic(1,ic) else if(r.le.bpoor) then npoor=npoor+1 iclr(i)=mcic(3,ic) endif enddo qmin=180.0d0*angmn qave=180.0d0*amnave endif c num(1)=ngood num(2)=ntf-ngood-npoor num(3)=npoor num(4)=ntf val(1)=qmin val(2)=qave c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clrmap(red,green,blue,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25) double precision + red(*),green(*),blue(*),r(7),g(7),b(7) save r,g,b data r/1.0d0,1.0d0,1.0d0,0.0d0,0.0d0,0.0d0,1.0d0/ data g/0.0d0,0.0d0,1.0d0,1.0d0,1.0d0,0.0d0,0.0d0/ data b/1.0d0,0.0d0,0.0d0,0.0d0,1.0d0,1.0d0,1.0d0/ c c set up a color map c ncolor=jp(5) icplt=jp(4) nshade=jp(16) mxcolr=jp(17) maplen=jp(18) dgamma=0.7d0 theta=1.0d0 c c background color (white) c red(1)=1.0d0 green(1)=1.0d0 blue(1)=1.0d0 c c line-drawing color (black) c red(2)=0.0d0 green(2)=0.0d0 blue(2)=0.0d0 c if(maplen.le.2) return c if(ncolor.ge.mxcolr-2) then jcolor=mxcolr-2 else jcolor=ncolor endif c c the primary set of colors c red(3)=r(7) green(3)=g(7) blue(3)=b(7) if(jcolor.eq.1) go to 20 if(icplt.ne.0) then h=5.0d0/dfloat(jcolor-1) else h=6.0d0/dfloat(jcolor) endif do ii=2,jcolor i=ii+2 x=6.0d0-h*dfloat(ii-1) k=1+idint(x) dl=dfloat(k)-x dr=1.0d0-dl red(i)=dl*r(k)+dr*r(k+1) red(i)=dmax1(0.0d0,red(i))**dgamma red(i)=dmin1(1.0d0,red(i)) green(i)=dl*g(k)+dr*g(k+1) green(i)=dmax1(0.0d0,green(i))**dgamma green(i)=dmin1(1.0d0,green(i)) blue(i)=dl*b(k)+dr*b(k+1) blue(i)=dmax1(0.0d0,blue(i))**dgamma blue(i)=dmin1(1.0d0,blue(i)) enddo c c shading c 20 if(nshade.eq.0) return if(icplt.ne.0) then bmax=0.5d0/dfloat(nshade) wmax=0.5d0/dfloat(nshade) else bmax=0.45d0/dfloat(nshade) wmax=0.75d0/dfloat(nshade) endif do j=1,nshade jplus=j*ncolor+2 jminus=jplus+nshade*ncolor fb=(1.0d0-dfloat(j)*bmax)**theta fw=(1.0d0-dfloat(j)*wmax)**theta w=1.0d0-fw do i=1,ncolor k=i+jplus red(k)=red(i+2)*fw+w red(k)=dmax1(red(k),0.0d0) red(k)=dmin1(red(k),1.0d0) green(k)=green(i+2)*fw+w green(k)=dmax1(green(k),0.0d0) green(k)=dmin1(green(k),1.0d0) blue(k)=blue(i+2)*fw+w blue(k)=dmax1(blue(k),0.0d0) blue(k)=dmin1(blue(k),1.0d0) k=i+jminus red(k)=red(i+2)*fb red(k)=dmax1(red(k),0.0d0) red(k)=dmin1(red(k),1.0d0) green(k)=green(i+2)*fb green(k)=dmax1(green(k),0.0d0) green(k)=dmin1(green(k),1.0d0) blue(k)=blue(i+2)*fb blue(k)=dmax1(blue(k),0.0d0) blue(k)=dmin1(blue(k),1.0d0) enddo enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- integer function ccolor(icolor,ishade,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25) c c compute the color index c ncolor=jp(5) nshade=jp(16) mxcolr=jp(17) if(icolor.le.0.or.icolor.gt.ncolor + .or.iabs(ishade).gt.nshade) then ccolor=1 else if(ishade.eq.0) then ccolor=icolor+2-((icolor-1)/(mxcolr-1))*(mxcolr-1) if(ccolor.gt.mxcolr) ccolor=1 else if(ishade.gt.0) then ccolor=icolor+2+ncolor*ishade else ccolor=icolor+2+ncolor*(nshade-ishade) endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine incirc(x1,y1,x2,y2,x3,y3,xc,yc,r) c implicit double precision (a-h,o-z) implicit integer (i-n) c c compute center of inscribed circle c h1=dsqrt((x2-x3)**2+(y2-y3)**2) h2=dsqrt((x3-x1)**2+(y3-y1)**2) h3=dsqrt((x1-x2)**2+(y1-y2)**2) h=(h1+h2+h3)/2.0d0 s1=x2+((h-h2)/h1)*(x3-x2) t1=y2+((h-h2)/h1)*(y3-y2) s2=x3+((h-h3)/h2)*(x1-x3) t2=y3+((h-h3)/h2)*(y1-y3) s3=x1+((h-h1)/h3)*(x2-x1) t3=y1+((h-h1)/h3)*(y2-y1) call centre(s1,t1,s2,t2,s3,t3,xc,yc) r=dsqrt((xc-s1)**2+(yc-t1)**2) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine arc(x1,y1,x2,y2,xc,yc,theta1,theta2,r,alen) c implicit double precision (a-h,o-z) implicit integer (i-n) c c compute the parametric representation of the arc of c the circle passing through (x1,y1) and (x2,y2) with c center at (xc,yc). c pi=3.141592653589793d0 v1=x1-xc w1=y1-yc r1=dsqrt(v1**2+w1**2) v1=v1/r1 w1=w1/r1 c v2=x2-xc w2=y2-yc r2=dsqrt(v2**2+w2**2) v2=v2/r2 w2=w2/r2 c vm=(v1+v2)/2.0d0 wm=(w1+w2)/2.0d0 dd=dsqrt(vm**2+wm**2) vm=vm/dd wm=wm/dd c r=dsqrt(r1*r2) theta=dmax1(-1.0d0,vm) theta=dmin1(1.0d0,theta) theta=dacos(theta) if(wm.lt.0.0d0) theta=-theta c dtheta=dmin1(1.0d0,dd) dtheta=dacos(dtheta) if(v1*wm-w1*vm.gt.0.0d0) dtheta=-dtheta theta1=(theta+dtheta)/pi theta2=(theta-dtheta)/pi alen=dabs(dtheta*r*2.0d0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tbdy(c,ibdy,ntri,it,itnode,ibndry,itedge, + vx,vy,xm,ym,q,i3d) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibdy(*),itnode(5,*),itedge(3,*),ibndry(6,*), 1 iadj(3),index(3,3),icurv(3) double precision + vx(*),vy(*),xm(*),ym(*),c(3,*),c1(9,9),c2(9,9), 1 c3(9,9),q(3,3),xr(3),dr(3),rad(3),theta1(3),theta2(3) save index data index/1,2,3,2,3,1,3,1,2/ c c compute parameterization of triangle it in terms of c baricentric coordinates c pi=3.141592653589793d0 irefn=1 do j=1,3 if(itedge(j,it).gt.0) then k=itedge(j,it)/4 icurv(j)=0 iadj(j)=0 if(itnode(5,it).ne.itnode(5,k)) iadj(j)=2 if(itnode(4,it).ne.itnode(4,k)) iadj(j)=iadj(j)+3 else iadj(j)=1 k=-itedge(j,it) if(ibndry(4,k).eq.4) iadj(j)=5 if(ibndry(4,k).eq.3) iadj(j)=3 if(ibndry(3,k).le.0) then icurv(j)=0 else kt=ibndry(3,k) icurv(j)=kt iv1=itnode(index(2,j),it) iv2=itnode(index(3,j),it) call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(kt),ym(kt),theta1(j),theta2(j),rad(j), 1 alen) aa=dabs(theta2(j)-theta1(j))*32.0d0 mm=min0(idint(aa+0.5d0),8) irefn=max0(irefn,mm) endif endif enddo c c set up initial baricentric coodinates c do k=1,irefn+1 do j=1,irefn+2-k c2(k,j)=dfloat(k-1)/dfloat(irefn) c3(k,j)=dfloat(j-1)/dfloat(irefn) c1(k,j)=1.0d0-c2(k,j)-c3(k,j) enddo enddo c c modify barycentric coordinates for curved edges c if(irefn.eq.1) go to 30 do 10 j=1,3 if(icurv(j).eq.0) go to 10 kt=icurv(j) iv1=itnode(index(2,j),it) iv2=itnode(index(3,j),it) iv3=itnode(j,it) dt=(theta2(j)-theta1(j))/dfloat(irefn) x1=vx(iv1)-vx(iv3) x2=vx(iv2)-vx(iv3) y1=vy(iv1)-vy(iv3) y2=vy(iv2)-vy(iv3) det=x1*y2-y1*x2 do m=2,irefn tt=(theta1(j)+dt*dfloat(m-1))*pi xx=xm(kt)+rad(j)*dcos(tt)-vx(iv3) yy=ym(kt)+rad(j)*dsin(tt)-vy(iv3) mm=irefn+2-m if(j.eq.1) then c2(mm,m)=(xx*y2-yy*x2)/det c3(mm,m)=(x1*yy-y1*xx)/det c1(mm,m)=1.0d0-c2(mm,m)-c3(mm,m) else if(j.eq.2) then c3(1,mm)=(xx*y2-yy*x2)/det c1(1,mm)=(x1*yy-y1*xx)/det c2(1,mm)=1.0d0-c3(1,mm)-c1(1,mm) else c1(m,1)=(xx*y2-yy*x2)/det c2(m,1)=(x1*yy-y1*xx)/det c3(m,1)=1.0d0-c1(m,1)-c2(m,1) endif enddo 10 continue c c smoothing c itmax=100 tol=1.d-2 do i=1,itmax cc=0.0d0 do k=2,irefn-1 do j=2,irefn+1-k cc2=(c2(k,j-1)+c2(k,j+1)+c2(k+1,j)+ + c2(k-1,j)+c2(k+1,j-1)+c2(k-1,j+1))/6.0d0 cc3=(c3(k,j-1)+c3(k,j+1)+c3(k+1,j)+ + c3(k-1,j)+c3(k+1,j-1)+c3(k-1,j+1))/6.0d0 cc=dmax1(cc,dabs(cc2-c2(k,j)),dabs(cc3-c3(k,j))) c2(k,j)=cc2 c3(k,j)=cc3 c1(k,j)=1.0d0-cc2-cc3 enddo enddo if(cc.le.tol) go to 20 enddo c c do orientation c 20 if(i3d.eq.0) go to 30 do j=1,3 xr(j)=q(1,1)*vx(itnode(j,it))+q(2,1)*vy(itnode(j,it)) enddo dr(1)=xr(3)-xr(2) dr(2)=xr(1)-xr(3) dr(3)=xr(2)-xr(1) iback=1 if(dr(2).gt.dr(iback)) iback=2 if(dr(3).gt.dr(iback)) iback=3 imid=index(2,iback) ifront=index(3,iback) if(dr(ifront).gt.dr(imid)) imid=ifront ifront=6-iback-imid c c swapping c jmid=2 if(iback.eq.2) then do j=1,irefn jj=irefn+2-j do k=1,jj/2 cc=c1(k,j) c1(k,j)=c1(jj+1-k,j) c1(jj+1-k,j)=cc cc=c2(k,j) c2(k,j)=c2(jj+1-k,j) c2(jj+1-k,j)=cc cc=c3(k,j) c3(k,j)=c3(jj+1-k,j) c3(jj+1-k,j)=cc enddo enddo ii=iadj(1) iadj(1)=iadj(2) iadj(2)=ii jmid=1 else if(iback.eq.3) then do k=1,irefn kk=irefn+2-k do j=1,kk/2 cc=c1(k,j) c1(k,j)=c1(k,kk+1-j) c1(k,kk+1-j)=cc cc=c2(k,j) c2(k,j)=c2(k,kk+1-j) c2(k,kk+1-j)=cc cc=c3(k,j) c3(k,j)=c3(k,kk+1-j) c3(k,kk+1-j)=cc enddo enddo ii=iadj(1) iadj(1)=iadj(3) iadj(3)=ii endif if(jmid.ne.imid) then do k=2,irefn+1 do j=1,k/2 cc=c1(k+1-j,j) c1(k+1-j,j)=c1(j,k+1-j) c1(j,k+1-j)=cc cc=c2(k+1-j,j) c2(k+1-j,j)=c2(j,k+1-j) c2(j,k+1-j)=cc cc=c3(k+1-j,j) c3(k+1-j,j)=c3(j,k+1-j) c3(j,k+1-j)=cc enddo enddo ii=iadj(2) iadj(2)=iadj(3) iadj(3)=ii endif c c now make triangles c 30 k=0 do j=1,irefn do 40 i=1,irefn+1-j c(1,k+1)=c1(i,j) c(2,k+1)=c2(i,j) c(3,k+1)=c3(i,j) c(1,k+2)=c1(i+1,j) c(2,k+2)=c2(i+1,j) c(3,k+2)=c3(i+1,j) c(1,k+3)=c1(i,j+1) c(2,k+3)=c2(i,j+1) c(3,k+3)=c3(i,j+1) ibdy(k+1)=-1 ibdy(k+2)=-1 ibdy(k+3)=-1 if(j.eq.1) ibdy(k+3)=iadj(3) if(i.eq.1) ibdy(k+2)=iadj(2) if(i+j.eq.irefn+1) ibdy(k+1)=iadj(1) k=k+3 if(i+j.eq.irefn+1) go to 40 c(1,k+1)=c1(i+1,j) c(2,k+1)=c2(i+1,j) c(3,k+1)=c3(i+1,j) c(1,k+2)=c1(i+1,j+1) c(2,k+2)=c2(i+1,j+1) c(3,k+2)=c3(i+1,j+1) c(1,k+3)=c1(i,j+1) c(2,k+3)=c2(i,j+1) c(3,k+3)=c3(i,j+1) ibdy(k+1)=-1 ibdy(k+2)=-1 ibdy(k+3)=-1 k=k+3 40 continue enddo ntri=irefn**2 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- integer function tblock(itnode,it,iside,vx,vy,q,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) double precision + vx(*),vy(*),q(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c test edge iside relative to the viewing direction c this routine assume that knots are ordered such that geom > 0 c j2=index(2,iside) j3=index(3,iside) c=vx(itnode(j2,it))-vx(itnode(j3,it)) s=vy(itnode(j2,it))-vy(itnode(j3,it)) qq=(c*q(1,1)+s*q(2,1))/dsqrt(c**2+s**2) tblock=0 if(qq.gt.eps) tblock=1 if(qq.lt.-eps) tblock=-1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bblock(ntf,itnode,itedge,ilen,list,tlist,vx,vy,q, + cen,eps,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),list(*),tlist(2,*), 1 tblock,endin,endout,index(3,3) double precision + vx(*),vy(*),q(3,3),cen(*) save index data index/1,2,3,2,3,1,3,1,2/ c c compute boundary types c iflag=0 c llen=ilen+ntf+1 c eps1=dmax1(1.0d-4,eps*8.0d0) c c make a list of triangles with boundary edges c istrt=llen+1 endin=0 do i=1,ntf kin=0 kout=0 do 10 j=1,3 if(itedge(j,i).gt.0) go to 10 ity=tblock(itnode,i,j,vx,vy,q,eps1) if(ity.eq.0) go to 10 if(ity.eq.1) then if(kin.eq.0) then endin=endin+1 list(endin)=j+4*i kin=j else list(endin)=6-j-kin+4*i endif else if(kout.eq.0) then istrt=istrt-1 list(istrt)=j+4*i kout=j else list(istrt)=6-j-kout+4*i endif endif 10 continue enddo if(istrt.le.endin) go to 160 do i=istrt,llen list(endin+i-istrt+1)=list(i) enddo endout=endin+llen-istrt+1 c c sort edges c hmax=0.0d0 do ic=1,2 if(ic.eq.1) then iptr=1 kl=endin else iptr=endin+1 kl=endout-endin endif do m=1,kl i=m+iptr-1 it=list(i)/4 iedge=list(i)-4*it j1=index(2,iedge) j2=index(3,iedge) x1i=q(1,1)*vx(itnode(j1,it))+q(2,1)*vy(itnode(j1,it)) x2i=q(1,1)*vx(itnode(j2,it))+q(2,1)*vy(itnode(j2,it)) cen(i)=(x1i+x2i)/2.0d0 hmax=dmax1(hmax,dabs(x2i-x1i)) enddo l2=kl/2 do i=l2,1,-1 call mkheap(i,kl,cen(iptr),list(iptr)) enddo do i=kl,1,-1 i1=list(iptr) list(iptr)=list(iptr+i-1) list(iptr+i-1)=i1 c1=cen(iptr) cen(iptr)=cen(iptr+i-1) cen(iptr+i-1)=c1 call mkheap(1,i-1,cen(iptr),list(iptr)) enddo enddo c c now make list of triangle pairs that interfere c jstrt=1 num=0 do 80 ii=endin+1,endout it=list(ii)/4 iedge=list(ii)-4*it j1=index(2,iedge) j2=index(3,iedge) x1i=q(1,1)*vx(itnode(j1,it))+q(2,1)*vy(itnode(j1,it)) x2i=q(1,1)*vx(itnode(j2,it))+q(2,1)*vy(itnode(j2,it)) y1i=q(2,1)*vx(itnode(j1,it))-q(1,1)*vy(itnode(j1,it)) y2i=q(2,1)*vx(itnode(j2,it))-q(1,1)*vy(itnode(j2,it)) ximax=dmax1(x1i,x2i) yimax=dmax1(y1i,y2i) ximin=dmin1(x1i,x2i) yimin=dmin1(y1i,y2i) epsi=eps*(yimax-yimin+ximax-ximin) c istrt=jstrt do 70 jj=istrt,endin c c simple tests to cut down compares c if(cen(jj)+hmax.le.cen(ii)) then jstrt=jj go to 70 endif if(ximin.ge.cen(jj)+hmax/2.0d0) go to 70 if(ximax.le.cen(jj)-hmax/2.0d0) go to 80 c jt=list(jj)/4 if(it.eq.jt) go to 70 jedge=list(jj)-4*jt j1=index(2,jedge) j2=index(3,jedge) x1j=q(1,1)*vx(itnode(j1,jt))+q(2,1)*vy(itnode(j1,jt)) x2j=q(1,1)*vx(itnode(j2,jt))+q(2,1)*vy(itnode(j2,jt)) y1j=q(2,1)*vx(itnode(j1,jt))-q(1,1)*vy(itnode(j1,jt)) y2j=q(2,1)*vx(itnode(j2,jt))-q(1,1)*vy(itnode(j2,jt)) xjmax=dmax1(x1j,x2j) xjmin=dmin1(x1j,x2j) yjmax=dmax1(y1j,y2j) yjmin=dmin1(y1j,y2j) epsj=eps*(yjmax-yjmin+xjmax-xjmin)+epsi c c simple tests to disregard this element c c* if(yimin+epsj.ge.yjmax) go to 70 if(ximin+epsj.ge.xjmax) go to 70 if(xjmin+epsj.ge.ximax) go to 70 c xx=(dmax1(ximin,xjmin)+dmin1(ximax,xjmax))/2.0d0 yi=(y1i*(x2i-xx)+y2i*(xx-x1i))/(x2i-x1i) yj=(y1j*(x2j-xx)+y2j*(xx-x1j))/(x2j-x1j) if(yi-8.0d0*epsj.ge.yj) go to 70 c c we have found a conflicting pair c num=num+1 if(num.gt.ilen) go to 160 tlist(1,num)=it tlist(2,num)=jt c 70 continue 80 continue c c make final list c do i=1,ntf+1 list(i)=0 enddo if(num.le.0) return c do i=1,num j=tlist(1,i) list(j+1)=list(j+1)+1 enddo c list(1)=ntf+2 do i=2,ntf+1 list(i)=list(i)+list(i-1) enddo if(list(ntf+1).gt.llen+1) go to 160 c do i=1,num j=tlist(1,i) k=list(j) list(j)=k+1 list(k)=tlist(2,i) enddo c do i=ntf+1,2,-1 list(i)=list(i-1) enddo list(1)=ntf+2 return 160 iflag=20 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkheap(i,llen,d,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + list(*) double precision + d(*) c c this routine makes a heap with root at vertex i, assuming its c sons are already roots of heaps c k=i 10 kson=2*k if(kson.gt.llen) return if(kson.lt.llen) then if(d(kson+1).gt.d(kson)) kson=kson+1 endif if(d(k).ge.d(kson)) return ktemp=list(k) list(k)=list(kson) list(kson)=ktemp dtemp=d(k) d(k)=d(kson) d(kson)=dtemp k=kson go to 10 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd0(t) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(6),y(6),z(6),t(25),tt(25),q(3,3) c c helps locating current window (draw boundary in small window) c call linit(tt,q) zshift=tt(5) scale=tt(3) size=tt(14) dd=(scale+size)/4.0d0 x0=tt(15)-dd x1=tt(15)+dd y0=tt(16)-dd y1=tt(16)+dd c c mark magnified area c do i=1,6 z(i)=zshift enddo if(t(12).gt.1.0d0) then xl=dmax1(x0,t(8)) xr=dmin1(x1,t(9)) yb=dmax1(y0,t(10)) yt=dmin1(y1,t(11)) c c mark the box in the window c x(1)=(xl+xr)/2.0d0 x(2)=x(1) y(1)=y0 y(2)=yb call pline(x,y,z,2,2) y(1)=yt y(2)=y1 call pline(x,y,z,2,2) x(1)=x0 x(2)=xl y(1)=(yb+yt)/2.0d0 y(2)=y(1) call pline(x,y,z,2,2) x(1)=xr x(2)=x1 call pline(x,y,z,2,2) x(1)=xl y(1)=yb x(2)=xr y(2)=y(1) x(3)=x(2) y(3)=yt x(4)=x(1) y(4)=y(3) x(5)=x(1) y(5)=y(1) call pline(x,y,z,5,2) endif c x(1)=x0 y(1)=y0 x(2)=x1 y(2)=y(1) x(3)=x(2) y(3)=y1 x(4)=x(1) y(4)=y(3) x(5)=x(1) y(5)=y(1) call pline(x,y,z,5,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine linit(t,q) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + t(25),q(3,3) data ibit/0/ c c initial for legends and graphs c size=0.9d0 do i=1,25 t(i)=0.0d0 enddo t(3)=1.0d0 t(5)=0.5d0 t(7)=ceps(ibit) t(12)=1.0d0 t(14)=size t(15)=0.5d0 t(16)=0.5d0 t(17)=0.5d0 do i=1,3 do j=1,3 q(i,j)=0.0d0 enddo q(i,i)=1.0d0 enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine zoombx(rp,t) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rp(100),t(25) c c compute the zoom-in window c size=t(14) xs=t(15) ys=t(16) zs=t(17) rmag=dmax1(1.0d0,rp(10)) cenx=dmax1(0.0d0,rp(11)) cenx=dmin1(1.0d0,cenx) ceny=dmax1(0.0d0,rp(12)) ceny=dmin1(1.0d0,ceny) h=1.0d0/(2.0d0*rmag) hx=xs-size/2.0d0 hy=ys-size/2.0d0 t(8)=size*(cenx-h)+hx t(9)=size*(cenx+h)+hx t(10)=size*(ceny-h)+hy t(11)=size*(ceny+h)+hy t(12)=rmag c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkrot(nx,ny,nz,q) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + q(3,3),d(3) c c compute rotation matrix c d(1)=dfloat(nx) d(2)=dfloat(ny) d(3)=dfloat(nz) do i=1,3 do j=1,3 q(j,i)=0.0d0 enddo q(i,i)=1.0d0 enddo dl=dsqrt(d(1)*d(1)+d(2)*d(2)+d(3)*d(3)) if(dl.gt.0.0d0) then do i=1,3 q(i,3)=d(i)/dl enddo endif dl=dsqrt(q(1,3)*q(1,3)+q(2,3)*q(2,3)) if(dl.gt.0.0d0) then q(1,1)=-q(2,3)/dl q(2,1)=q(1,3)/dl q(1,2)=-q(2,1)*q(3,3) q(2,2)=q(1,1)*q(3,3) q(3,2)=dl else if(q(3,3).lt.0.0d0) q(1,1)=-q(1,1) endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd1(jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor double precision + x(4),y(4),z(4),q(3,3),t(25) character*80 + ichr c call linit(t,q) size=t(14) zshift=t(5) xs=t(15) ys=t(16) c ncolor=jp(5) xl=xs-size/2.0d0 xr=xs+size/2.0d0 yb=ys-size/2.0d0 yt=ys+size/2.0d0 s3=dsqrt(3.0d0)/2.0d0 c c compute ncol and nrow c s=dsqrt(dfloat(ncolor)/3.0d0) is=idint(s) if(s-dfloat(is).gt.1.d-3) is=is+1 ncol=max0(is,2) nrow=ncolor/ncol if(nrow*ncol.lt.ncolor) nrow=nrow+1 nrow=max0(nrow,1) dx=(xr-xl)/dfloat(ncol) dy=(yt-yb)/dfloat(nrow) if(dx.gt.3.0d0*dy) dx=3.0d0*dy if(dx.lt.3.0d0*dy) dy=dx/3.0d0 c c the main loop c icolor=0 do 30 nr=1,nrow do 20 nc=1,ncol icolor=icolor+1 if(icolor.gt.ncolor) go to 20 c c level number c ichr=' ' if(icolor.lt.10) then call sint(ichr(3:3),nchr,icolor) else call sint(ichr(2:2),nchr,icolor) endif ii=ccolor(icolor,0,jp) c x1=xl+dfloat(nc-1)*dx x2=xl+dfloat(nc)*dx xm=(2.0d0*x2+x1)/3.0d0 y1=yt-dfloat(nr)*dy y2=yt-dfloat(nr-1)*dy ym=(y1+y2)/2.0d0 call htext(x1,y1,xm,ym,4,ichr,1,q,t,2) c c triangle icon c x(1)=xm x(2)=(xm+x2)/2.0d0 x(3)=x2 x(4)=xm y(1)=y1 y(2)=y1+s3*(x2-xm) y(3)=y1 y(4)=y1 do i=1,4 z(i)=zshift enddo ii=ccolor(icolor,0,jp) call pfill(x,y,z,3,ii) call pline(x,y,z,4,2) 20 continue 30 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd2(jp,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,mcic(3,6) double precision + x(4),y(4),z(4),tt(25),qq(3,3),t(25) character*80 + ichr,title(3),label(5) save label,mcic,title c data title/'element quality','maximum angle', + 'minimum angle'/ data label/'good','fair','poor','worst','average'/ data mcic/2,2,1,1,3,2,2,1,3,3,2,4,3,2,5,4,2,6/ c call linit(tt,qq) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c xl=xs-size/2.0d0 xr=xs+size/2.0d0 yb=ys-size/2.0d0 yt=ys+size/2.0d0 s3=2.0d0/dsqrt(3.0d0) dx=(xr-xl)/14.5d0 dy=(yt-yb)/6.0d0 h=dmin1(0.9d0*dy,dx) c do i=1,4 z(i)=zshift enddo c mxcolr=jp(17) if(mxcolr.ge.3.and.mxcolr.lt.8) then ic=mxcolr-2 else ic=6 endif c inplsw=jp(9) call fstr(ichr,nchr,title(inplsw-1),0) xxl=xl+2.25d0*dx xxr=xxl+15.0d0*dx yyl=yt-dy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,15,ichr,-1,qq,tt,2) c do i=1,5 yy=yt-dfloat(i+1)*dy c c triangle icon c if(i.le.3) then x(1)=xl+0.25d0*dx x(2)=x(1)+s3*h x(3)=(x(1)+x(2))/2.0d0 x(4)=x(1) y(1)=yy y(2)=yy y(3)=yy+h y(4)=yy icolor=mcic(i,ic) ii=ccolor(icolor,0,jp) call pfill(x,y,z,3,ii) call pline(x,y,z,4,2) endif c c label c call fstr(ichr,nchr,label(i),0) xxl=xl+2.25d0*dx xxr=xxl+7.0d0*dx yyl=yy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,7,ichr,-1,qq,tt,2) c c value c ichr=' ' call sfix(ichr(4:4),nchr,t(20+i),3) cc call sreal(ichr(4:4),nchr,t(20+i),3,1) if(nchr.lt.7) then ii=nchr-3 nchr=7 else ii=4 endif xxl=xl+9.25d0*dx xxr=xxl+5.0d0*dx call htext(xxl,yyl,xxr,yyr,nchr,ichr(ii:ii),1,qq,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd3(jp,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,nchr(15) double precision + x(129),y(129),z(129),t(25),tt(25),qq(3,3),f(52) character*80 + ichr(15) c call linit(tt,qq) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c ncolor=jp(5) if(ncolor.le.0) return nshade=jp(16) iscale=jp(19) c c set function values c funmin=fscale(t(19),iscale,0) funmax=fscale(t(20),iscale,0) df=(funmax-funmin)/dfloat(2*nshade+1) do i=1,2*nshade+2 zz=funmin+df*dfloat(i-1) f(i)=fscale(zz,iscale,1) enddo c xm=xs+0.15d0*size ym=ys rmax=0.35d0*size pi=3.141592653589793d0 c if(t(19).gt.0.0d0) then rmin=rmax*0.15d0 else rmin=0.0d0 endif dr=(rmax-rmin)/dfloat(2*nshade+1) dt=2.0d0*pi/dfloat(ncolor) nn=max0(64/ncolor,2) nn=min0(nn,48) dq=dt/dfloat(nn-1) n2=2*nn n3=n2+1 c c draw regions c do i=1,ncolor do j=1,2*nshade+1 theta=dfloat(i-1)*dt r1=rmin+dfloat(j-1)*dr r2=rmin+dfloat(j)*dr k=j-nshade-1 ic=ccolor(i,k,jp) do k=1,nn ang=theta+dfloat(k-1)*dq c=dcos(ang) s=dsin(ang) x(k)=xm+r2*c y(k)=ym+r2*s z(k)=zshift x(n3-k)=xm+r1*c y(n3-k)=ym+r1*s z(n3-k)=zshift enddo x(n3)=x(1) y(n3)=y(1) z(n3)=z(1) call pfill(x,y,z,n2,ic) call pline(x,y,z,n3,2) enddo enddo c c draw band across the bottom c yb=ys-size*0.45d0 yt=ys+size*0.45d0 xl=xs-size*0.5d0 xr=xl+size*0.05d0 xc=xr+0.02d0*size xf=xc+0.2d0*size c dy=(yt-yb)/dfloat(2*nshade+1) do i=1,2*nshade+1 k=i-nshade-1 ic=ccolor(1,k,jp) x(1)=xl y(1)=yb+dfloat(i-1)*dy z(1)=zshift x(2)=xr y(2)=y(1) z(2)=zshift x(3)=x(2) y(3)=yb+dfloat(i)*dy z(3)=zshift x(4)=x(1) y(4)=y(3) z(4)=zshift x(5)=x(1) y(5)=y(1) z(5)=z(1) call pfill(x,y,z,4,ic) call pline(x,y,z,5,2) enddo c mxchr=0 do i=1,2*nshade+2 ichr(i)=' ' zc=f(i) if(zc.lt.0.0d0) then call sreal(ichr(i),nchr(i),zc,3,1) else call sreal(ichr(i)(2:2),nn,zc,3,1) nchr(i)=nn+1 endif mxchr=max0(mxchr,nchr(i)) enddo do i=1,2*nshade+2 yc=yb+dy*dfloat(i-1)-dy/2.0d0 yf=yc+dy call htext(xc,yc,xf,yf,mxchr,ichr(i),-1,qq,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd4(jp,t,kdist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + nchr(20),jp(25),ccolor,kdist(22) double precision + f(12),x(44),y(44),z(44),t(25),tt(25),qq(3,3) character*80 + ichr(15) c call linit(tt,qq) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c ierrsw=jp(6) icolor=jp(5) if(icolor.le.0) return ncolor=min0(icolor,11) iscale=jp(19) c c set function values c zmin=fscale(t(19),iscale,0) zmax=fscale(t(20),iscale,0) df=(zmax-zmin)/dfloat(ncolor) do i=1,ncolor+1 zz=zmin+df*dfloat(i-1) f(i)=fscale(zz,iscale,1) enddo c c make boxes for each color c xf=xs xi=xf-size*0.45d0 xc=xf+0.04d0*size xx=xc+0.4d0*size yi=ys-size*0.45d0 yf=ys+size*0.45d0 yinc=0.04d0*size tic=0.02d0*size if(icolor.eq.ncolor) yf=yi+(yf-yi)*ncolor/11.0d0 c do i=1,5 z(i)=zshift enddo x(1)=xi x(2)=xf x(3)=xf x(4)=xi x(5)=xi dy=(yf-yi)/dfloat(icolor) do i=1,icolor y(1)=yi+dy*dfloat(i) y(2)=y(1) y(3)=yi+dy*dfloat(i-1) y(4)=y(3) ii=ccolor(i,0,jp) call pfill(x,y,z,4,ii) enddo c c draw the border and tick marks c y(1)=yi y(2)=yi y(3)=yf y(4)=yf y(5)=yi call pline(x,y,z,5,2) c c x(1)=xf scale=(yf-yi)/dfloat(ncolor) do i=0,ncolor yp=yi+scale*i x(2)=xf+tic y(1)=yp y(2)=yp call pline(x,y,z,2,2) enddo c c compute error distribution c if(ierrsw.eq.1.and.df.ne.0.0d0) then num=2*ncolor kdm=0 do i=1,num kdm=max0(kdm,kdist(i)) enddo ddy=(yf-yi)/dfloat(num) xxi=xi+0.05d0*(xf-xi) ddx=0.9d0*(xf-xi) do i=1,num j=2*i-1 x(j)=xxi+ddx*(dfloat(kdist(i))/dfloat(kdm)) x(j+1)=x(j) y(j+1)=yi+ddy*dfloat(i) y(j)=yi+ddy*dfloat(i-1) z(j)=zshift z(j+1)=zshift enddo num=2*num call pline(x,y,z,num,2) endif c c label the tick marks c mxchr=0 do i=1,ncolor+1 ichr(i)=' ' zc=f(i) if(zc.lt.0.0d0) then call sreal(ichr(i)(2:2),nn,zc,3,1) nchr(i)=nn+1 else call sreal(ichr(i)(3:3),nn,zc,3,1) nchr(i)=nn+2 endif mxchr=max0(mxchr,nchr(i)) enddo do i=1,ncolor+1 yc=yi+scale*dfloat(i-1)-yinc/2.0d0 yf=yc+yinc call htext(xc,yc,xx,yf,mxchr,ichr(i),-1,qq,tt,2) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cdist(jp,t,e,kdist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),kdist(22) double precision + e(*),t(25) c c num=2*min0(jp(5),11) ntf=jp(1) iscale=jp(19) c c set function values c zmin=fscale(t(19),iscale,0) zmax=fscale(t(20),iscale,0) if(zmax.gt.zmin) then dd=dfloat(num)/(zmax-zmin) else dd=0.0d0 endif c do i=1,num kdist(i)=0 enddo do i=1,ntf ff=(fscale(e(i),iscale,0)-zmin)*dd iq=max0(1,idint(ff)+1) iq=min0(num,iq) kdist(iq)=kdist(iq)+1 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd5(jp,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,mcic(4) double precision + x(5),y(5),z(5),q(3,3),t(25),tt(25) character*80 + ichr,title,label(4),mnmx(2) save label,title,mcic,mnmx c data title/'element types'/ data label/'diagonal','original','fillin','neglected'/ data mnmx/'min','max'/ data mcic/5,4,2,6/ c call linit(tt,q) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c xl=xs-size/2.0d0 xr=xs+size/2.0d0 yb=ys-size/2.0d0 yt=ys+size/2.0d0 dx=(xr-xl)/14.5d0 dy=(yt-yb)/7.0d0 h=dmin1(0.9d0*dy,dx) c call fstr(ichr,nchr,title,0) xxl=xl+2.25d0*dx xxr=xxl+15.0d0*dx yyl=yt-dy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,15,ichr,-1,q,tt,2) c do i=1,4 yy=yt-dfloat(i+1)*dy c c square icon c x(1)=xl+0.25d0*dx x(2)=x(1)+h x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=yy y(2)=yy y(3)=yy+h y(4)=y(3) y(5)=y(1) do j=1,5 z(j)=zshift enddo ii=ccolor(mcic(i),0,jp) call pfill(x,y,z,4,ii) call pline(x,y,z,5,2) c c label c call fstr(ichr,nchr,label(i),0) xxl=xl+2.25d0*dx xxr=xxl+15.0d0*dx yyl=yy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,15,ichr,-1,q,tt,2) enddo c c min-max values c do i=1,2 yy=yt-dfloat(i+5)*dy c c label c call fstr(ichr,nchr,mnmx(i),0) xxl=xl+0.25d0*dx xxr=xxl+3.0d0*dx yyl=yy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,3,ichr,-1,q,tt,2) c c value c ichr=' ' call sreal(ichr(4:4),nchr,t(23+i),3,1) if(nchr.lt.7) then ii=nchr-3 nchr=7 else ii=4 endif xxl=xl+4.25d0*dx xxr=xr call htext(xxl,yyl,xxr,yyr,nchr,ichr(ii:ii),1,q,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd6(jp,iptr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,mcic(50),jc(6) double precision + x(5),y(5),z(5),q(3,3),tt(25) character*80 + ichr,title(5),label(50) save label,title,mcic,jc c data title( 1)/'adaptive mesh option'/ data label( 1)/'error estimate '/ data label( 2)/'refine '/ data label( 3)/'unrefine '/ data label( 4)/'unrefine/refine '/ data label( 5)/'uniform/load balance'/ data label( 6)/'mesh smoothing '/ data (mcic(i),i= 1, 6)/4,2,3,1,5,6/ c data title( 2)/'continuation options'/ data label( 7)/'initialization '/ data label( 8)/'regular point '/ data label( 9)/'limit point '/ data label(10)/'bifurcation point '/ data label(11)/'adaptive mesh '/ data label(12)/'adaptive mesh (mpi) '/ data (mcic(i),i= 7,12)/1,4,2,6,3,5/ c data title( 3)/'time history '/ data label(13)/'new step '/ data label(14)/'redone step '/ data (mcic(i),i=13,14)/6,4/ c data title( 4)/'interior point method'/ data label(15)/'initialization '/ data label(16)/'regular point '/ data label(17)/'switch lambda '/ data label(18)/'mpi solve '/ data (mcic(i),i=15,18)/6,2,5,3/ c data jc/1,7,13,15,19,19/ c call linit(tt,q) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c xl=xs-size/2.0d0 xr=xs+size/2.0d0 yb=ys-size/2.0d0 yt=ys+size/2.0d0 dx=(xr-xl)/20.5d0 dy=(yt-yb)/9.0d0 h=dmin1(0.9d0*dy,dx) c call fstr(ichr,nchr,title(iptr),0) xxl=xl+2.25d0*dx xxr=xxl+17.0d0*dx yyl=yt-dy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,tt,2) c i1=jc(iptr) i2=jc(iptr+1)-1 do i=i1,i2 yy=yt-dfloat(i-i1+2)*dy c c square icon c x(1)=xl+0.25d0*dx x(2)=x(1)+h x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=yy y(2)=yy y(3)=yy+h y(4)=y(3) y(5)=y(1) do j=1,5 z(j)=zshift enddo ii=ccolor(mcic(i),0,jp) call pfill(x,y,z,4,ii) call pline(x,y,z,5,2) c c label c call fstr(ichr,nchr,label(i),0) xxl=xl+2.25d0*dx xxr=xxl+20.0d0*dx yyl=yy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,20,ichr,-1,q,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine legnd7(jp,pstat) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor double precision + t(25),q(3,3),sfact(4),x(500),y(500),z(500),sr(10), 1 pstat(10,*) character*80 + ichr,label(2) save label data label/'triangles','error'/ c c graph error c ipix=jp(7) nproc=jp(23) if(ipix.eq.1) then jbeg=3 jend=4 else jbeg=5 jend=6 endif smx=0.0d0 smn=0.0d0 s2=dlog(2.0d0) do j=jbeg,jend sr(j)=0.0d0 do i=1,nproc sr(j)=sr(j)+pstat(j,i) if(pstat(j,i).le.0) return enddo sr(j)=dfloat(nproc)/sr(j) do i=1,nproc ss=dlog(pstat(j,i)*sr(j))/s2 smx=dmax1(smx,ss) smn=dmin1(smn,ss) enddo enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8d0/dsqrt(2.0d0) sfact(2)=0.8d0 sfact(3)=0.6d0 sfact(4)=0.6d0 c c set up input arrays c h=0.025d0 h2=h/2.0d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=idint(smn) if(smn.lt.dfloat(imin)) imin=imin-1 imax=idint(smx) if(smx.gt.dfloat(imax)) imax=imax+1 if(jmax-jmin.le.12) then ix=1 else if(jmax-jmin.le.40) then jmax=jmin+((jmax-jmin-1)/4)*4+4 numx=(jmax-jmin)/4+1 ix=4 else ix=((jmax-jmin-1)/100+1)*10 jmax=jmin+((jmax-jmin-1)/ix)*ix+ix numx=(jmax-jmin)/ix+1 endif if(imax-imin.le.6) then numy=imax-imin+1 iy=1 else if(imax-imin.le.40) then imax=imin+((imax-imin-1)/4)*4+4 numy=(imax-imin)/4+1 iy=4 else iy=((imax-imin-1)/100+1)*10 imax=imin+((imax-imin-1)/iy)*iy+iy numy=(imax-imin)/iy+1 endif c c banner c yyl=yr+1.2d0*h yyr=yyl+h ym=yyl+h2 hx=(xr-xl)/2.0d0 do j=1,2 call fstr(ichr,nchr,label(j),0) ichr(nchr+1:nchr+1)=' ' xxl=xl+dfloat(j-1)*hx xxr=xxl+dfloat(nchr)*h xxm=xxr+h dxm=h*1.5d0 dym=h*1.5d0 icolor=ccolor(1,0,jp) itype=j+2 call symbl(xxm,ym,dxm,dym,itype,icolor,t) call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy) c c graph c dx=(xr-xl)/dfloat(jmax-jmin) dy=(yr-yl)/dfloat(imax-imin) do j=jbeg,jend itype=j-jbeg+3 hh=h*sfact(itype)*2.0d0 do i=1,nproc xs=xl+dx*dfloat(i) ss=dlog(pstat(j,i)*sr(j))/s2 ys=yl+dy*(ss-dfloat(imin)) x(i)=xs*size+xshift y(i)=ys*size+yshift z(i)=zshift icolor=ccolor(i,0,jp) call symbl(xs,ys,hh,hh,itype,icolor,t) enddo if(nproc.gt.1) call pline(x,y,z,nproc,2) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function fscale(f,iscale,invrse) c implicit double precision (a-h,o-z) implicit integer (i-n) c c set scaling function c if(iscale.eq.0) then c c linear scale c fscale=f return else if(iscale.eq.1) then c c log scale c if(invrse.eq.0) then fscale=dlog(f) return else fscale=dexp(f) return endif else c c arcsinh scale c if(invrse.eq.0) then af=dabs(f) if(af.lt.1.0d0) then q=dsqrt(1.0d0+f*f)+af fx=dlog(q) fscale=fx+(af-dsinh(fx))/dcosh(fx) else q=1.0d0/f q=dsqrt(1.0d0+q*q)+1.0d0 fscale=dlog(q)+dlog(af) endif if(f.lt.0.0d0) fscale=-fscale return else fscale=dsinh(f) return endif endif end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dgrid c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(6),y(6),z(6),tt(25),q(3,3) c c helps locating current window (draw boundary in small window) c call linit(tt,q) zshift=1.0d0 size=tt(14) x0=tt(15)-size/2.0d0 x1=tt(15)+size/2.0d0 y0=tt(16)-size/2.0d0 y1=tt(16)+size/2.0d0 c c mark magnified area c icolor=1 z(1)=zshift z(2)=zshift h=size/20.0d0 do i=1,10 x(1)=x0+dfloat(2*i-1)*h x(2)=x(1) y(1)=y0 y(2)=y1 call pline(x,y,z,2,icolor) x(1)=x0 x(2)=x1 y(1)=y0+dfloat(2*i-1)*h y(2)=y(1) call pline(x,y,z,2,icolor) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine vlabel(jp,itnode,vx,vy,rad,vtype,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),index(3,3),vtype(*) double precision + t(25),vx(*),vy(*),rad(*),q(3,3) character*80 + ichr save index data index/1,2,3,2,3,1,3,1,2/ c c print vertex number c ntf=jp(1) nvf=jp(2) nbf=jp(3) numbrs=jp(21) scale=t(3) c rmax=0.05d0/scale do i=1,nvf rad(i)=rmax enddo c do it=1,ntf do j=1,3 j1=itnode(index(2,j),it) j2=itnode(index(3,j),it) h=dsqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2)/2.1d0 rad(j1)=dmin1(h,rad(j1)) rad(j2)=dmin1(h,rad(j2)) enddo enddo c do k=1,nvf xc=vx(k) yc=vy(k) r=rad(k) c if(numbrs.eq.8) then kk=vtype(k) else kk=k endif call sint(ichr,nchr,kk) ratio=dfloat(nchr)*20.0d0/21.0d0 delta=r/dsqrt(1.0d0+ratio*ratio) x1=xc-ratio*delta x2=xc+ratio*delta y1=yc-delta y2=yc+delta c call htext(x1,y1,x2,y2,nchr,ichr,0,q,t,2) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine blabel(jp,itnode,ibndry,ibedge,vx,vy,xm,ym,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ibndry(6,*),itnode(5,*),ibedge(2,*),index(3,3) double precision + t(25),vx(*),vy(*),q(3,3),xm(*),ym(*) character*80 + ichr save index data index/1,2,3,2,3,1,3,1,2/ c c print edge numbers or midpoint numbers c nbf=jp(3) numbrs=jp(21) scale=t(3) c c find local h for vertices c rmax=0.05d0/scale do 20 ib=1,nbf r=rmax do k=1,2 if(ibedge(k,ib).ne.0) then it=ibedge(k,ib)/4 j=ibedge(k,ib)-4*it i1=itnode(j,it) i2=itnode(index(2,j),it) i3=itnode(index(3,j),it) x2=vx(i2)-vx(i1) y2=vy(i2)-vy(i1) x3=vx(i3)-vx(i1) y3=vy(i3)-vy(i1) d1=dsqrt((x2-x3)**2+(y2-y3)**2)/2.5d0 d2=dsqrt((x2+x3)**2+(y2+y3)**2)/5.0d0 r=dmin1(d1,d2,r) endif enddo c c j1=ibndry(1,ib) j2=ibndry(2,ib) jm=ibndry(3,ib) c i=ib if(numbrs.eq.4) i=jm if(numbrs.eq.5) i=ibndry(4,ib) if(numbrs.eq.6) i=ibndry(6,ib) if(jm.gt.0) then call midpt(vx(j1),vy(j1),vx(j2), + vy(j2),xm(jm),ym(jm),xc,yc) else if(numbrs.eq.4) go to 20 xc=(vx(j1)+vx(j2))/2.0d0 yc=(vy(j1)+vy(j2))/2.0d0 endif c call sint(ichr,nchr,i) ratio=dfloat(nchr)*20.0d0/21.0d0 delta=r/dsqrt(1.0d0+ratio*ratio) x1=xc-ratio*delta x2=xc+ratio*delta y1=yc-delta y2=yc+delta call htext(x1,y1,x2,y2,nchr,ichr,0,q,t,2) 20 continue c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tlabel(jp,itnode,vx,vy,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jp(25) double precision + vx(*),vy(*),q(3,3),t(25) character*80 + ichr c ntf=jp(1) scale=t(3) c rmax=0.05d0/scale c do it=1,ntf c c compute center of inscribed circle c call incirc(vx(itnode(1,it)),vy(itnode(1,it)), + vx(itnode(2,it)),vy(itnode(2,it)), 1 vx(itnode(3,it)),vy(itnode(3,it)),xc,yc,r) r=dmin1(rmax,r) c c compute number width (max 10 digits) c call sint(ichr,nchr,it) ratio=dfloat(nchr)*20.0d0/21.0d0 delta=r/dsqrt(1.0d0+ratio*ratio) x1=xc-ratio*delta x2=xc+ratio*delta y1=yc-delta y2=yc+delta c call htext(x1,y1,x2,y2,nchr,ichr,0,q,t,2) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rlabel(jp,itnode,jt,vx,vy,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jp(25),jt(*) double precision + vx(*),vy(*),q(3,3),t(25) character*80 + ichr c ntf=jp(8) scale=t(3) c rmax=0.05d0/scale c do irgn=1,ntf c c compute center of inscribed circle c xc=0.0d0 yc=0.0d0 r=0.0d0 it1=jt(irgn) it2=jt(irgn+1)-1 do it=it1,it2 call incirc(vx(itnode(1,it)),vy(itnode(1,it)), + vx(itnode(2,it)),vy(itnode(2,it)), 1 vx(itnode(3,it)),vy(itnode(3,it)),xcc,ycc,rr) if(rr.gt.r) then r=rr xc=xcc yc=ycc endif enddo r=dmin1(rmax,r) c c compute number width (max 10 digits) c call sint(ichr,nchr,irgn) ratio=dfloat(nchr)*20.0d0/21.0d0 delta=r/dsqrt(1.0d0+ratio*ratio) x1=xc-ratio*delta x2=xc+ratio*delta y1=yc-delta y2=yc+delta call htext(x1,y1,x2,y2,nchr,ichr,0,q,t,2) c enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dlabel(jp,itnode,xc,yc,r,vx,vy,q,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jp(25) double precision + vx(*),vy(*),q(3,3),t(25),xc(*),yc(*),r(*) character*80 + ichr c ntf=jp(1) nproc=jp(23) scale=t(3) c rmax=0.05d0/scale c do i=1,nproc r(i)=-1.0d0 enddo do i=1,ntf call incirc(vx(itnode(1,i)),vy(itnode(1,i)), + vx(itnode(2,i)),vy(itnode(2,i)), 1 vx(itnode(3,i)),vy(itnode(3,i)),xcc,ycc,rr) irgn=itnode(4,i) if(rr.gt.r(irgn)) then r(irgn)=rr xc(irgn)=xcc yc(irgn)=ycc endif enddo do irgn=1,nproc c c compute center of inscribed circle c r(irgn)=dmin1(rmax,r(irgn)) c c compute number width (max 10 digits) c call sint(ichr,nchr,irgn) ratio=dfloat(nchr)*20.0d0/21.0d0 delta=r(irgn)/dsqrt(1.0d0+ratio*ratio) x1=xc(irgn)-ratio*delta x2=xc(irgn)+ratio*delta y1=yc(irgn)-delta y2=yc(irgn)+delta call htext(x1,y1,x2,y2,nchr,ichr,0,q,t,2) c enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine title0(title,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + t(25),q(3,3) character*80 + title character*80 + ichr c c draw the title for the picture c call linit(t,q) size=t(14) xl=t(15)-size/2.0d0 xr=t(15)+size/2.0d0 if(isw.eq.1) xr=xr+0.5d0 yb=t(16)+size/2.0d0 yt=t(16)+t(3)/2.0d0 yl=yb+(yt-yb)*0.25d0 yr=yb+(yt-yb)*0.75d0 call fstr(ichr,nchr,title,0) call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine gphplt(ip,rp,sp,w) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),jp(25) double precision + w(*),red(10),green(10),blue(10),rp(100) character*80 + sp(100) c c storage allocation c if(ip(5).ne.0) then call stor(ip) endif c ip(25)=0 c c array pointers...in the order that they c occur in the w array c iuu=ip(83) iux=ip(84) iuy=ip(85) iu0=ip(86) iudot=ip(87) iu0dot=ip(88) iudl=ip(89) ievr=ip(90) ievl=ip(91) jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) c do i=1,25 jp(i)=0 enddo lenw=ip(20) iprob=iabs(ip(6)) mxcolr=max0(2,ip(51)) igrsw=ip(54) if(iabs(igrsw).gt.6) igrsw=0 c mpisw=ip(48) nproc=ip(49) irgn=ip(50) jp(1)=ip(1) jp(2)=nproc jp(3)=irgn c c******************************* c c ip(29) is used for debugging on one processor c ccc jp(2)=ip(29) c******************************* jp(4)=1 jp(5)=6 jp(7)=iprob jp(17)=mxcolr jp(18)=min0(mxcolr,jp(5)+2) jp(10)=igrsw jp(11)=ip(75) jp(12)=mpisw c jp(13)=ip(64) jp(14)=ip(65) jp(15)=ip(66) c c extra memory c ibegin=iz iend=lenw call memptr(iatim,150,'head',ibegin,iend,iflag) call memptr(iptim,2*nproc,'head',ibegin,iend,iflag) if(mpisw.eq.1) then if(iabs(igrsw).eq.2) call extim(w(jtime),w(iatim),w(iptim)) if(igrsw.eq.-3) call exstat(w(jstat),w(iptim)) if(irgn.ne.1) return endif c call clrmap(red,green,blue,jp) c call pltutl(jp(18),red,green,blue) c call pgraph(jp,w(jhist),w(jtime),w(jpath),w(jstat), + w(ka),ip,rp,sp,w(iatim),w(iptim)) c call pltutl(-1,red,green,blue) sp(11)='gphplt: ok' ip(25)=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pgraph(jp,hist,time,path,pstat,ka,ip,rp,sp, + atime,ptime) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ip(100),ka(10,*) double precision + hist(22,*),time(3,*),path(101,*),rp(100),pstat(10,*), 1 atime(3,*),ptime(*) character*80 + sp(100) save len data len/50/ c c output graphs c iprob=jp(7) igrsw=jp(10) mpisw=jp(12) c c newton, mg historry, ilu statistics c if(iabs(igrsw).le.1) then call pframe(4) call title0(sp(3),0) if(igrsw.eq.0) call nwtplt(hist(1,11),jp) if(igrsw.eq.1) call hbplt(hist(1,7),4,1,jp) if(igrsw.eq.-1) call kaplt(ka,jp) call pframe(-4) c call pframe(2) if(igrsw.ne.1) then call hbplt(hist(1,7),4,1,jp) else call kaplt(ka,jp) endif call pframe(-2) c call pframe(3) if(igrsw.ne.0) then call nwtplt(hist(1,11),jp) else call kaplt(ka,jp) endif call pframe(-3) c c timing statistics c else if(iabs(igrsw).eq.2) then if(mpisw.ne.1) then do i=1,len atime(1,i)=time(1,i) atime(2,i)=time(2,i) atime(3,i)=time(3,i) enddo endif c call pframe(4) call title0(sp(3),0) if(igrsw.eq.2) call timplt(atime,jp) if(igrsw.eq.-2) call pieplt(atime,jp) call pframe(-4) c call pframe(2) if(igrsw.eq.2) call pieplt(atime,jp) if(igrsw.eq.-2) call subplt(atime,jp) call pframe(-2) c call pframe(3) if(mpisw.eq.1) then call aveplt(ptime,jp) else call nwtplt(hist(1,11),jp) endif call pframe(-3) c c continuation path / time step history c else if(igrsw.eq.3) then if(iprob.eq.3.or.iprob.eq.6) then call pframe(4) call title0(sp(3),0) if(iprob.eq.3) call pthplt(jp,path) if(iprob.eq.6) call tmhist(jp,path,1) call pframe(-4) else if(iprob.eq.2.or.iprob.eq.4.or.iprob.eq.5) then call pframe(5) call title0(sp(3),0) call ipmplt(jp,path) call pframe(-5) endif c call pframe(2) if(iprob.eq.3) call legnd6(jp,2) if(iprob.eq.2) call legnd6(jp,4) if(iprob.eq.4) call legnd6(jp,4) if(iprob.eq.5) call legnd6(jp,4) if(iprob.eq.6) call legnd6(jp,3) call pframe(-2) c call pframe(3) if(iprob.eq.3) call hbplt(hist(1,14),1,2,jp) if(iprob.eq.6) call tmhist(jp,path,2) call pframe(-3) c c load balance c else if(igrsw.eq.-3) then call pframe(4) call title0(sp(3),0) if(mpisw.eq.1) then call lbplt(jp,pstat,1) else call lbplt(jp,pstat,2) endif call pframe(-4) c call pframe(2) call lbplt(jp,pstat,0) call pframe(-2) c call pframe(3) call hbplt(hist(1,23),4,3,jp) call pframe(-3) c c error estimates c else if(iabs(igrsw).eq.4) then call pframe(4) call title0(sp(3),0) call pframe(-4) c i1=(12-igrsw)/8 i2=3-i1 call pframe(5) call errplt(hist,i1,jp) call pframe(-5) c call pframe(2) call legnd6(jp,1) call pframe(-2) c call pframe(3) call errplt(hist,i2,jp) call pframe(-3) c c ip, rp, sp, ka arrays c else if(iabs(igrsw).ge.5.and.iabs(igrsw).le.6) then call pframe(1) call title0(sp(3),1) if(igrsw.eq.5) call prtip(ip,jp) if(igrsw.eq.-5) call prtsp(sp,jp) if(igrsw.eq.6) call prtrp(rp,jp) if(igrsw.eq.-6) call prtka(ka,jp) call pframe(-1) endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine prtip(ip,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),jp(25),ccolor,icolor(3),ic(100) double precision + t(25),q(3,3) character*15 + name0(300),name(100) character*80 + ichr c c print ip array c call linit(t,q) mxcolr=jp(17) if(mxcolr.ge.8) then icolor(1)=2 icolor(2)=ccolor(2,0,jp) icolor(3)=ccolor(6,0,jp) else icolor(1)=2 icolor(2)=2 icolor(3)=2 endif call getnam(name0,nlen) do i=1,100 name(i)=' ' ic(i)=icolor(1) call sint(ichr,length,i) name(i)(4-length:3)=ichr(1:length) enddo do i=1,nlen if(name0(i)(15:15).eq.'i') then call cint(name0(i),3,indx,jerr) name(indx)(4:10)=name0(i)(4:10) if(name0(i)(12:13).eq.' ') then ic(indx)=icolor(2) else ic(indx)=icolor(3) endif endif enddo c size=t(14) dy=size/25.0d0 dx=(size+0.5d0)/4.0d0 h=dmin1(dy*0.9d0,dx/20.0d0) c do i=1,25 do j=1,4 k=(j-1)*25+i xl=dfloat(j-1)*dx+.05d0+dx/10.0d0 xr=xl+dx/2.0d0 yl=0.95d0-(dfloat(i)*dy) yr=yl+h call htext(xl,yl,xr,yr,10,name(k),-1,q,t,ic(k)) xl=xl+dx/2.0d0 xr=xl+3.0d0*dx/10.0d0 ichr=' ' call sint(ichr(6:6),nchr,ip(k)) m=min0(nchr,6) nchr=max0(6,nchr) call htext(xl,yl,xr,yr,nchr,ichr(m:m),1,q,t,ic(k)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine prtrp(rp,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,icolor(3),ic(100) double precision + t(25),q(3,3),rp(100) character*15 + name0(300),name(100) character*80 + ichr c c print rp array c call linit(t,q) mxcolr=jp(17) if(mxcolr.ge.8) then icolor(1)=2 icolor(2)=ccolor(2,0,jp) icolor(3)=ccolor(6,0,jp) else icolor(1)=2 icolor(2)=2 icolor(3)=2 endif call getnam(name0,nlen) do i=1,100 name(i)=' ' ic(i)=icolor(1) call sint(ichr,length,i) name(i)(4-length:3)=ichr(1:length) enddo do i=1,nlen if(name0(i)(15:15).eq.'r') then call cint(name0(i),3,indx,jerr) name(indx)(4:10)=name0(i)(4:10) if(name0(i)(12:13).eq.' ') then ic(indx)=icolor(2) else ic(indx)=icolor(3) endif endif enddo c size=t(14) dy=size/25.0d0 dx=(size+0.5d0)/4.0d0 h=dmin1(dy*0.9d0,dx/20.0d0) c do i=1,25 do j=1,4 k=(j-1)*25+i xl=dfloat(j-1)*dx+.05d0+dx/22.0d0 xr=xl+10.0d0*dx/22.0d0 yl=0.95d0-(dfloat(i)*dy) yr=yl+h call htext(xl,yl,xr,yr,10,name(k),-1,q,t,ic(k)) xl=xr+dx/22.0d0 xr=xl+9.0d0*dx/22.0d0 ichr=' ' call sreal(ichr(9:9),nchr,rp(k),3,0) m=min0(nchr,9) nchr=max0(9,nchr) call htext(xl,yl,xr,yr,nchr,ichr(m:m),1,q,t,ic(k)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine prtsp(sp,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,icolor(3),ic(100) double precision + t(25),q(3,3) character*15 + name0(300),name(100) character*80 + ichr,sp(100) c c print sp array c call linit(t,q) mxcolr=jp(17) if(mxcolr.ge.8) then icolor(1)=2 icolor(2)=ccolor(2,0,jp) icolor(3)=ccolor(6,0,jp) else icolor(1)=2 icolor(2)=2 icolor(3)=2 endif call getnam(name0,nlen) do i=1,100 name(i)=' ' ic(i)=icolor(1) call sint(ichr,length,i) name(i)(4-length:3)=ichr(1:length) enddo do i=1,nlen isw=1 if(name0(i)(15:15).eq.'r') isw=0 if(name0(i)(15:15).eq.'i') isw=0 if(isw.eq.1) then call cint(name0(i),3,indx,jerr) name(indx)(4:10)=name0(i)(4:10) if(name0(i)(12:13).eq.' ') then ic(indx)=icolor(2) else ic(indx)=icolor(3) endif endif enddo c size=t(14) dy=size/25.0d0 dx=(size+0.5d0)/4.0d0 h=dmin1(dy*0.9d0,dx/20.0d0) c do i=1,25 do j=1,2 k=(j-1)*25+i xl=dfloat(j-1)*dx*2.0d0+.05d0+dx/10.0d0 xr=xl+dx/2.0d0 yl=0.95d0-(dfloat(i)*dy) yr=yl+h call htext(xl,yl,xr,yr,10,name(k),-1,q,t,ic(k)) xl=xl+dx/2.0d0 xr=xl+1.5d0*dx call fstr(ichr,nchr,sp(k),0) if(nchr.gt.0) + call htext(xl,yl,xr,yr,nchr,ichr,-1,q,t,ic(k)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine prtka(ka,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ka(10,*),list(8),total(8),jp(25) double precision + t(25),q(3,3) character*80 + ichr,name(8) save name data name/'level',' n ','lenja','lena ','lenju','lenu ', + 'lenvf','lenwt'/ c c print ip array c lvl=jp(11) call linit(t,q) dy=0.9d0/25.0d0 dx=1.4d0/8.0d0 h=dmin1(dy*0.6d0,dx/8.0d0) c xl=.05d0 xr=xl+dx yl=0.95d0-dy yr=yl+h do k=1,8 total(k)=0 call fstr(ichr,nchr,name(k),0) call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,2) xl=xr xr=xr+dx enddo do i=1,lvl xl=.05d0 xr=xl+dx yl=0.95d0-(dfloat(i+1)*dy) yr=yl+h list(1)=lvl+1-i list(2)=ka(1,i) list(3)=ka(10,i)-ka(3,i) list(4)=ka(6,i)-ka(4,i) if(ka(5,i).eq.ka(3,i)) then list(5)=list(3) else list(5)=ka(7,i)-ka(5,i) endif list(6)=ka(8,i)-ka(6,i) if(ka(6,i).eq.ka(4,i)) then list(4)=list(6) endif kk=6 if(i.lt.lvl) then list(7)=ka(3,i+1)-ka(7,i) list(8)=ka(4,i+1)-ka(8,i) kk=8 else list(7)=0 list(8)=0 endif do k=2,8 total(k)=total(k)+list(k) enddo do k=1,kk call sint(ichr,nchr,list(k)) call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,2) xl=xr xr=xr+dx enddo enddo c c totals c xl=.05d0+2.0d0*dx xr=xl+dx yl=0.95d0-(dfloat(lvl+2)*dy) yr=yl+h icolor=jp(18) do k=3,8 call sint(ichr,nchr,total(k)) call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,icolor) xl=xr xr=xr+dx enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine lbplt(jp,pstat,ipix) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(8),ccolor double precision + t(25),q(3,3),sfact(4),x(500),y(500),z(500),sr(10), 1 pstat(10,*) character*80 + ichr,label(2) save label data label/'triangles','error'/ c c graph error c ntf=jp(1) if(ntf.le.0) return nproc=jp(2) if(ipix.eq.1) then jbeg=3 jend=4 else if(ipix.eq.2) then jbeg=5 jend=6 else jbeg=1 jend=2 endif smx=0.0d0 smn=0.0d0 s2=dlog(2.0d0) do j=jbeg,jend sr(j)=0.0d0 do i=1,nproc sr(j)=sr(j)+pstat(j,i) if(pstat(j,i).le.0) return enddo sr(j)=dfloat(nproc)/sr(j) do i=1,nproc ss=dlog(pstat(j,i)*sr(j))/s2 smx=dmax1(smx,ss) smn=dmin1(smn,ss) enddo enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8d0/dsqrt(2.0d0) sfact(2)=0.8d0 sfact(3)=0.6d0 sfact(4)=0.6d0 c icolor(1)=ccolor(5,0,jp) icolor(2)=ccolor(3,0,jp) icolor(3)=ccolor(4,0,jp) icolor(4)=ccolor(6,0,jp) icolor(5)=ccolor(2,0,jp) icolor(6)=ccolor(1,0,jp) c c set up input arrays c h=0.025d0 h2=h/2.0d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=idint(smn) if(smn.lt.dfloat(imin)) imin=imin-1 imax=idint(smx) if(smx.gt.dfloat(imax)) imax=imax+1 if(jmax-jmin.le.12) then ix=1 else if(jmax-jmin.le.40) then jmax=jmin+((jmax-jmin-1)/4)*4+4 numx=(jmax-jmin)/4+1 ix=4 else ix=((jmax-jmin-1)/100+1)*10 jmax=jmin+((jmax-jmin-1)/ix)*ix+ix numx=(jmax-jmin)/ix+1 endif if(imax-imin.le.6) then numy=imax-imin+1 iy=1 else if(imax-imin.le.40) then imax=imin+((imax-imin-1)/4)*4+4 numy=(imax-imin)/4+1 iy=4 else iy=((imax-imin-1)/100+1)*10 imax=imin+((imax-imin-1)/iy)*iy+iy numy=(imax-imin)/iy+1 endif c c banner c yyl=yr+1.2d0*h yyr=yyl+h ym=yyl+h2 hx=(xr-xl)/3.5d0 do j=1,2 call fstr(ichr,nchr,label(j),0) ichr(nchr+1:nchr+1)=' ' xxl=xl+dfloat(j-1)*hx xxr=xxl+dfloat(nchr)*h xxm=(xxl+xxr)/2.0d0 dxm=xxr-xxl dym=2.0d0*h call symbl(xxm,ym,dxm,dym,1,icolor(jbeg+j-1),t) call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy) c c graph c dx=(xr-xl)/dfloat(jmax-jmin) dy=(yr-yl)/dfloat(imax-imin) do j=jbeg,jend itype=1 hh=h*sfact(itype) do i=1,nproc xs=xl+dx*dfloat(i) ss=dlog(pstat(j,i)*sr(j))/s2 ys=yl+dy*(ss-dfloat(imin)) x(i)=xs*size+xshift y(i)=ys*size+yshift z(i)=zshift call symbl(xs,ys,hh,hh,itype,icolor(j),t) enddo if(nproc.gt.1) call pline(x,y,z,nproc,2) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine timplt(time,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,icolor(2),jcolor(2),map(50),mcic(10), 1 iptr(10),order(10) double precision + time(3,*),x(5),y(5),z(5),t(25),q(3,3),t0(2,50) character*80 + ichr,name(36),label(2),name0(50),lab0(10) save label,order data label/'last call','accumulated'/ data order/1,2,3,6,5,4,7,8,9,10/ c c print time statistics c call timdat(num0,name0,map,ll,lab0,mcic) call linit(t,q) mxcolr=jp(17) if(mxcolr.ge.8) then icolor(1)=ccolor(6,0,jp) icolor(2)=ccolor(2,0,jp) jcolor(1)=icolor(1) jcolor(2)=icolor(2) else icolor(1)=ccolor(mxcolr-2,0,jp) if(mxcolr.eq.4) then icolor(2)=ccolor(1,0,jp) else icolor(2)=ccolor(2,0,jp) endif jcolor(1)=2 jcolor(2)=2 endif size=t(14) zshift=t(5) xx=t(15)-size/2.0d0 yy=t(16)-size/2.0d0 c do i=1,ll+1 iptr(i)=0 enddo do i=1,num0 if(time(2,i).gt.0.0d0) then k=order(map(i))+1 iptr(k)=iptr(k)+1 endif enddo iptr(1)=1 do i=2,ll+1 iptr(i)=iptr(i)+iptr(i-1) enddo c s1=0.0d0 s2=0.0d0 do i=1,num0-1 if(time(2,i).gt.0.0d0) then k=order(map(i)) name(iptr(k))=name0(i) t0(1,iptr(k))=time(1,i) t0(2,iptr(k))=time(2,i) s1=s1+time(1,i) s2=s2+time(2,i) iptr(k)=iptr(k)+1 endif enddo do i=ll,2,-1 iptr(i)=iptr(i-1) enddo iptr(1)=1 c num=iptr(ll+1) name(num)=name0(num0) t0(1,num)=s1 t0(2,num)=s2 if(s2.eq.0.0d0) return ss=1.0d0/dabs(s2) c xxl=xx xxr=xx+size yyb=yy yyt=yy+size dx=(xxr-xxl)/4.3d0 dy=(yyt-yyb)/(dfloat(num)+3.75d0) h=size/43.0d0 h2=h/2.0d0 c c banner c yl=yyt-dy yr=yl+h ym=yl+h2 hx=(xxr-xxl)/4.0d0 do j=1,2 call fstr(ichr,nchr,label(j),0) xl=xxl+dfloat(j-1)*hx xr=xl+dfloat(nchr)*h xm=xr+h2 call symbl(xm,ym,h,h,1,icolor(j),t) call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,2) enddo c c horizontal axis c do i=1,5 z(i)=zshift enddo x(1)=xxl+2.2d0*dx x(2)=xxr x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=yyt-(dfloat(num)+1.75d0)*dy y(2)=y(1) y(3)=yyt-1.75d0*dy y(4)=y(3) y(5)=y(1) call pline(x,y,z,5,2) dd=(xxr-xxl-2.2d0*dx)/5.0d0 do i=1,6 k=(i-1)*20 call sint(ichr,nchr,k) x(1)=xxl+2.2d0*dx+dfloat(i-1)*dd x(2)=x(1) y(1)=yyt-(dfloat(num)+1.75d0)*dy y(2)=y(1)-0.02d0*size call pline(x,y,z,2,2) xl=x(1)-dfloat(nchr)*h/2.0d0 xr=x(1)+dfloat(nchr)*h/2.0d0 yl=y(2)-2.0d0*h yr=y(2)-h call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,2) enddo c do 10 i=1,num c c names c call fstr(ichr,nchr,name(i),0) xl=xxl xr=xl+0.6d0*dx yl=yyt-dfloat(i+1)*dy-0.75d0*dy yr=yl+h call htext(xl,yl,xr,yr,6,ichr,-1,q,t,2) if(dmax1(t0(1,i),t0(2,i)).le.0.0d0) go to 10 c c times c do 5 k=1,2 xl=xr+0.05d0*dx xr=xl+0.7d0*dx if(t0(k,i).le.0.0d0) go to 5 ichr=' ' if(t0(k,i).gt.10.0d0) then ii=idint(dlog10(t0(k,i)))+2 else ii=2 endif call sfix(ichr(6:6),nchr,t0(k,i),ii) if(nchr.lt.8) then ii=nchr-2 nchr=8 else ii=6 endif call htext(xl,yl,xr,yr,nchr,ichr(ii:ii),1,q,t,jcolor(k)) 5 continue c c histogram c do k=2,1,-1 if(t0(k,i).gt.0.0d0) then xp=xr+0.1d0*dx if(k.eq.1) then x(1)=xp else x(1)=xp+t0(k-1,i)*(xxr-xp)*ss endif x(2)=xp+t0(k,i)*(xxr-xp)*ss x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=yl y(2)=y(1) y(3)=yl+dy y(4)=y(3) y(5)=y(1) call pfill(x,y,z,4,icolor(k)) call pline(x,y,z,5,2) endif enddo 10 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine timpl0(time,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(50),ccolor,map(50),mcic(10),iptr(8), 1 order(7) double precision + t(25),q(3,3),time(3,*),tim1(50),tim2(50) character*80 + ichr,label(10),name(50),name0(50) save order data order/1,2,3,6,5,4,7/ c c graph times c call timdat(len0,name0,map,num,label,mcic) len0=len0-1 call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 t(1)=xshift t(2)=yshift t(3)=size c c set up input arrays c do i=1,num+1 iptr(i)=0 enddo do i=1,len0 if(time(2,i).gt.0.0d0) then k=order(map(i))+1 iptr(k)=iptr(k)+1 endif enddo iptr(1)=1 do i=2,num+1 iptr(i)=iptr(i)+iptr(i-1) enddo tot2=0.0d0 tot1=0.0d0 do i=1,len0 if(time(2,i).gt.0.0d0) then k=order(map(i)) name(iptr(k))=name0(i) tim1(iptr(k))=time(1,i) tim2(iptr(k))=time(2,i) icolor(iptr(k))=ccolor(mcic(map(i)),0,jp) tot1=tot1+time(1,i) tot2=tot2+time(2,i) iptr(k)=iptr(k)+1 endif enddo do i=num,2,-1 iptr(i)=iptr(i-1) enddo iptr(1)=1 len=iptr(num+1) name(len)=name0(len0+1) icolor(len)=2 tim1(len)=tot1 tim2(len)=tot2 if(tot2.le.0.0d0) return c xl=t(15)-size/2.0d0 yt=t(16)+size/2.0d0 hf=dmax1(24.0d0,dfloat(len+10)) h=size/hf ss=dmin1(hf/dfloat(len+1),4.0d0) dx=(size-4.0d0*h)/5.0d0 do i=1,len yyl=yt-h*dfloat(i)*ss yyr=yyl+h xm=xl+h/2.0d0 ym=yyl+h/2.0d0 call symbl(xm,ym,h,h,1,icolor(i),t) call fstr(ichr,nchr,name(i),0) xxl=xl+h*1.5d0 xxr=xxl+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) c tm=tim1(i) if(tm.gt.0.0d0) then k=2 if(tm.gt.10.0d0) k=idint(dlog10(tm))+2 call sfix(ichr,nchr,tm,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) c fr=tim1(i)/tot2*100.0d0 k=1 if(fr.ge.10.0d0) k=2 call sfix(ichr,nchr,fr,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) else xxr=xxr+2.0d0*dx endif c tm=tim2(i) k=2 if(tm.gt.10.0d0) k=idint(dlog10(tm))+2 call sfix(ichr,nchr,tm,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) c fr=tim2(i)/tot2*100.0d0 k=1 if(fr.ge.10.0d0) k=2 call sfix(ichr,nchr,fr,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) c xm=xxr+h*1.5d0 ym=yyl+h/2.0d0 call symbl(xm,ym,h,h,1,icolor(i),t) c enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pieplt(time,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(20),ccolor,map(50),mcic(10) double precision + t(25),q(3,3),time(3,*),th(21),dt(20),x(90),y(90),z(90), 1 tim(20) character*80 + ichr,label(10),name(50) c c graph times c call timdat(len,name,map,num,label,mcic) len=len-1 call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 t(1)=xshift t(2)=yshift t(3)=size zshift=t(5) scale=t(3) c c set up input arrays c do i=1,num icolor(i)=ccolor(mcic(i),0,jp) tim(i)=0.0d0 enddo do i=1,len tim(map(i))=tim(map(i))+time(2,i) enddo tot=0.0d0 do i=1,num tot=tot+tim(i) enddo if(tot.le.0.0d0) return pi=3.141592653589793d0 th(1)=pi/2.0d0 do i=1,num fr=tim(i)/tot dt(i)=fr*2.0d0*pi th(i+1)=th(i)+dt(i) enddo c c make pie chart c xcen=0.5d0 ycen=0.4d0 rad=0.35d0 dd=pi/32.0d0 do i=1,num m=idint(dt(i)/dd) x(1)=xcen*scale+xshift y(1)=ycen*scale+yshift z(1)=zshift dtheta=dt(i)/dfloat(m+1) theta=th(i) do j=1,m+2 ang=theta+dtheta*dfloat(j-1) xx=xcen+rad*dcos(ang) yy=ycen+rad*dsin(ang) x(j+1)=xx*scale+xshift y(j+1)=yy*scale+yshift z(j+1)=zshift enddo x(m+4)=x(1) y(m+4)=y(1) z(m+4)=z(1) call pfill(x,y,z,m+3,icolor(i)) call pline(x,y,z,m+4,2) enddo c xl=t(15)-size/2.0d0 yt=t(16)+size/2.0d0 h=size/30.0d0 h=size/27.0d0 mm=num/2 do i=1,mm yyl=yt-h*dfloat(i)*1.5d0 yyr=yyl+h xs=xl xr=t(15) ii=i do j=1,2 xm=xs ym=yyl+h/2.0d0 call symbl(xm,ym,h,h,1,icolor(ii),t) call fstr(ichr,nchr,label(ii),0) xxl=xs+h xxr=xxl+dfloat(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) fr=tim(ii)/tot*100.0d0 k=1 if(fr.ge.10.0d0) k=2 call sfix(ichr,nchr,fr,k) xxr=xr-h if(j.eq.2) xxr=xr xxl=xxr-dfloat(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) xs=t(15)+h xr=t(15)+size/2.0d0 ii=num+1-i enddo enddo c label(num+1)='total time -- ' call fstr(ichr,nchr,label(num+1),0) xxl=xl+h xxr=xxl+dfloat(nchr)*h yyl=yt yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) k=2 if(tot.gt.10.0d0) k=idint(dlog10(tot))+2 call sfix(ichr,nchr,tot,k) ichr(nchr+1:nchr+8)=' seconds' xxl=t(15) xxr=xxl+dfloat(nchr+8)*h call htext(xxl,yyl,xxr,yyr,nchr+8,ichr,-1,q,t,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine subplt(time,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(50),ccolor,map(50),mcic(10),iptr(7) double precision + t(25),q(3,3),time(3,*),tim(50) character*80 + ichr,label(10),name(50),name0(50),nn c c graph times c call timdat(len0,name0,map,num,label,mcic) len0=len0-1 call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 t(1)=xshift t(2)=yshift t(3)=size c c set up input arrays c do i=1,num+1 iptr(i)=0 enddo do i=1,len0 if(time(2,i).gt.0.0d0) iptr(map(i)+1)=iptr(map(i)+1)+1 enddo iptr(1)=1 do i=2,num+1 iptr(i)=iptr(i)+iptr(i-1) enddo tot=0.0d0 do i=1,len0 if(time(2,i).gt.0.0d0) then k=map(i) name(iptr(k))=name0(i) tim(iptr(k))=time(2,i) icolor(iptr(k))=ccolor(mcic(k),0,jp) tot=tot+time(2,i) iptr(k)=iptr(k)+1 endif enddo do i=num,2,-1 iptr(i)=iptr(i-1) enddo iptr(1)=1 if(tot.le.0.0d0) return c mm=num/2 do m=mm+1,num ii=(iptr(m+1)-iptr(m))/2 do i=1,ii i1=i+iptr(m)-1 i2=iptr(m+1)-i nn=name(i1) name(i1)=name(i2) name(i2)=nn tt=tim(i1) tim(i1)=tim(i2) tim(i2)=tt enddo enddo xl=t(15)-size/2.0d0 yt=t(16)+size/2.0d0 hf=24.0d0 h=size/hf mrt=iptr(mm+1)-iptr(1) mlt=iptr(num+1)-iptr(mm+1) mx=max0(mrt,mlt) ss=dmin1(hf/dfloat(mx+1),4.0d0) do i=1,mx yyl=yt-h*dfloat(i)*ss yyr=yyl+h xr=t(15) xs=xl ii=i if(i.ge.iptr(mm+1)) ii=0 do j=1,2 if(ii.gt.0) then xm=xs ym=yyl+h/2.0d0 call symbl(xm,ym,h,h,1,icolor(ii),t) call fstr(ichr,nchr,name(ii),0) xxl=xs+h xxr=xxl+dfloat(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) fr=tim(ii)/tot*100.0d0 k=1 if(fr.ge.10.0d0) k=2 call sfix(ichr,nchr,fr,k) xxr=xr-h if(j.eq.2) xxr=xr xxl=xxr-dfloat(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) endif xs=t(15)+h xr=t(15)+size/2.0d0 ii=iptr(num+1)-i if(ii.lt.iptr(mm+1)) ii=0 enddo c enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine aveplt(ptime,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor double precision + t(25),q(3,3),sfact(4),x(500),y(500),z(500),ptime(*) character*80 + ichr c c graph error c ntf=jp(1) if(ntf.le.0) return nproc=jp(2) tmx=ptime(1) tmn=ptime(1) ave=0.0d0 do i=1,nproc tmx=dmax1(tmx,ptime(i)) tmn=dmin1(tmn,ptime(i)) ave=ave+ptime(i) enddo if(ave.le.0.0d0) return ave=dfloat(nproc)/ave smx=0.0d0 smn=0.0d0 s2=dlog(2.0d0) do i=1,nproc ss=dlog(ptime(i)*ave)/s2 smx=dmax1(smx,ss) smn=dmin1(smn,ss) enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8d0/dsqrt(2.0d0) sfact(2)=0.8d0 sfact(3)=0.6d0 sfact(4)=0.6d0 icolor=ccolor(6,0,jp) c c set up input arrays c h=0.025d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=idint(smn) if(smn.lt.dfloat(imin)) imin=imin-1 imax=idint(smx) if(smx.gt.dfloat(imax)) imax=imax+1 if(jmax-jmin.le.12) then ix=1 else if(jmax-jmin.le.40) then jmax=jmin+((jmax-jmin-1)/4)*4+4 numx=(jmax-jmin)/4+1 ix=4 else ix=((jmax-jmin-1)/100+1)*10 jmax=jmin+((jmax-jmin-1)/ix)*ix+ix numx=(jmax-jmin)/ix+1 endif if(imax-imin.le.6) then numy=imax-imin+1 iy=1 else if(imax-imin.le.40) then imax=imin+((imax-imin-1)/4)*4+4 numy=(imax-imin)/4+1 iy=4 else iy=((imax-imin-1)/100+1)*10 imax=imin+((imax-imin-1)/iy)*iy+iy numy=(imax-imin)/iy+1 endif c c banner c yyl=yr+1.2d0*h yyr=yyl+h xxl=xl ichr(1:4)='min ' val=tmn do j=1,2 if(val.gt.10.0d0) then ii=idint(dlog10(val))+2 else ii=2 endif call sfix(ichr(5:5),nchr,val,ii) nchr=nchr+4 xxr=xxl+dfloat(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) xxl=(xl+xr)/2.0d0 ichr(1:4)='max ' val=tmx enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy) c c graph c dx=(xr-xl)/dfloat(jmax-jmin) dy=(yr-yl)/dfloat(imax-imin) itype=2 hh=h*sfact(itype) do i=1,nproc xs=xl+dx*dfloat(i) ss=dlog(ptime(i)*ave)/s2 ys=yl+dy*(ss-dfloat(imin)) x(i)=xs*size+xshift y(i)=ys*size+yshift z(i)=zshift call symbl(xs,ys,hh,hh,itype,icolor,t) enddo if(nproc.gt.1) call pline(x,y,z,nproc,2) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine timdat(num0,name0,jcat,len0,label0,color0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + icat(50),jcat(*),color(10),color0(*) character*80 + name0(*),label(10),label0(*),name(50) save name,icat,num,len,label,color data num/35/ data name( 1),icat( 1)/'tgen ',2/ data name( 2),icat( 2)/'refine',2/ data name( 3),icat( 3)/'unrefn',2/ data name( 4),icat( 4)/'unifrm',2/ data name( 5),icat( 5)/'mvmesh',2/ data name( 6),icat( 6)/'errest',1/ data name( 7),icat( 7)/'cdlfn ',1/ data name( 8),icat( 8)/'rgen ',2/ data name( 9),icat( 9)/'ldbal ',3/ data name(10),icat(10)/'lbev ',3/ data name(11),icat(11)/'cutr ',3/ data name(12),icat(12)/'paste ',3/ data name(13),icat(13)/'paste1',3/ data name(14),icat(14)/'bcast ',3/ data name(15),icat(15)/'collct',3/ data name(16),icat(16)/'expth ',3/ data name(17),icat(17)/'trigen',2/ data name(18),icat(18)/'mginit',5/ data name(19),icat(19)/'mg ',5/ data name(20),icat(20)/'mgilu ',5/ data name(21),icat(21)/'cev ',4/ data name(22),icat(22)/'linsys',6/ data name(23),icat(23)/'predct',4/ data name(24),icat(24)/'blk3 ',4/ data name(25),icat(25)/'blk4 ',4/ data name(26),icat(26)/'blk5 ',4/ data name(27),icat(27)/'swbrch',4/ data name(28),icat(28)/'tpick ',4/ data name(29),icat(29)/'blk3dd',4/ data name(30),icat(30)/'rgnsys',6/ data name(31),icat(31)/'tpickd',4/ data name(32),icat(32)/'blk4dd',4/ data name(33),icat(33)/'recovr',1/ data name(34),icat(34)/'pltmg ',4/ data name(35),icat(35)/'total ',7/ c data len/6/ data label(1),color(1)/'errors',3/ data label(2),color(2)/'mesh gen', 1/ data label(3),color(3)/'parallel', 5/ data label(4),color(4)/'pltmg', 2/ data label(5),color(5)/'m-graph', 4/ data label(6),color(6)/'assembly', 6/ c num0=num do i=1,num name0(i)=name(i) jcat(i)=icat(i) enddo len0=len do i=1,len label0(i)=label(i) color0(i)=color(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine errplt(hist,igraph,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ic(22),icc(6),ccolor double precision + rn(22),e(22),t(25),q(3,3),x(25),y(25),z(25), 1 xn(25),yn(25),zn(25),hist(22,*) character*80 + ichr,label(4) save label,icc c data label/'error in h1 norm','error in l2 norm', + 'error in lambda ','error in rho '/ data icc/3,4,2,1,6,5/ c c initialize c mxhist=20 call linit(t,q) size=t(14) xx=t(15)-size/2.0d0 yy=t(16)-size/2.0d0 t(1)=xx t(2)=yy t(3)=size c num=idint(hist(mxhist+2,1)) if(num.le.0) return c c set up input arrays c e1=dabs(hist(mxhist+2,igraph+2)) if(e1.gt.0.0d0) e1=1.0d0/e1 do i=1,num rn(i)=dlog10(hist(i,1)) e(i)=0.0d0 qq=dabs(hist(i,igraph+2))*e1 if(qq.gt.0.0d0) e(i)=dlog10(qq) ii=idint(hist(i,2))+2 if(ii.lt.1) ii=1 if(ii.gt.6) ii=6 ic(i)=ccolor(icc(ii),0,jp) enddo c rmx=rn(1) emx=e(1) emn=emx do i=1,num rmx=dmax1(rn(i),rmx) emx=dmax1(e(i),emx) emn=dmin1(e(i),emn) enddo c numx=max0(5,idint(rmx)+2) numy=6 iminz=idint(emn) if(emn.lt.dfloat(iminz)) iminz=iminz-1 imaxz=idint(emx) if(emx.gt.dfloat(imaxz)) imaxz=imaxz+1 if(imaxz-iminz.lt.4) then iminz=iminz-(4+iminz-imaxz)/2 imaxz=iminz+4 endif numz=imaxz-iminz+1 c h=0.025d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr zl=xl zr=xr c c banners c call fstr(ichr,nchr,label(igraph),0) xxl=0.0d0 xxr=1.0d0 yyl=1.0d0-h yyr=1.0d0 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) c c set up rotated coordinate system c call mkrot(jp(13),jp(14),jp(15),q) c xmin=dmin1(0.0d0,q(1,1))+dmin1(0.0d0,q(2,1)) xmax=dmax1(0.0d0,q(1,1))+dmax1(0.0d0,q(2,1)) ymin=dmin1(0.0d0,q(1,2))+dmin1(0.0d0,q(2,2)) ymax=dmax1(0.0d0,q(1,2))+dmax1(0.0d0,q(2,2))+q(3,2) zmin=dmin1(0.0d0,q(1,3))+dmin1(0.0d0,q(2,3))+dmin1(0.0d0,q(3,3)) zmax=dmax1(0.0d0,q(1,3))+dmax1(0.0d0,q(2,3))+dmax1(0.0d0,q(3,3)) c scale=size/dmax1(xmax-xmin,ymax-ymin) xshift=xx+(size-scale*(xmax+xmin))/2.0d0 yshift=yy+(size-scale*(ymax+ymin))/2.0d0 zshift= (size-scale*(zmax+zmin))/2.0d0 t(1)=xshift t(2)=yshift t(5)=zshift t(3)=scale c dx=(xr-xl)/dfloat(numx-1) dz=(zr-zl)/dfloat(numz-1) dy=(yr-yl)/dfloat(4*numy-4) do i=1,num x(i)=xl+dx*rn(i) y(i)=yl+dy*dfloat(i) z(i)=zl+dz*(e(i)-dfloat(iminz)) xn(i)=(x(i)*q(1,1)+y(i)*q(2,1))*scale+xshift yn(i)=(x(i)*q(1,2)+y(i)*q(2,2)+z(i)*q(3,2))*scale+yshift zn(i)=(x(i)*q(1,3)+y(i)*q(2,3)+z(i)*q(3,3))*scale+zshift enddo c c we must call routines in right order to get the c hidden lines right c if(q(3,3).gt.0.0d0) then call xygrid(xl,xr,yl,yr,zl,h,t,q,numx,0,1,numy,0,4) else call pline(xn,yn,zn,num,2) endif isw=1 if(q(2,3).lt.0.0d0) then do i=num,1,-1 call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw) enddo call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1) else call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1) do i=1,num call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw) enddo endif if(q(3,3).le.0.0d0) then call xygrid(xl,xr,yl,yr,zl,h,t,q,numx,0,1,numy,0,4) else call pline(xn,yn,zn,num,2) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine nwtplt(hist,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(2),ccolor double precision + e(22,2),t(25),q(3,3),hist(22,*) character*80 + ichr,label(6) save label c data label/'newton residual ','newton increment', + 'upper bound ','lower bound ', + 'dd newton residual','dd newton increment'/ c c graph error c call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 mxhist=20 t(1)=xshift t(2)=yshift t(3)=size c lab1=idint(hist(mxhist+1,2)) if(lab1.eq.-1) then lab=5 icolor(1)=ccolor(1,0,jp) icolor(2)=ccolor(3,0,jp) else if(lab1.eq.-2) then lab=3 icolor(1)=ccolor(4,0,jp) icolor(2)=ccolor(5,0,jp) else lab=1 icolor(1)=ccolor(6,0,jp) icolor(2)=ccolor(2,0,jp) endif num1=idint(hist(mxhist+1,1)) num=min0(num1,mxhist) if(num.le.0) return do j=1,2 e1=dabs(hist(mxhist+2,j)) if(e1.gt.0.0d0) e1=1.0d0/e1 do i=1,num qq=dabs(hist(i,j))*e1 e(i,j)=0.0d0 if(qq.gt.0.0d0) e(i,j)=dlog10(qq) enddo enddo c h=0.025d0 h2=h/2.0d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr jmin=max0(num1-mxhist,0) jmax=jmin+max0(((num1-jmin-1)/4)*4+4,8) if(jmax-jmin.eq.8) then numx=5 is=2 else if(jmax-jmin.le.40) then numx=(jmax-jmin)/4+1 is=4 else jmax=jmin+((num1-jmin-1)/10)*10+10 numx=(jmax-jmin)/10+1 is=10 endif emx=e(1,1) emn=emx do i=1,num emx=dmax1(e(i,1),e(i,2),emx) emn=dmin1(e(i,1),e(i,2),emn) enddo imin=idint(emn) if(emn.lt.dfloat(imin)) imin=imin-1 imax=idint(emx) if(emx.gt.dfloat(imax)) imax=imax+1 if(imax-imin.lt.4) then imin=imin-(4+imin-imax)/2 imax=imin+4 endif numy=imax-imin+1 c c banner c yyl=yr+1.8d0*h yyr=yyl+h ym=yyl+h2 xxl=xl-2.0d0*h do j=1,2 call fstr(ichr,nchr,label(lab+j-1),0) xxr=xxl+dfloat(nchr)*h xm=xxr+h2 call symbl(xm,ym,h,h,1,icolor(j),t) call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) xxl=(xl+xr)/2.0d0 enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin, + is,numy,imin,1) c c graph c dx=(xr-xl)/dfloat(jmax-jmin) hx=dx/4.0d0 dy=(yr-yl)/dfloat(numy-1) do i=1,num xs=xl+dx*dfloat(i)-hx/2.0d0 do j=1,2 xm=xs+dfloat(j-1)*hx hy=dy*(e(i,j)-dfloat(imin)) ym=yl+hy/2.0d0 call symbl(xm,ym,hx,hy,1,icolor(j),t) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine kaplt(ka,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(4),ccolor,ka(10,*) double precision + t(25),q(3,3),e(3,100),rn(100),ratio(4) character*80 + ichr,label(4),jchr save label data label/'ja','ju','vf','n'/ c c graph error c lvl=jp(11) if(lvl.le.0) return call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 t(1)=xshift t(2)=yshift t(3)=size c cc icolor(1)=ccolor(6,0,jp) cc icolor(2)=ccolor(2,0,jp) icolor(1)=ccolor(5,0,jp) icolor(2)=ccolor(3,0,jp) icolor(3)=ccolor(1,0,jp) icolor(4)=1 if(lvl.le.0) return c c set up input arrays c nsum=0 jasum=0 jusum=0 jfsum=0 do ii=1,lvl i=lvl+1-ii n=ka(1,i) lenja=ka(10,i)-ka(3,i) if(ka(5,i).eq.ka(3,i)) then lenju=lenja else lenju=ka(7,i)-ka(5,i) endif if(i.lt.lvl) then lenvf=ka(3,i+1)-ka(7,i) else lenvf=n+1 endif rn(ii)=dlog10(dfloat(n)) e(1,ii)=dfloat(lenja-n-1)/dfloat(n) e(2,ii)=dfloat(lenju-n-1)/dfloat(n) e(3,ii)=dfloat(lenvf-n-1)/dfloat(n) nsum=nsum+n jasum=jasum+2*(lenja-n-1)+n jusum=jusum+2*(lenju-n-1)+n jfsum=jfsum+lenvf-n-1 enddo ja0=2*(lenja-n-1)+n ratio(1)=dfloat(jasum)/dfloat(ja0) ratio(2)=dfloat(jusum)/dfloat(ja0) ratio(3)=dfloat(jfsum)/dfloat(ja0) ratio(4)=dfloat(nsum)/dfloat(n) c h=0.025d0 h2=h/2.0d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr jmin=0 jmax=jmin+idint(rn(lvl))+1 numx=jmax+1 emx=e(1,1) emn=emx do i=1,lvl emx=dmax1(e(1,i),e(2,i),emx) emn=dmin1(e(1,i),e(2,i),emn) enddo cc imin=int(emn) cc if(emn.lt.float(imin)) imin=imin-1 imin=0 imax=idint(emx) if(emx.gt.dfloat(imax)) imax=imax+1 if(imax-imin.lt.4) then imin=imin-(4+imin-imax)/2 imax=imin+4 endif if(imax-imin.le.6) then numy=imax-imin+1 iy=1 else if(imax-imin.le.40) then imax=imin+((imax-imin-1)/4)*4+4 numy=(imax-imin)/4+1 iy=4 else iy=((imax-imin-1)/100+1)*10 imax=imin+((imax-imin-1)/iy)*iy+iy numy=(imax-imin)/iy+1 endif c c banner c yyl=yr+1.2d0*h yyr=yyl+h ym=yyl+h2 hx=(xr-xl)/3.5d0 do j=1,4 call fstr(ichr,nchr,label(j),0) ichr(nchr+1:nchr+1)=' ' ii=3 if(ratio(j).ge.10.0d0) ii=4 if(ratio(j).ge.100.0d0) ii=5 call sreal(jchr,mchr,ratio(j),ii,0) ichr(nchr+2:nchr+mchr+1)=jchr(1:mchr) nchr=nchr+mchr+1 xxl=xl+dfloat(j-1)*hx xxr=xxl+dfloat(nchr)*h xm=xxr+h2 cc xxm=(xxl+xxr)/2.0e0 cc dxm=xxr-xxl cc dym=2.0e0*h cc call symbl(xxm,ym,dxm,dym,1,icolor(j),t) if(j.ne.4) call symbl(xm,ym,h,h,1,icolor(j),t) call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,1,numy,imin,iy) c c graph c dx=(xr-xl)/dfloat(jmax-jmin) hx=dx/12.0d0 dy=(yr-yl)/dfloat(imax-imin) do i=1,lvl xs=xl+dx*rn(i)-hx do j=1,3 xm=xs+dfloat(j-1)*hx hy=dy*(e(j,i)-dfloat(imin)) ym=yl+hy/2.0d0 call symbl(xm,ym,hx,hy,1,icolor(j),t) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine hbplt(hist,numhst,lab,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + icolor(22,4),jp(25),num1(4),num(4),jc(2,4),ccolor double precision + e(22,4),hist(22,*),t(25),q(3,3),x(25),y(25),z(25), 1 ave(4),sfact(4) character*80 + ichr,rate(3) save rate c data rate/'multigraph','singular vector', + 'spectral bisection'/ c c graph error c call linit(t,q) size=t(14) xshift=t(15)-size/2.0d0 yshift=t(16)-size/2.0d0 zshift=t(5) mxhist=20 t(1)=xshift t(2)=yshift t(3)=size jc(1,1)=ccolor(4,0,jp) jc(2,1)=ccolor(6,0,jp) jc(1,2)=ccolor(2,0,jp) jc(2,2)=ccolor(5,0,jp) jc(1,3)=ccolor(3,0,jp) jc(2,3)=ccolor(1,0,jp) jc(1,4)=1 jc(2,4)=2 sfact(1)=0.8d0/dsqrt(2.0d0) sfact(2)=0.8d0 sfact(3)=0.6d0 sfact(4)=0.6d0 do j=1,4 num(j)=0 num1(j)=0 enddo c do j=1,numhst num1(j)=idint(hist(mxhist+1,j)) num(j)=min0(num1(j),mxhist) if(num(j).gt.0) then e1=dabs(hist(mxhist+2,j)) if(e1.gt.0.0d0) e1=1.0d0/e1 do i=1,num(j) qq=dabs(hist(i,j))*e1 e(i,j)=0.0d0 if(qq.gt.0.0d0) e(i,j)=dlog10(qq) ee=e(i,j) if(hist(i,j).ge.0.0d0) then icolor(i,j)=jc(1,j) else icolor(i,j)=jc(2,j) endif enddo ave(j)=10.0d0**(e(num(j),j)/dfloat(num1(j))) endif enddo n1max=num1(1) n1min=num1(1) do j=1,numhst if(num1(j).gt.0) then n1max=max0(num1(j),n1max) n1min=min0(num1(j),n1min) endif enddo if(n1max.eq.0) return c h=0.025d0 h2=h/2.0d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr if(n1max-n1min+4.le.mxhist) then jmin=max0(n1max-mxhist,0) c* jmax=jmin+max0(((n1max-jmin-1)/4)*4+4,8) jmax=jmin+mxhist else jmin=max0(n1min-4,0) jmax=jmin+((n1max-jmin-1)/4)*4+4 endif if(jmax-jmin.eq.8) then numx=5 is=2 else if(jmax-jmin.le.40) then numx=(jmax-jmin)/4+1 is=4 else jmax=jmin+((n1max-jmin-1)/10)*10+10 numx=(jmax-jmin)/10+1 is=10 endif emx=ee emn=ee do j=1,numhst if(num(j).gt.0) then do i=1,num(j) emx=dmax1(e(i,j),emx) emn=dmin1(e(i,j),emn) enddo endif enddo imin=idint(emn) if(emn.lt.dfloat(imin)) imin=imin-1 imax=idint(emx) if(emx.gt.dfloat(imax)) imax=imax+1 if(imax-imin.lt.4) then imin=imin-(4+imin-imax)/2 imax=imin+4 endif numy=imax-imin+1 c c banners c yyl=yr+1.8d0*h yyr=yyl+h ym=yyl+h2 call fstr(ichr,nchr,rate(lab),0) xxl=h xxr=xxl+10.0d0*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) do j=1,numhst if(num(j).gt.0) then call sreal(ichr,nchr,ave(j),2,0) xxl=dfloat(6+7*j)*h xxr=xxl+5.0d0*h xm=xxl-h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) call symbl(xm,ym,h,h,j,jc(1,j),t) endif enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin, + is,numy,imin,1) c c graph c dy=(yr-yl)/dfloat(numy-1) dx=(xr-xl)/dfloat(jmax-jmin) do j=1,numhst hh=h*sfact(j) ishift=max0(num1(j)-mxhist,0)-jmin i0=max0(1,-ishift) do i=i0,num(j) xs=xl+dx*dfloat(i+ishift) ys=yl+dy*(e(i,j)-dfloat(imin)) x(i)=xs*size+xshift y(i)=ys*size+yshift z(i)=zshift call symbl(xs,ys,hh,hh,j,icolor(i,j),t) enddo nn=num(j)-i0+1 if(nn.gt.1) call pline(x(i0),y(i0),z(i0),nn,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pthplt(jp,path) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor double precision + path(101,*),x(5),y(5),z(5),t(25),q(3,3) character*80 + ichr,label save label data label/'continuation path'/ c c plot continuation path c call linit(t,q) zshift=t(5) size=t(14) xx=t(15)-size/2.0d0 yy=t(16)-size/2.0d0 num=idint(path(101,1)) if(num.le.0) return rlmax=path(1,1) rlmin=rlmax rmax=path(1,2) rmin=rmax do i=1,num rlmax=dmax1(rlmax,path(i,1)) rlmin=dmin1(rlmin,path(i,1)) rmax=dmax1(rmax,path(i,2)) rmin=dmin1(rmin,path(i,2)) enddo dr=(rlmax-rlmin)/20.0d0 if(dr.eq.0.0d0) dr=dabs(rlmax)/20.0d0 if(dr.eq.0.0d0) dr=1.0d0 rlmax=rlmax+dr rlmin=rlmin-dr dr=(rmax-rmin)/20.0d0 if(dr.eq.0.0d0) dr=dabs(rmax)/20.0d0 if(dr.eq.0.0d0) dr=1.0d0 rmax=rmax+dr rmin=rmin-dr c h=0.025d0*size xl=xx+7.0d0*h xr=xx+size-h yb=yy+2.5d0*h yt=yb+size-5.5d0*h c srl=(xr-xl)/(rlmax-rlmin) sr=(yt-yb)/(rmax-rmin) xshift=(xr+xl)/2.0d0-srl*(rlmax+rlmin)/2.0d0 yshift=(yb+yt)/2.0d0-sr*(rmax+rmin)/2.0d0 c c banners c call fstr(ichr,nchr,label,0) xxl=xx xxr=xx+size yyl=yy+size-1.25d0*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) c c horizontal axis c do i=1,5 z(i)=zshift enddo x(1)=xl x(2)=xr y(1)=yb y(2)=y(1) call pline(x,y,z,2,2) dx=(xr-xl)/10.0d0 dr=(rlmax-rlmin)/10.0d0 do 25 i=1,11 x(1)=xl+dfloat(i-1)*dx x(2)=x(1) y(1)=yb y(2)=yb-0.5d0*h call pline(x,y,z,2,2) if(i-(i/2)*2.eq.0) go to 25 xk=rlmin+dfloat(i-1)*dr call sreal(ichr,nchr,xk,3,0) xxl=x(1)-dfloat(nchr)*h/4.0d0 xxr=x(1)+dfloat(nchr)*h/4.0d0 yyl=y(2)-1.75d0*h/2.0d0 yyr=yyl+h/2.0d0 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) 25 continue c c vertical axis c x(1)=xl x(2)=x(1) y(1)=yb y(2)=yt call pline(x,y,z,2,2) dy=(yt-yb)/10.0d0 dr=(rmax-rmin)/10.0d0 do i=1,11 xk=rmin+dfloat(i-1)*dr call sreal(ichr,nchr,xk,3,0) x(1)=xl x(2)=x(1)-0.5d0*h y(1)=yb+dfloat(i-1)*dy y(2)=y(1) call pline(x,y,z,2,2) xxl=dmax1(x(1)-dfloat(nchr+3)*h/2.0d0,xx) xxr=x(1)-h yyl=y(1)-h/4.0d0 yyr=y(1)+h/4.0d0 call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) enddo c c mark points c do 35 i=1,num x(1)=path(i,1)*srl+xshift-h/2.0d0 x(2)=x(1)+h x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=path(i,2)*sr+yshift-h/2.0d0 y(2)=y(1) y(3)=y(1)+h y(4)=y(3) y(5)=y(1) iic=idint(path(i,6)) if(iic.gt.6) go to 35 ic=ccolor(iic,0,jp) call pfill(x,y,z,4,ic) call pline(x,y,z,5,2) 35 continue c c draw interpolant c if(num.gt.1) then do i=1,num-1 it1=idint(path(i+1,6)) call cpth(path(i,1),path(i+1,1),path(i,2),path(i+1,2), + path(i,3),path(i+1,3),path(i,4),path(i+1,4), 1 it1,srl,sr,xshift,yshift,zshift,xl,xr,yb,yt) enddo endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cpth(l0,l1,r0,r1,l0dot,l1dot,r0dot,r1dot,it1, + xscale,yscale,xshift,yshift,zshift,xl,xr,yb,yt) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + l0,l1,l0dot,l1dot,x(101),y(101),z(101) c c compute the parabola thru two points and evaluate c if(it1.ge.7) return dr=r1-r0 dl=l1-l0 al=dsqrt(dr*dr+dl*dl) if(al.eq.0.0d0) return c1=dr/al s1=dl/al xd1=c1*r1dot+s1*l1dot yd1=c1*l1dot-s1*r1dot xd0=c1*r0dot+s1*l0dot yd0=c1*l0dot-s1*r0dot c c c we are solving 4 eqns in 4 unknowns (c,q,pr,pl) c the eqns are (x,y) = m d (u,v) + (pr,pl) c m= 2x2 orthogonal c d = diag(1 q) c v= u**2 c (solve by first eliminating pr,pl using data points c and the solving tangent equations for c,q) c it is ok to consider one point at the origin and one at (al,0) c if(it1.eq.1.or.it1.eq.3) go to 10 w0=2.0d0*yd0*yd1 w1=-(xd0*yd1+xd1*yd0) a=dsqrt(w0*w0+w1*w1) if(dabs(a).lt.1.d-2) go to 10 c2=w0/a s2=w1/a ud0=c2*xd0+s2*yd0 if(dabs(ud0).le.1.d-2) go to 10 vd0=c2*yd0-s2*xd0 c=c1*c2-s1*s2 s=c1*s2+s1*c2 b=((yd0*yd1)/a)*((yd1*al)/a) q=-1.0d0/(4.0d0*b*ud0) t=b*vd0/ud0 pr=r0+(c*2.0d0*ud0-s*vd0)*t pl=l0+(c*vd0+s*2.0d0*ud0)*t c c compute number of points c num=idint(dabs(r0-r1)*yscale*50.0d0) + +idint(dabs(l0-l1)*xscale*50.0d0) num=min0(101,num) if(num.le.2) go to 10 u0=c*(r0-pr)+s*(l0-pl) u1=c*(r1-pr)+s*(l1-pl) h=(u1-u0)/dfloat(num-1) do i=1,num u=u0+dfloat(i-1)*h v=q*u*u y(i)=(pr+c*u-s*v)*yscale+yshift x(i)=(pl+s*u+c*v)*xscale+xshift z(i)=zshift if(x(i).lt.xl.or.x(i).gt.xr) go to 10 if(y(i).lt.yb.or.y(i).gt.yt) go to 10 enddo call pline(x,y,z,num,2) return c c use straight line approximation c 10 num=2 y(1)=r0*yscale+yshift y(2)=r1*yscale+yshift x(1)=l0*xscale+xshift x(2)=l1*xscale+xshift z(1)=zshift z(2)=zshift call pline(x,y,z,num,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tmhist(jp,path,iptr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor double precision + path(101,*),x(5),y(5),z(5),t(25),q(3,3),rr(101) character*80 + ichr,label(2) save label data label/'time step history','utnorm history'/ c c plot time-step history of parabolic problem c call linit(t,q) size=t(14) xx=t(15)-size/2.0d0 yy=t(16)-size/2.0d0 zshift=t(5) num=idint(path(101,1)) if(num.le.1) return tmin=path(1,1) tmax=path(num,1) if(tmax.le.tmin) return rr(1)=0.0d0 rr(2)=dlog10(path(2,iptr+1)) rmax=rr(2) rmin=rmax do i=2,num rr(i)=dlog10(path(i,iptr+1)) rmax=dmax1(rmax,rr(i)) rmin=dmin1(rmin,rr(i)) enddo irmax=idint(rmax)+1 irmin=idint(rmin)-1 c h=0.025d0*size xl=xx+7.0d0*h xr=xx+size-h yb=yy+2.5d0*h yt=yb+size-5.5d0*h c st=(xr-xl)/(tmax-tmin) sr=(yt-yb)/dfloat(irmax-irmin) xshift=(xr+xl)/2.0d0-st*(tmax+tmin)/2.0d0 yshift=(yb+yt)/2.0d0-sr*dfloat(irmax+irmin)/2.0d0 c c banners c call fstr(ichr,nchr,label(iptr),0) xxl=xx xxr=xx+size yyl=yy+size-1.25d0*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) c c horizontal axis c do i=1,5 z(i)=zshift enddo x(1)=xl x(2)=xr y(1)=yb y(2)=y(1) call pline(x,y,z,2,2) dx=(xr-xl)/10.0d0 dt=(tmax-tmin)/10.0d0 do 25 i=1,11 x(1)=xl+dfloat(i-1)*dx x(2)=x(1) y(1)=yb y(2)=yb-0.5d0*h call pline(x,y,z,2,2) if(i-(i/2)*2.eq.0) go to 25 xk=tmin+dfloat(i-1)*dt call sreal(ichr,nchr,xk,3,0) xxl=x(1)-dfloat(nchr)*h/4.0d0 xxr=x(1)+dfloat(nchr)*h/4.0d0 yyl=y(2)-1.75d0*h/2.0d0 yyr=yyl+h/2.0d0 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) 25 continue c c vertical axis c x(1)=xl x(2)=x(1) y(1)=yb y(2)=yt call pline(x,y,z,2,2) dy=(yt-yb)/10.0d0 if(irmax-irmin.lt.10) then nn=irmax-irmin+1 inc=1 else nn=(irmax-irmin)/2+1 inc=2 endif dy=(yt-yb)/dfloat(nn-1) do i=1,nn k=irmin+(i-1)*inc call sint(ichr,nchr,k) x(1)=xl x(2)=x(1)-0.5d0*h y(1)=yb+dfloat(i-1)*dy y(2)=y(1) call pline(x,y,z,2,2) xxl=dmax1(x(1)-dfloat(nchr+3)*h/2.0d0,xx) xxr=x(1)-h yyl=y(1)-h/4.0d0 yyr=y(1)+h/4.0d0 call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) enddo c c mark points c do i=2,num x(1)=path(i,1)*st+xshift-h/2.0d0 x(2)=x(1)+h x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=rr(i)*sr+yshift-h/2.0d0 y(2)=y(1) y(3)=y(1)+h y(4)=y(3) y(5)=y(1) ic=ccolor(4,0,jp) if(idint(path(i,6)).lt.0) ic=ccolor(6,0,jp) call pfill(x,y,z,4,ic) call pline(x,y,z,5,2) if(i.gt.2) then x(1)=path(i-1,1)*st+xshift x(2)=path(i,1)*st+xshift y(1)=rr(i-1)*sr+yshift y(2)=rr(i)*sr+yshift call pline(x,y,z,2,2) endif enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ipmplt(jp,path) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ic(100),icc(6),ccolor double precision + rn(100),rho(100),rmu(100),t(25),q(3,3),x(100), 1 y(100),z(100),xn(100),yn(100),zn(100),path(101,*) character*80 + ichr,label save label,icc c data label/'interior point history'/ data icc/6,2,5,3,1,4/ c c initialize c call linit(t,q) size=t(14) xx=t(15)-size/2.0d0 yy=t(16)-size/2.0d0 t(1)=xx t(2)=yy t(3)=size c num=idint(path(101,1)) if(num.le.0) return c c set up input arrays c do i=1,num rmu(i)=dlog10(path(i,1)) rho(i)=dlog10(dabs(path(i,2))) rn(i)=dlog10(path(i,3)) ii=idint(path(i,6)) if(ii.lt.1) ii=1 if(ii.gt.6) ii=6 ic(i)=ccolor(icc(ii),0,jp) enddo c rnmax=rn(1) rmumax=rmu(1) rmumin=rmumax rhomax=rho(1) rhomin=rhomax do i=1,num rnmax=dmax1(rn(i),rnmax) rmumax=dmax1(rmu(i),rmumax) rmumin=dmin1(rmu(i),rmumin) rhomax=dmax1(rho(i),rhomax) rhomin=dmin1(rho(i),rhomin) enddo c numx=max0(5,idint(rnmax)+2) iminy=idint(rmumin) if(rmumin.lt.dfloat(iminy)) iminy=iminy-1 imaxy=idint(rmumax) if(rmumax.gt.dfloat(imaxy)) imaxy=imaxy+1 if(imaxy-iminy.lt.4) then iminy=iminy-(4+iminy-imaxy)/2 imaxy=iminy+4 endif numy=imaxy-iminy+1 iminz=idint(rhomin) if(rhomin.lt.dfloat(iminz)) iminz=iminz-1 imaxz=idint(rhomax) if(rhomax.gt.dfloat(imaxz)) imaxz=imaxz+1 if(imaxz-iminz.lt.4) then iminz=iminz-(4+iminz-imaxz)/2 imaxz=iminz+4 endif numz=imaxz-iminz+1 c h=0.025d0 xl=3.0d0*h xr=1.0d0-xl yl=xl yr=xr zl=xl zr=xr c c banners c call fstr(ichr,nchr,label,0) xxl=0.0d0 xxr=1.0d0 yyl=1.0d0-h yyr=1.0d0 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) c c set up rotated coordinate system c call mkrot(jp(13),jp(14),jp(15),q) c xmin=dmin1(0.0d0,q(1,1))+dmin1(0.0d0,q(2,1)) xmax=dmax1(0.0d0,q(1,1))+dmax1(0.0d0,q(2,1)) ymin=dmin1(0.0d0,q(1,2))+dmin1(0.0d0,q(2,2)) ymax=dmax1(0.0d0,q(1,2))+dmax1(0.0d0,q(2,2))+q(3,2) zmin=dmin1(0.0d0,q(1,3))+dmin1(0.0d0,q(2,3))+dmin1(0.0d0,q(3,3)) zmax=dmax1(0.0d0,q(1,3))+dmax1(0.0d0,q(2,3))+dmax1(0.0d0,q(3,3)) c scale=size/dmax1(xmax-xmin,ymax-ymin) xshift=xx+(size-scale*(xmax+xmin))/2.0d0 yshift=yy+(size-scale*(ymax+ymin))/2.0d0 zshift= (size-scale*(zmax+zmin))/2.0d0 t(1)=xshift t(2)=yshift t(5)=zshift t(3)=scale c dx=(xr-xl)/dfloat(numx-1) dz=(zr-zl)/dfloat(numz-1) dy=(yr-yl)/dfloat(numy-1) do i=1,num x(i)=xl+dx*rn(i) y(i)=yl+dy*(rmu(i)-dfloat(iminy)) z(i)=zl+dz*(rho(i)-dfloat(iminz)) xn(i)=(x(i)*q(1,1)+y(i)*q(2,1))*scale+xshift yn(i)=(x(i)*q(1,2)+y(i)*q(2,2)+z(i)*q(3,2))*scale+yshift zn(i)=(x(i)*q(1,3)+y(i)*q(2,3)+z(i)*q(3,3))*scale+zshift enddo c c we must call routines in right order to get the c hidden lines right c if(q(3,3).gt.0.0d0) then call xygrid(xl,xr,yl,yr,zl,h,t,q,numx,0,1,numy,iminy,1) else call pline(xn,yn,zn,num,2) endif isw=1 if(q(2,3).lt.0.0d0) then do i=num,1,-1 call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw) enddo call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1) else call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1) do i=1,num call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw) enddo endif if(q(3,3).le.0.0d0) then call xygrid(xl,xr,yl,yr,zl,h,t,q,numx,0,1,numy,iminy,1) else call pline(xn,yn,zn,num,2) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xyaxis(xl,xr,yl,yr,h,t,q,numx,iminx, + incx,numy,iminy,incy) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + t(25),q(3,3),x(2),y(2),z(2) character*80 + ichr c dx=(xr-xl)/(numx-1) dy=(yr-yl)/(numy-1) xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h2=h/2.0d0 c c x - axis c z(1)=zshift z(2)=zshift x(1)=xl*scale+xshift y(1)=yl*scale+yshift x(2)=xr*scale+xshift y(2)=y(1) call pline(x,y,z,2,2) do i=1,numx k=iminx+(i-1)*incx call sint(ichr,nchr,k) xx=xl+dfloat(i-1)*dx x(1)=xx*scale+xshift y(1)=(yl+h2)*scale+yshift x(2)=x(1) y(2)=yl*scale+yshift call pline(x,y,z,2,2) xxl=xx-dfloat(nchr)*h2 xxr=xx+dfloat(nchr)*h2 yyl=yl-2.25d0*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) enddo c c y-axis c x(1)=xl*scale+xshift y(1)=yl*scale+yshift x(2)=x(1) y(2)=yr*scale+yshift call pline(x,y,z,2,2) do i=1,numy k=iminy+(i-1)*incy call sint(ichr,nchr,k) yy=yl+dfloat(i-1)*dy x(1)=(xl+h2)*scale+xshift y(1)=yy*scale+yshift x(2)=xl*scale+xshift y(2)=y(1) call pline(x,y,z,2,2) xxl=xl-dfloat(2*nchr+1)*h2 xxr=xl-h2 yyl=yy-h2 yyr=yy+h2 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q,t,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine symbl(xm,ym,hx,hy,itype,icolor,t) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + iptr(5) double precision + t(25),px(14),py(14),x(5),y(5),z(5) save px,py,iptr c data iptr/1,5,9,12,15/ data px/-0.5d0,0.5d0,0.5d0,-0.5d0,0.5d0,0.0d0,-0.5d0,0.0d0, + -0.5d0,0.5d0,0.0d0,0.0d0,0.5d0,-0.5d0/ data py/-0.5d0,-0.5d0,0.5d0,0.5d0,0.0d0,0.5d0,0.0d0,-0.5d0, + -0.5d0,-0.5d0,0.5d0,-0.5d0,0.5d0,0.5d0/ c c itype = 1 box itype = 2 diamond itype = 3,4 triangle c xshift=t(1) yshift=t(2) scale=t(3) zshift=t(5) istart=iptr(itype) num=iptr(itype+1)-istart do i=1,num x(i)=(xm+hx*px(i+istart-1))*scale+xshift y(i)=(ym+hy*py(i+istart-1))*scale+yshift z(i)=zshift enddo x(num+1)=x(1) y(num+1)=y(1) z(num+1)=z(1) call pfill(x,y,z,num,icolor) call pline(x,y,z,num+1,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xygrid(xl,xr,yl,yr,zl,h,t,q,numx,iminx, + incx,numy,iminy,incy) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + t(25),q(3,3),x(2),y(2),z(2),t0(25),q0(3,3) character*80 + ichr c dx=(xr-xl)/(numx-1) dy=(yr-yl)/(numy-1) xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h2=h/2.0d0 zm=zl-h2 zp=zl+h2 do i=1,25 t0(i)=t(i) enddo c c x - axis c if(q(2,3).eq.0.0d0.and.q(3,3).eq.0.0d0) go to 10 nn=numy if(q(3,3).eq.0.0d0) nn=1 do i=1,nn yy=yl+dfloat(i-1)*dy x(1)=(xl*q(1,1)+yy*q(2,1))*scale+xshift y(1)=(xl*q(1,2)+yy*q(2,2)+zl*q(3,2))*scale+yshift z(1)=(xl*q(1,3)+yy*q(2,3)+zl*q(3,3))*scale+zshift x(2)=(xr*q(1,1)+yy*q(2,1))*scale+xshift y(2)=(xr*q(1,2)+yy*q(2,2)+zl*q(3,2))*scale+yshift z(2)=(xr*q(1,3)+yy*q(2,3)+zl*q(3,3))*scale+zshift call pline(x,y,z,2,2) enddo do i=1,3 q0(1,i)=q(1,i) q0(2,i)=q(3,i) q0(3,i)=-q(2,i) enddo t0(1)=xshift+q(2,1)*scale*(yl-h) t0(2)=yshift+q(2,2)*scale*(yl-h) t0(5)=zshift+q(2,3)*scale*(yl-h) do i=1,numx k=iminx+(i-1)*incx call sint(ichr,nchr,k) xx=xl+dfloat(i-1)*dx x(1)=(xx*q(1,1)+yl*q(2,1))*scale+xshift y(1)=(xx*q(1,2)+yl*q(2,2)+zm*q(3,2))*scale+yshift z(1)=(xx*q(1,3)+yl*q(2,3)+zm*q(3,3))*scale+zshift x(2)=(xx*q(1,1)+yl*q(2,1))*scale+xshift y(2)=(xx*q(1,2)+yl*q(2,2)+zp*q(3,2))*scale+yshift z(2)=(xx*q(1,3)+yl*q(2,3)+zp*q(3,3))*scale+zshift call pline(x,y,z,2,2) xxl=xx-dfloat(nchr)*h2 xxr=xx+dfloat(nchr)*h2 yyl=zl-2.25d0*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q0,t0,2) enddo c c y-axis c 10 if(q(1,3).eq.0.0d0.and.q(3,3).eq.0.0d0) return nn=numx if(q(3,3).eq.0.0d0) nn=1 do i=1,nn xx=xl+dfloat(i-1)*dx x(1)=(xx*q(1,1)+yl*q(2,1))*scale+xshift y(1)=(xx*q(1,2)+yl*q(2,2)+zl*q(3,2))*scale+yshift z(1)=(xx*q(1,3)+yl*q(2,3)+zl*q(3,3))*scale+zshift x(2)=(xx*q(1,1)+yr*q(2,1))*scale+xshift y(2)=(xx*q(1,2)+yr*q(2,2)+zl*q(3,2))*scale+yshift z(2)=(xx*q(1,3)+yr*q(2,3)+zl*q(3,3))*scale+zshift call pline(x,y,z,2,2) enddo do i=1,3 q0(1,i)=q(2,i) q0(2,i)=q(3,i) q0(3,i)=q(1,i) enddo t0(1)=xshift+q(1,1)*scale*(xl-h) t0(2)=yshift+q(1,2)*scale*(xl-h) t0(5)=zshift+q(1,3)*scale*(xl-h) do i=1,numy k=iminy+(i-1)*incy call sint(ichr,nchr,k) yy=yl+dfloat(i-1)*dy x(1)=(xl*q(1,1)+yy*q(2,1))*scale+xshift y(1)=(xl*q(1,2)+yy*q(2,2)+zm*q(3,2))*scale+yshift z(1)=(xl*q(1,3)+yy*q(2,3)+zm*q(3,3))*scale+zshift x(2)=(xl*q(1,1)+yy*q(2,1))*scale+xshift y(2)=(xl*q(1,2)+yy*q(2,2)+zp*q(3,2))*scale+yshift z(2)=(xl*q(1,3)+yy*q(2,3)+zp*q(3,3))*scale+zshift call pline(x,y,z,2,2) xxl=yy-dfloat(nchr)*h2 xxr=yy+dfloat(nchr)*h2 yyl=zl-2.25d0*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q0,t0,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,incz) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + t(25),q(3,3),x(3),y(3),z(3),t0(25),q0(3,3) character*80 + ichr c dz=(zr-zl)/(numz-1) xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h2=h/2.0d0 xp=xl+h2 yp=yl+h2 do i=1,25 t0(i)=t(i) enddo if(dabs(q(1,3)).lt.dabs(q(2,3))) then do i=1,3 q0(1,i)=q(1,i) q0(2,i)=q(3,i) q0(3,i)=-q(2,i) enddo t0(1)=xshift+q(2,1)*scale*(yl-h) t0(2)=yshift+q(2,2)*scale*(yl-h) t0(5)=zshift+q(2,3)*scale*(yl-h) else do i=1,3 q0(1,i)=q(2,i) q0(2,i)=q(3,i) q0(3,i)=q(1,i) enddo t0(1)=xshift+q(1,1)*scale*(xl-h) t0(2)=yshift+q(1,2)*scale*(xl-h) t0(5)=zshift+q(1,3)*scale*(xl-h) endif c c z - axis c x(1)=(xl*q(1,1)+yl*q(2,1))*scale+xshift y(1)=(xl*q(1,2)+yl*q(2,2)+zl*q(3,2))*scale+yshift z(1)=(xl*q(1,3)+yl*q(2,3)+zl*q(3,3))*scale+zshift x(2)=(xl*q(1,1)+yl*q(2,1))*scale+xshift y(2)=(xl*q(1,2)+yl*q(2,2)+zr*q(3,2))*scale+yshift z(2)=(xl*q(1,3)+yl*q(2,3)+zr*q(3,3))*scale+zshift call pline(x,y,z,2,2) do i=1,numz k=iminz+(i-1)*incz call sint(ichr,nchr,k) zz=zl+dfloat(i-1)*dz x(1)=(xp*q(1,1)+yl*q(2,1))*scale+xshift y(1)=(xp*q(1,2)+yl*q(2,2)+zz*q(3,2))*scale+yshift z(1)=(xp*q(1,3)+yl*q(2,3)+zz*q(3,3))*scale+zshift x(2)=(xl*q(1,1)+yl*q(2,1))*scale+xshift y(2)=(xl*q(1,2)+yl*q(2,2)+zz*q(3,2))*scale+yshift z(2)=(xl*q(1,3)+yl*q(2,3)+zz*q(3,3))*scale+zshift x(3)=(xl*q(1,1)+yp*q(2,1))*scale+xshift y(3)=(xl*q(1,2)+yp*q(2,2)+zz*q(3,2))*scale+yshift z(3)=(xl*q(1,3)+yp*q(2,3)+zz*q(3,3))*scale+zshift call pline(x,y,z,3,2) c xxl=xl-dfloat(nchr+1)*h xxr=xl-h yyl=zz-h2 yyr=zz+h2 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q0,t0,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cbox(x,y,z,zl,h,t,q,icolor,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + face(4,6),order(6),index(3,3) double precision + t(25),q(3,3),px(8),py(8),pz(8),xn(5),yn(5),zn(5) save px,py,pz,face,order,istrt,index data px/0.0d0,1.0d0,1.0d0,0.0d0,0.0d0,1.0d0,1.0d0,0.0d0/ data py/0.0d0,0.0d0,1.0d0,1.0d0,0.0d0,0.0d0,1.0d0,1.0d0/ data pz/0.0d0,0.0d0,0.0d0,0.0d0,1.0d0,1.0d0,1.0d0,1.0d0/ data face/4,1,5,8,2,3,7,6,1,2,6,5,3,4,8,7,4,3,2,1,5,6,7,8/ data index/1,2,3,2,3,1,3,1,2/ c if(isw.eq.1) then c c compute order c kmin=1 if(dabs(q(kmin,3)).gt.dabs(q(2,3))) kmin=2 if(dabs(q(kmin,3)).gt.dabs(q(3,3))) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(dabs(q(kmid,3)).gt.dabs(q(kmax,3))) kmid=kmax kmax=6-kmin-kmid c if(q(kmax,3).gt.0.0d0) then order(1)=2*kmax-1 order(6)=2*kmax else order(6)=2*kmax-1 order(1)=2*kmax endif if(q(kmid,3).gt.0.0d0) then order(2)=2*kmid-1 order(5)=2*kmid else order(5)=2*kmid-1 order(2)=2*kmid endif if(q(kmin,3).gt.0.0d0) then order(3)=2*kmin-1 order(4)=2*kmin else order(4)=2*kmin-1 order(3)=2*kmin endif c tol=1.d-3 istrt=6 if(dabs(q(kmin,3)).gt.tol) then istrt=4 else if(dabs(q(kmid,3)).gt.tol) then istrt=5 endif endif xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h2=h/2.0d0 do i=istrt,6 ii=order(i) do j=1,4 xx=x-h2+h*px(face(j,ii)) yy=y-h2+h*py(face(j,ii)) zz=zl+(z-zl)*pz(face(j,ii)) xn(j)=(xx*q(1,1)+yy*q(2,1))*scale+xshift yn(j)=(xx*q(1,2)+yy*q(2,2)+zz*q(3,2))*scale+yshift zn(j)=(xx*q(1,3)+yy*q(2,3)+zz*q(3,3))*scale+zshift enddo xn(5)=xn(1) yn(5)=yn(1) zn(5)=zn(1) call pfill(xn,yn,zn,4,icolor) call pline(xn,yn,zn,5,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mktris(ip,vx,vy,ibndry,itnode,xm,ym,jb,jt, + jtnode,jtedge,index,list,llist,ntf,iclrsw,vx0,vy0) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),jtnode(5,*),jt(*), 1 jtedge(3,*),list(*),ip(100),index(*) double precision + vx(*),vy(*),xm(*),ym(*),vx0(*),vy0(*) c c make a crude triangulation of the skeleton c ntr=ip(1) nvr=ip(2) nbr=ip(4) c c make jb c call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,jb,list, + vx0,vy0,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c i1=1 i2=nvr+1 i3=(llist-i2+1)/2 ntf=0 do itag=1,ntr nb1=jb(itag) nb2=jb(itag+1)-1 ivc=itnode(1,itag) nn=0 do jj=nb1,nb2 it=jb(jj) ivn=ibndry(1,it)+ibndry(2,it)-ivc nn=nn+1 index(nn)=ivc ivc=ivn enddo nt1=ntf+1 jt(itag)=nt1 j4tag=0 if(iclrsw.eq.1) then j5tag=itnode(4,itag) else if(iclrsw.eq.2) then j5tag=itag else j5tag=itnode(5,itag) endif call trisk(nn,vx,vy,index,ntf,jtnode,j4tag,j5tag, + list(i1),list(i2),list(i3)) call cedgek(nvr,nt1,ntf,nb1,nb2,jtnode,ibndry, + jtedge,jb,vx,vy,list) call eswapk(nt1,ntf,jtnode,jtedge,vx,vy) enddo jt(ntr+1)=ntf+1 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine trisk(nvf,vx,vy,index,ntf,itnode,i4tag,i5tag, + list,istart,istop) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + istart(*),istop(*),itnode(5,*),list(*),index(*) double precision + vx(*),vy(*) c c triangulate the region give in vx,vy c c* ntf0=ntf nrgn=1 istart(1)=1 istop(1)=nvf eps=0.0d0 c c 10 ibegin=istart(nrgn) iend=istop(nrgn) nrgn=nrgn-1 c c compute vertices visible from ibegin (not counting c the immediate neighbors of ibegin) c llist=1 kk=ibegin+1 list(1)=kk do 70 l=ibegin+2,iend if(kk.eq.iend) go to 80 kk=kk+1 llist=llist+1 list(llist)=kk ka=list(llist) kb=list(llist-1) aa=geom(index(ibegin),index(kb),index(ka),vx,vy) c c the standard case c if(aa.gt.eps) go to 70 ac=geom(index(kb-1),index(kb),index(ka),vx,vy) c c boundary bends away from ibegin c if(ac.le.eps.or.llist.le.2) then iwind=0 sn=1.0d0 20 if(kk.eq.iend) go to 80 kk=kk+1 list(llist)=kk ak=sn*geom(index(ibegin),index(kb),index(kk),vx,vy) if(ak.gt.eps) then qq=geom(index(ibegin),index(kk-1),index(kk),vx,vy) if(qq.gt.eps) then iwind=iwind-1 if(iwind.lt.0) go to 70 else iwind=iwind+1 endif sn=-sn endif go to 20 endif c c the boundary bends towards ibegin c llist=llist-1 list(llist)=ka c c delete a back points c 30 kb=list(llist-1) aa=geom(index(ibegin),index(kb),index(ka),vx,vy) if(aa.le.eps) then ac=geom(index(ka-1),index(kb),index(ka),vx,vy) c c if we skip outside view c if(ac.ge.eps.or.llist.le.2) then sn=1.0d0 45 if(kk.eq.iend) go to 80 kk=kk+1 list(llist)=kk ak=sn*geom(index(ibegin),index(kb),index(kk), + vx,vy) if(ak.gt.eps) then if(sn.eq.1.0d0) then qq=geom(index(ka-1),index(ka),index(kk), + vx,vy) if(qq.lt.eps) go to 70 endif sn=-sn endif go to 45 endif llist=llist-1 list(llist)=ka go to 30 endif c c look for turning point c if(kk.eq.iend) go to 80 kk=kk+1 llist=llist+1 list(llist)=kk ka=list(llist) kasave=ka kb=list(llist-1) aa=geom(index(ibegin),index(kb),index(ka),vx,vy) if(aa.gt.eps) then ac=geom(index(ka),index(kb),index(kb-1),vx,vy) if(ac.gt.-eps) go to 70 c c now we have to work through the backward bending branch c llist=llist-1 40 if(kk.eq.iend) go to 80 kk=kk+1 list(llist)=kk ak=geom(index(ibegin),index(kb),index(kk),vx,vy) if(ak.ge.eps) go to 40 ka=list(llist) kb=kasave else llist=llist-1 list(llist)=ka endif go to 30 c 70 continue c c make new triangles c 80 if(list(llist).ne.iend) then if(llist.lt.2) stop 8094 list(llist)=iend kb=list(llist-1) aa=geom(index(ibegin),index(kb),index(iend),vx,vy) if(aa.le.0.0d0) then llist=llist-1 go to 80 endif endif nrsv=nrgn ntsv=ntf do i=1,llist-1 ntf=ntf+1 itnode(1,ntf)=index(ibegin) itnode(2,ntf)=index(list(i)) itnode(3,ntf)=index(list(i+1)) itnode(4,ntf)=i4tag itnode(5,ntf)=i5tag if(list(i+1).ne.list(i)+1) then nrgn=nrgn+1 istart(nrgn)=list(i) istop(nrgn)=list(i+1) endif enddo c c this is just a consistency check c mxtri=iend-ibegin-1 nwtri=ntf-ntsv if(nrsv.lt.nrgn) then do m=nrsv+1,nrgn nwtri=nwtri+istop(m)-istart(m)-1 enddo endif c if(mxtri.ne.nwtri) then c call drgrdz(ibegin,iend,index,vx,vy,ntsv,ntf,itnode) c endif if(mxtri.ne.nwtri) stop 6781 if(nrgn.gt.0) go to 10 c* call drgrdx(vx,vy,nvf,ntf0,ntf,itnode) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine eswapk(nt1,nt2,itnode,itedge,vx,vy) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine swaps interior triangle edges in an attempt c to improve the overall quality of the triangulation c itmax=10 tol=0.0d0 c c the main loop c do itnum=1,itmax ichng=0 do i=nt1,nt2 do 15 j=1,3 k=itedge(j,i)/4 if(k.le.i) go to 15 kj=itedge(j,i)-4*k ii=itnode(j,i) j1=index(2,j) j2=index(3,j) n1=itnode(j1,i) n2=itnode(j2,i) kk=itnode(kj,k) q1=geom(n1,kk,ii,vx,vy) q2=geom(n2,ii,kk,vx,vy) r1=geom(n1,n2,ii,vx,vy) r2=geom(n2,n1,kk,vx,vy) if(dmin1(q1,q2).lt.dmin1(r1,r2)+tol) go to 15 c c swap edges c ichng=ichng+1 k1=index(3,kj) k2=index(2,kj) itnode(j1,i)=kk itnode(k2,k)=ii itedge(j,i)=itedge(k1,k) itedge(kj,k)=itedge(j2,i) itedge(j2,i)=k*4+k1 itedge(k1,k)=i*4+j2 c c fixup neighboring elements c li=itedge(j,i)/4 if(li.gt.0) then ll=itedge(j,i)-4*li itedge(ll,li)=4*i+j endif lk=itedge(kj,k)/4 if(lk.gt.0) then ll=itedge(kj,k)-4*lk itedge(ll,lk)=4*k+kj endif 15 continue enddo if(ichng.le.0) return enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cedgek(nvf,nt1,nt2,nb1,nb2,itnode,ibndry,itedge,jb, + vx,vy,list) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),list(*),index(3,3), 1 jb(*) double precision + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine makes the itedge array for the level 1 elements c do i=1,nvf list(i)=0 enddo llist=nvf+nb2-nb1+1+3*(nt2-nt1+1) iptr=nvf+1 do i=iptr,llist,2 list(i)=i+2 enddo list(llist-1)=0 list(llist-2)=0 c c first find adjacent triangles c do i=nt1,nt2 do j=1,3 j2=index(2,j) j3=index(3,j) imax=max0(itnode(j2,i),itnode(j3,i)) imin=min0(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k.le.0) then c c add triangle i, edge j to list c if(iptr.le.0) stop 6666 list(kold)=iptr ii=iptr iptr=list(iptr) list(ii)=0 list(ii+1)=j+4*i else c c check for a common edge c ii=list(k+1)/4 jj=list(k+1)-4*ii j2=index(2,jj) j3=index(3,jj) iimax=max0(itnode(j2,ii),itnode(j3,ii)) if(imax.eq.iimax) then itedge(j,i)=jj+4*ii itedge(jj,ii)=j+4*i list(kold)=list(k) list(k)=iptr iptr=k c c check geometry c c* qi=geom(itnode(j,i),imin,imax,vx,vy) c* qk=geom(itnode(jj,ii),imin,imax,vx,vy) c* if(qi*qk.ge.0.0e0) stop 7777 else kold=k go to 40 endif endif enddo enddo c c match boundary data in ibndry c do ib=nb1,nb2 i=jb(ib) kold=min0(ibndry(1,i),ibndry(2,i)) imax=max0(ibndry(1,i),ibndry(2,i)) 70 k=list(kold) if(k.le.0) stop 5555 ii=list(k+1)/4 jj=list(k+1)-4*ii j2=index(2,jj) j3=index(3,jj) iimax=max0(itnode(j2,ii),itnode(j3,ii)) if(imax.eq.iimax) then itedge(jj,ii)=-i list(kold)=list(k) list(k)=iptr iptr=k else kold=k go to 70 endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine binits(ip,rp,vx,vy,xm,ym,itnode,ibndry,t,tl,q,jp, + iclr,ntf) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),ibndry(6,*),iclr(*), 1 ip(100),tmin(2),tmax(2) double precision + vx(*),vy(*),xm(*),ym(*),t(25),tl(25), 1 rp(100),q(3,3),bmin(3),bmax(3) c c find box containing the solution c call linit(t,q) call zoombx(rp,t) c do i=1,25 jp(i)=0 enddo ntr=ip(1) nvf=ip(2) nbf=ip(4) mpisw=ip(48) icrsn=ip(68) jp(1)=ntf jp(8)=ntr jp(2)=nvf jp(3)=nbf jp(4)=1 jp(12)=mpisw c inplsw=0 jp(9)=inplsw c numbrs=ip(60) if(numbrs.lt.0.or.numbrs.gt.7) numbrs=0 if(mpisw.eq.1.and.numbrs.ne.7) numbrs=0 if(icrsn.eq.1.and.numbrs.ne.7) numbrs=0 jp(21)=numbrs lines=ip(59) if(lines.ne.-1) lines=1 jp(20)=lines c mxcolr=max0(2,ip(51)) mxcolr=min0(256,mxcolr) jp(17)=mxcolr c c compute scaled coordinates c call xybox(nbf,vx,vy,xm,ym,ibndry,bmin(1),bmax(1), + bmin(2),bmax(2),diam) c size=t(14) xs=t(15) ys=t(16) scale=size/dmax1(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmin(1)+bmax(1))/2.0d0 t(2)=ys-scale*(bmin(2)+bmax(2))/2.0d0 t(3)=scale c c comput number of colors for the case of triangles c ii=5 tmin(1)=itnode(5,1) tmax(1)=itnode(5,1) do i=1,ntf tmin(1)=min0(itnode(5,i),tmin(1)) tmax(1)=max0(itnode(5,i),tmax(1)) enddo c jp(5)=tmax(1)-tmin(1)+1 do i=1,ntf iclr(i)=itnode(ii,i)-tmin(1)+1 enddo jp(18)=min0(mxcolr,jp(5)+2) c do i=1,25 tl(i)=t(i) enddo tl(12)=1.0d0 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine binitt(ip,rp,itnode,itedge,ibndry,ibedge,vx,vy, + xm,ym,jtnode,jbndry,vx0,vy0,e,ht,iclr,pstat,kdist, 1 z,t,tl,q,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jtnode(5,*),jbndry(6,*), 1 ip(100),jp(25),iclr(*),num(4),tmin(2),tmax(2), 2 kdist(*),itedge(3,*),ibedge(2,*) double precision + vx(*),vy(*),vx0(*),vy0(*),ht(*),e(*),rp(100),t(25), 1 tl(25),q(3,3),pstat(10,*),bmin(3),bmax(3),val(2), 2 xm(*),ym(*),z(*) c c make temporary copies of main data structures for graphics c ntf=ip(1) nvf=ip(2) nbf=ip(4) mpisw=ip(48) nproc=ip(49) irgn=ip(50) inplsw=ip(53) if(inplsw.gt.6.or.inplsw.lt.0) inplsw=0 icrsn=ip(68) itrgt=ip(69) ibase=ip(70) c do i=1,ntf do j=1,5 itnode(j,i)=jtnode(j,i) enddo ht(i)=0.0d0 enddo if(inplsw.eq.6) then do i=1,ntf ht(i)=e(i) enddo endif do i=1,nvf vx(i)=vx0(i) vy(i)=vy0(i) enddo do i=1,nbf do j=1,6 ibndry(j,i)=jbndry(j,i) enddo enddo c c reduce to elements in region irgn c if(mpisw.eq.1) then call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) call cedge5(nbf,itedge,ibedge,1) call cutr1(ntf,nvf,nbf,irgn,itnode,ibndry,vx,vy, + ht,bmin,bmax,ibedge,z,0) else if(icrsn.eq.1) then newnbf=0 do i=1,nbf if(ibndry(4,i).ne.0) then newnbf=newnbf+1 do j=1,6 ibndry(j,newnbf)=ibndry(j,i) enddo ibndry(4,newnbf)=1 endif enddo nbf=newnbf endif call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) c call linit(t,q) call zoombx(rp,t) c do i=1,25 jp(i)=0 enddo jp(1)=ntf jp(2)=nvf jp(3)=nbf jp(4)=1 jp(23)=nproc jp(12)=mpisw c inplsw=ip(53) if(inplsw.gt.6.or.inplsw.lt.0) inplsw=0 jp(9)=inplsw c numbrs=ip(60) if(numbrs.lt.0.or.numbrs.gt.8) numbrs=0 if(mpisw.eq.1.and.numbrs.ne.7) numbrs=0 if(icrsn.eq.1.and.numbrs.ne.7) numbrs=0 jp(21)=numbrs lines=ip(59) if(lines.lt.-1.or.lines.gt.2) lines=0 if(icrsn.eq.1.and.lines.eq.0) lines=1 jp(20)=lines c mxcolr=max0(2,ip(51)) mxcolr=min0(256,mxcolr) jp(17)=mxcolr c c compute scaled coordinates c call xybox(nbf,vx,vy,xm,ym,ibndry,bmin(1),bmax(1), + bmin(2),bmax(2),diam) c if(mpisw.eq.1) then call exbox(bmin,bmax,2) diam=dsqrt((bmax(1)-bmin(1))**2+(bmax(2)-bmin(2))**2) endif c size=t(14) xs=t(15) ys=t(16) scale=size/dmax1(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmin(1)+bmax(1))/2.0d0 t(2)=ys-scale*(bmin(2)+bmax(2))/2.0d0 t(3)=scale c c c comput number of colors for the case of triangles c if(inplsw.ge.2.and.inplsw.le.4) then jp(5)=6 call tinit(jp,itnode,iclr,vx,vy,num,val) c if(mpisw.eq.1) call exqual(num,val) c t(21)=100.0d0*dfloat(num(1))/dfloat(num(4)) t(22)=100.0d0*dfloat(num(2))/dfloat(num(4)) t(23)=100.0d0*dfloat(num(3))/dfloat(num(4)) t(24)=dabs(val(1)) t(25)=val(2)/dfloat(num(4)) else if(inplsw.ge.5.and.inplsw.le.6) then ncolor=min0(ip(56),mxcolr-2) ncolor=max0(1,ncolor) jp(5)=ncolor if(inplsw.eq.5) then do i=1,ntf ht(i)=ch(itnode(1,i),itnode(2,i), + itnode(3,i),vx,vy)/diam enddo endif ii=0 if(ncolor.gt.0) ii=1 bmin(3)=ht(1) bmax(3)=ht(1) do i=1,ntf iclr(i)=ii bmin(3)=dmin1(ht(i),bmin(3)) bmax(3)=dmax1(ht(i),bmax(3)) enddo c if(mpisw.eq.1) call exbox(bmin(3),bmax(3),1) c if(rp(9).le.rp(8)) then t(19)=bmin(3) t(20)=bmax(3) else t(19)=rp(8) t(20)=rp(9) endif c iscale=ip(58) if(t(19).le.0.0d0) iscale=2 jp(19)=iscale zmin=fscale(t(19),iscale,0) zmax=fscale(t(20),iscale,0) if(zmax.gt.zmin) then dd=dfloat(ncolor)/(zmax-zmin) do i=1,ntf zz=fscale(ht(i),iscale,0) iq=max0(1,idint((zz-zmin)*dd)+1) iclr(i)=min0(ncolor,iq) enddo endif c call cdist(jp,t,ht,kdist) nn=2*min0(ncolor,11) if(mpisw.eq.1) call exdist(kdist,nn) jp(6)=1 else if(inplsw.eq.1) then jp(5)=nproc jp(7)=0 c if(mpisw.eq.1) then call exstat(pstat,ht) jp(7)=1 endif c do i=1,ntf iclr(i)=max0(1,itnode(4,i)) enddo else ii=5 tmin(1)=itnode(5,1) tmax(1)=itnode(5,1) do i=1,ntf tmin(1)=min0(itnode(5,i),tmin(1)) tmax(1)=max0(itnode(5,i),tmax(1)) enddo c if(mpisw.eq.1) call exibox(tmin,tmax,1) c jp(5)=tmax(1)-tmin(1)+1 do i=1,ntf iclr(i)=itnode(ii,i)-tmin(1)+1 enddo endif jp(18)=min0(mxcolr,jp(5)+2) c do i=1,25 tl(i)=t(i) enddo tl(12)=1.0d0 c c coarsen the mesh c if(icrsn.eq.1) then ivtype=1 iseed=ivtype+nvf ipp=iseed+nvf iqq=ipp+nvf iqual=iqq+nvf c call crsn0(nvf,ntf,nbf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,z(ivtype),z(ipp),z(iqq),z(iqual), 1 z(iseed),iclr,ibase) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) c if(mpisw.eq.1) then nvtrgt=max0(3,itrgt/nproc) else nvtrgt=max0(3,itrgt) endif if(inplsw.lt.5.or.nvf.le.nvtrgt) go to 20 c itmax=10 do itnum=1,itmax if(itnum.le.1) then call smth1(ntf,itedge,iclr) else call smth2(ntf,itedge,itnode,vx,vy,iclr) endif call crsn0(nvf,ntf,nbf,itnode,ibndry,vx,vy, + xm,ym,itedge,ibedge,z(ivtype),z(ipp), 1 z(iqq),z(iqual),z(iseed),iclr,ibase) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,vx,vy,z,iflag) if(nvf.le.nvtrgt) go to 20 enddo endif c 20 jp(1)=ntf jp(2)=nvf jp(3)=nbf return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cutr1(ntf,nvf,nbf,irgn,itnode,ibndry,vx,vy, + e,ut,vt,ibedge,mark,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),mark(*),index(3,3) double precision + vx(*),vy(*),e(*),ut(3,*),vt(3,*) save index data index/1,2,3,2,3,1,3,1,2/ c c mark edges c newnbf=0 do i=1,nbf kk=0 if(ibndry(4,i).ne.0) then k1=ibedge(1,i)/4 krgn=itnode(4,k1) if(krgn.eq.irgn) kk=ibedge(1,i) else k1=ibedge(1,i)/4 k2=ibedge(2,i)/4 k1rgn=itnode(4,k1) k2rgn=itnode(4,k2) j1rgn=itnode(5,k1) j2rgn=itnode(5,k2) if(k1rgn.eq.irgn.and.k2rgn.ne.irgn) kk=ibedge(1,i) if(k1rgn.ne.irgn.and.k2rgn.eq.irgn) kk=ibedge(2,i) endif if(kk.ne.0) then newnbf=newnbf+1 do j=1,6 ibndry(j,newnbf)=ibndry(j,i) enddo kt=kk/4 ke=kk-4*kt ibndry(1,newnbf)=itnode(index(2,ke),kt) ibndry(2,newnbf)=itnode(index(3,ke),kt) if(ibndry(4,newnbf).eq.0) then ibndry(4,newnbf)=3 if(j1rgn.ne.j2rgn) ibndry(4,newnbf)=4 else if(ibndry(4,newnbf).lt.0) then ibndry(4,newnbf)=1 endif endif enddo c c order triangles in region irgn first c newntf=0 do i=1,ntf if(itnode(4,i).eq.irgn) then newntf=newntf+1 do j=1,5 itnode(j,newntf)=itnode(j,i) enddo if(isw.eq.1) then do j=1,3 ut(j,newntf)=ut(j,i) vt(j,newntf)=vt(j,i) enddo else e(newntf)=e(i) endif endif enddo c c mark vertices c do i=1,nvf mark(i)=0 enddo do i=1,newntf do j=1,3 mark(itnode(j,i))=1 enddo enddo newnvf=0 do i=1,nvf if(mark(i).ne.0) then newnvf=newnvf+1 mark(i)=newnvf vx(newnvf)=vx(i) vy(newnvf)=vy(i) endif enddo do i=1,newntf do j=1,3 itnode(j,i)=mark(itnode(j,i)) enddo enddo do i=1,newnbf do j=1,2 ibndry(j,i)=mark(ibndry(j,i)) enddo enddo c nvf=newnvf ntf=newntf nbf=newnbf return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tstvti(i,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3),iv(3), 1 vtype(*),elist(500),tlist(500),vlist(500),corner(9) double precision + xm(*),ym(*),vx(*),vy(*),c(3) save index,corner data index/1,2,3,2,3,1,3,1,2/ data corner/0,0,1,0,1,0,1,0,1/ c c test for vertex type for inplt coarsening c jcount=0 icount=0 if(vtype(i).le.5) then vtype(i)=1 l2=len+1 else vtype(i)=6 l2=len-1 endif do ll=2,l2 i1=tlist(ll) i2=tlist(ll+1) if(itnode(4,i1).ne.itnode(4,i2).or. + itnode(5,i1).ne.itnode(5,i2)) then icount=icount+1 if(icount.le.2) iv(icount)=ll+1 ke=iabs(elist(ll+1)) if(itedge(index(3,ke),i2).lt.0) jcount=jcount+1 endif enddo c if(vtype(i).eq.1) then if(icount.lt.2) return vtype(i)=3 if(icount.eq.2) then aa=dabs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(dabs(aa-1.0d0).lt.angmin) vtype(i)=2 endif else if(vtype(i).eq.6) then vtype(i)=7 if(icount.gt.0) return ie1=iabs(tlist(1)) ie2=iabs(tlist(len+1)) if(ibndry(6,ie1).ne.ibndry(6,ie2)) return if(ibndry(4,ie1).ne.ibndry(4,ie2)) return if(max0(ibndry(3,ie1),ibndry(3,ie2)).gt.0) then if(ibndry(3,ie1).ne.ibndry(3,ie2)) return endif if(ibndry(3,ie1).le.0) then aa=dabs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(dabs(aa-1.0d0).lt.angmin) vtype(i)=6 else tol=1.0d-1 iv(1)=vlist(2) iv(2)=vlist(len+1) iv(3)=i do kk=3,len k=vlist(kk) call bari(vx(k),vy(k),vx,vy,iv,c) if(dmin1(c(1),c(2),c(3)).ge.-tol) return enddo kt=ibndry(3,ie1) call arc(vx(iv(1)),vy(iv(1)),vx(iv(2)),vy(iv(2)), + xm(kt),ym(kt),theta1,theta2,r,alen) if(dabs(theta2-theta1).le.arcmax) vtype(i)=6 endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine crsn0(nvf,ntf,nbf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,p,q,qual,iseed,icolor,ibase) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),iseed(*),itedge(3,*),vtype(*), 1 ibedge(2,*),icolor(*),p(*),q(*),corner(9), 2 elist(500),tlist(500),vlist(500),blist(500),vsv(500) double precision + xm(*),ym(*),vx(*),vy(*),bump(3),e(3),qual(*) save corner data corner/0,0,1,0,1,0,1,0,1/ c c check to see if we have solved problem on current finest grid c idbcpt=0 lenb=3 hmin=0.0d0 coeff=0.0d0 angmin=1.0d-3 cc angmin=1.0e-4 arcmax=0.26d0 cc arcmax=0.1e0 c c initailize iseed, vtype c call cvtype(ntf,nbf,nvf,idbcpt,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c c initialize qual, p,q c do i=1,nvf p(i)=i q(i)=i call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) call tstvti(i,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) qual(i)=gqual(i,tlist,elist,len,vtype,icolor) enddo c c initialize heap c nn=nvf/2 do k=nn,1,-1 call updhp(k,nvf,p,q,qual,0) enddo last=nvf c c main elimination loop c call cedge5(nbf,itedge,ibedge,1) do nn=nvf,1,-1 i=p(1) if(qual(i).le.0.0d0) go to 60 p(1)=p(last) p(last)=i q(p(last))=last q(p(1))=1 last=last-1 call updhp(1,last,p,q,qual,0) c c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) lvsv=0 do j=2,len+1 if(corner(vtype(vlist(j))).ne.1) then lvsv=lvsv+1 vsv(lvsv)=vlist(j) endif enddo c c reduce to degree 3 or 4 by edge swapping c call reduc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,hmin,coeff,0,iflag) c if(corner(vtype(i)).eq.1) stop 6235 if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist,len, 1 hmin,coeff,ibase,0) else qual(i)=0.0d0 last=last+1 endif c c update vertices in connected to i c do jj=1,lvsv j=vsv(jj) qual(j)=0.0d0 call cirlst(j,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) if(vtype(j).ne.1) then call tstvti(j,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) endif qual(j)=gqual(j,tlist,elist,len,vtype,icolor) kk=q(j) call updhp(kk,last,p,q,qual,1) enddo enddo 60 call clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge,vx,vy, + icolor,iseed) c c improve geometry c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,vtype,jflag) call cedge5(nbf,itedge,ibedge,1) call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,0) call cedge5(nbf,itedge,ibedge,0) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- double precision function gqual(i,tlist,elist,len,vtype,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + vtype(*),tlist(500),elist(500),corner(9),ie(2), 1 icolor(*),ic(2) save corner data corner/0,0,1,0,1,0,1,0,1/ c c compute quality funtion for vertex c gqual=0.0d0 if(corner(vtype(i)).eq.1) return if(len.gt.10) return c if(vtype(i).ge.6) then do j=2,len-1 it1=iabs(tlist(j)) it2=iabs(tlist(j+1)) if(icolor(it1).ne.icolor(it2)) return enddo gqual=0.5d0 if(len.ge.4) gqual=0.5d0/dfloat(len) else k=0 do j=2,len+1 it1=iabs(tlist(j)) it2=iabs(tlist(j-1)) if(icolor(it1).ne.icolor(it2)) then k=k+1 if(k.le.2) ic(k)=j endif enddo if(vtype(i).ne.1) then if(k.gt.2) return m=0 do j=2,len+1 if(elist(j).lt.0) then m=m+1 ie(m)=j endif enddo if(m.ne.2) stop 7666 if(k.eq.2) then if(ic(1).ne.ie(1)) return if(ic(2).ne.ie(2)) return endif if(len.eq.4) then if(iabs(ie(1)-ie(2)).ne.2) return endif else if(k.ne.0) return endif gqual=2.0d0 if(len.eq.5) gqual=1.0d0 if(len.ge.6) gqual=3.0d0/dfloat(len) endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,icolor,mark) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ibedge(2,*), 1 mark(*),icolor(*) double precision + vx(*),vy(*) c c clean up data structure after vertex elimination c c fixup itnode, itedge, bump c ntnew=0 do i=1,ntf if(itnode(1,i).ne.0) then ntnew=ntnew+1 mark(i)=ntnew do j=1,5 itnode(j,ntnew)=itnode(j,i) enddo do j=1,3 itedge(j,ntnew)=itedge(j,i) enddo icolor(ntnew)=icolor(i) else mark(i)=0 endif enddo do i=1,nbf ibedge(1,i)=0 ibedge(2,i)=0 enddo do i=1,ntnew do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 ke=itedge(j,i)-4*k itedge(j,i)=4*mark(k)+ke else m=-itedge(j,i) if(ibedge(1,m).gt.0) then ibedge(2,m)=4*i+j else ibedge(1,m)=4*i+j endif endif enddo enddo ntf=ntnew c c fixup ibndry...note internal interface edges are put in itedge c nbnew=0 do i=1,nbf if(ibndry(1,i).ne.0) then nbnew=nbnew+1 mark(i)=nbnew do j=1,6 ibndry(j,nbnew)=ibndry(j,i) enddo ibedge(1,nbnew)=ibedge(1,i) ibedge(2,nbnew)=ibedge(2,i) k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew).gt.0) then k=ibedge(2,nbnew)/4 ke=ibedge(2,nbnew)-4*k itedge(ke,k)=-nbnew endif else mark(i)=0 endif enddo nbf=nbnew c c periodic edges c do i=1,nbf if(ibndry(4,i).lt.0) then k=-ibndry(4,i) ibndry(4,i)=-mark(k) endif enddo c c now fix vertex arrays c do i=1,nvf mark(i)=0 enddo do i=1,ntf do j=1,3 mark(itnode(j,i))=1 enddo enddo nvnew=0 do i=1,nvf if(mark(i).ne.0) then nvnew=nvnew+1 mark(i)=nvnew vx(nvnew)=vx(i) vy(nvnew)=vy(i) endif enddo nvf=nvnew do i=1,ntf do j=1,3 itnode(j,i)=mark(itnode(j,i)) enddo enddo do i=1,nbf do j=1,2 ibndry(j,i)=mark(ibndry(j,i)) enddo enddo c c orient triangles c do i=1,ntf r=geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) if(r.lt.0.0d0) then itemp=itnode(2,i) itnode(2,i)=itnode(3,i) itnode(3,i)=itemp endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine smth1(ntf,itedge,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + icolor(*),ic(3),itedge(3,*) c itmax=2 c do itnum=1,itmax ichng=0 do i=1,ntf num=0 do j=1,3 if(itedge(j,i).gt.0) then num=num+1 ii=itedge(j,i)/4 ic(num)=icolor(ii) endif enddo ii=icolor(i) if(num.eq.2) then if(ic(1).eq.ic(2).and.ii.ne.ic(1)) then ichng=ichng+1 icolor(i)=ic(1) endif else if(num.eq.3) then isw=0 if(ic(1).eq.ic(2)) isw=isw+1 if(ic(1).eq.ic(3)) isw=isw+1 if(isw.gt.0.and.ii.ne.ic(1)) then ichng=ichng+1 icolor(i)=ic(1) elseif(ic(2).eq.ic(3).and.ii.ne.ic(2)) then ichng=ichng+1 icolor(i)=ic(2) endif else if(num.eq.1) then if(ii.ne.ic(1)) then ichng=ichng+1 icolor(i)=ic(1) endif endif enddo if(ichng.eq.0) return enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine smth2(ntf,itedge,itnode,vx,vy,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + icolor(*),itedge(3,*),itnode(5,*) double precision + vx(*),vy(*) c itmax=1 theta=0.05d0 c hmin=ch(itnode(1,1),itnode(2,1),itnode(3,1),vx,vy) hmax=hmin do i=1,ntf hh=ch(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) hmin=dmin1(hh,hmin) hmax=dmax1(hh,hmax) enddo thrsh=hmin+theta*(hmax-hmin) c do itnum=1,itmax do i=1,ntf hh=ch(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) if(hh.le.thrsh) then num=2 q=dfloat(2*icolor(i))+0.5d0 do j=1,3 if(itedge(j,i).gt.0) then num=num+2 ii=itedge(j,i)/4 q=q+dfloat(icolor(ii)+icolor(i)) endif enddo q=q/dfloat(num) icolor(i)=idint(q) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine tplot(vx,vy,ibndry,itnode,xm,ym,t,jp,itedge,iclr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),jp(25),ccolor, 1 iclr(*),index(3,3),ibdy(192) double precision + vx(*),vy(*),xm(*),ym(*),t(25),x(2),y(2),z(2), 1 c(3,192),q(3,3),bx(3),by(3),bz(3) save index,q data index/1,2,3,2,3,1,3,1,2/ data q/1.0d0,0.0d0,0.0d0,0.0d0,1.0d0,0.0d0, + 0.0d0,0.0d0,1.0d0/ c c draw triangle data c ntf=jp(1) lines=jp(20) c xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) zval=0.0d0 c c color triangles c do ii=1,ntf c c compute triangle boundary c call tbdy(c,ibdy,ntri,ii,itnode,ibndry,itedge, + vx,vy,xm,ym,q,0) c iv1=itnode(1,ii) iv2=itnode(2,ii) iv3=itnode(3,ii) ic=iclr(ii) icolor=ccolor(ic,0,jp) do itri=1,3*ntri,3 do mm=1,3 m=mm+itri-1 xx=c(1,m)*vx(iv1)+c(2,m)*vx(iv2)+c(3,m)*vx(iv3) yy=c(1,m)*vy(iv1)+c(2,m)*vy(iv2)+c(3,m)*vy(iv3) bx(mm)=xx*scale+xshift by(mm)=yy*scale+yshift bz(mm)=zval*scale+zshift enddo call pwindw(bx,by,bz,3,t,icolor) c c line drawing c do m=1,3 k=ibdy(itri+m-1) isw=0 if(lines.eq.-1) then isw=1 else if(lines.eq.0.and.k.ge.0) then isw=1 else if(k.eq.1) then isw=1 else if(k.gt.1) then if(lines.eq.1) then if(k.eq.2.or.k.eq.5) isw=1 else if(lines.eq.2) then if(k.eq.3.or.k.eq.5) isw=1 endif endif if(isw.eq.1) then x(1)=bx(index(2,m)) y(1)=by(index(2,m)) z(1)=bz(index(2,m)) x(2)=bx(index(3,m)) y(2)=by(index(3,m)) z(2)=bz(index(3,m)) call lwindw(x,y,z,2,t,2) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sfix(list,length,val,ndig) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + mlen character*1 + list(*),zero,minus,temp(100),dot save minus,zero,dot data minus,dot,zero/'-','.','0'/ c c compute character string for fixed point number c if(val.eq.0.0d0) then length=ndig+1 do i=1,length list(i)=zero enddo list(2)=dot return endif zc=dabs(val) zz=dlog10(zc) iex=idint(zz) mdig=min0(ndig,ndig-iex) mdig=max0(0,mdig) tt=zc*(10.0d0**mdig)+0.5d0 n=idint(tt) if(n.eq.0) then do i=1,ndig+2 list(i)=zero enddo if(val.ge.0.0d0) then length=ndig+1 list(2)=dot else length=ndig+2 list(1)=minus list(3)=dot endif return endif call sint(temp,mlen,n) if(mlen.le.ndig) then do i=mlen,1,-1 temp(ndig-mlen+i+1)=temp(i) enddo do i=1,ndig+1-mlen temp(i)=zero enddo mlen=ndig+1 endif if(val.gt.0.0d0) then length=mlen+1 ishift=0 else length=mlen+2 ishift=1 list(1)=minus endif do i=1,mlen-mdig list(i+ishift)=temp(i) enddo ishift=ishift+1 list(mlen-mdig+ishift)=dot do i=mlen-mdig+1,mlen list(i+ishift)=temp(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine htext(xl,yl,xr,yr,nchr,cchr,ijust,q,t,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ichr(80),symbcd(640),istart(94),map(128) double precision + width(94),x(2),y(2),z(2),t(25),q(3,3) character*1 + cchr(*),cc save symbcd,istart,width,map c c writes text given in cchr array in the rectangle defined by its c lower left corner of world coordinates xl,yl and its upper right c corner of world coordinates xr,yr. c c ijust=-1 for justification on the left c ijust= 0 for centered text c ijust=+1 for justification on the right c c the symbol numbers are c 1-26 upper case roman simplex c 27-52 lower case roman simplex c 53-62 simplex numbers c 63-78 symbols + - ( ) , . / = * $ < > { } @ ^ c 79-94 symbols [ ] # : ; ! ? % & ~ " ' _ \ | ` c c c symbol parameters taken from n.m.wolcott, fortran iv enhanced c character graphics, nbs c ichr(j) contains the symbol number of the jth symbol c everything outside this range is considered a space c data (symbcd(i),i=1,60)/ + 443556555,443557579,432612882, 0,433070987,433071584, 1 323987166,328083226,325854871,317404054,317400725,325723922, 2 327657165,323364299,298156032,462268125,321889760,309339231, 3 300852123,296493907,298329038,304489675,317040204,325527312, 4 0,433070987,433071456,319792797,325953304,327788240, 5 323429900,312845195, 0,433070987,433071840,432743830, 6 432383691, 0,433070987,433071840,432743830, 0, 7 462268125,321889760,309339231,300852123,296493907,298329038, 8 304489675,317040204,325527312,327792083,327778304,433070987, 9 462432011,432744214, 0,433070987, 0,449848720/ data (symbcd(i),i=61,120)/ + 312911116,306553867,298197837,294134546, 0,433070987, 1 462431122,443262731, 0,433070987,432383627, 0, 2 433070987,433071499,466625931,466626443, 0,433070987, 3 433071883,462432011, 0,443556959,300852123,296493907, 4 298329038,304489675,317040204,325527312,329885528,328050397, 5 321889760,309329920,433070987,433071584,323987166,328083225, 6 325822102,317367189, 0,443556959,300852123,296493907, 7 298329038,304489675,317040204,325527312,329885528,328050397, 8 321889760,309343631,327450624,433070987,433071584,323987166, 9 328083226,325854871,317399958,447424267, 0,460236383/ data (symbcd(i),i=121,180)/ + 315630752,300917597,296592281,300688471,317367892,323593937, 1 325527116,314942603,300294990, 0,441459851,426780256, 2 0,433070993,300360780,310748555,321267406,327722784, 3 0,426779851,460334283, 0,428876875,449848395, 4 449849035,470820555, 0,430974667,460333899, 0, 5 426779862,308655840,309002240,460333899,430974688,430286539, 6 0,455910987,455812568,313304217,302785430,296330065, 7 298263564,306554187,317072974, 0,433070987,432743448, 8 307012953,317466198,323593873,321332684,312845451,302392206, 9 0,455812568,313304217,302785430,296330065,298263564/ data (symbcd(i),i=181,240)/ + 306554187,317072974, 0,456140363,455812568,313304217, 1 302785430,296330065,298263564,306554187,317072974, 0, 2 430548563,321562135,317465945,307012632,298525523,296264590, 3 302392459,312845772,321323008,445654176,303014876,300266265, 4 309100544,455910985,318973381,312616068,302167638,317465945, 5 307012632,298525523,296264590,302392459,312845772,321323008, 6 433070987,432710744,309110169,319563349,321224704,430973855, 7 300950433,296760217,298156032,435168287,305144865,300954649, 8 302261189,295838404, 0,433070987,453813135,441034315, 9 0,433070987, 0,432841611,432710744,309110169/ data (symbcd(i),i=241,300)/ + 319563349,321238613,327952281,338471128,344631563, 0, 1 432841611,432710744,309110169,319563349,321224704,441230360, 2 298525523,296264590,302392459,312845772,321332881,323593814, 3 317465945,307003392,432841604,432743448,307012953,317466198, 4 323593873,321332684,312845451,302392206, 0,455910980, 5 455812568,313304217,302785430,296330065,298263564,306554187, 6 317072974, 0,432841611,432645078,304882905,315392000, 7 453715416,311207001,298591062,298460179,313075153,319268366, 8 317072651,304456588,296157184,435168207,302392459,310752025, 9 309100544,432841615,300295243,310748556,321369689,321224704/ data (symbcd(i),i=301,360)/ + 428647563,453813387, 0,430744651,447521867,447522379, 1 464299595, 0,430745099,453813067, 0,428647563, 2 453813387,302228357,293741252, 0,453813067,430745113, 3 430286347, 0,443556895,298722135,296362895,302392523, 4 312845836,323462868,325822108,319792480,309329920,437134493, 5 313533771, 0,432907164,300885023,307242400,319792734, 6 323888794,321660373,296068811, 0,435168928,311174616, 7 321627798,325691089,323429900,312845451,300295053,296189952, 8 451945298,327759328,317030400,456139744,298558424,307012953, 9 319563414,325691089,323429900,312845451,300295053,296189952/ data (symbcd(i),i=361,420)/ + 458139231,315630880,305112028,298558354,300360780,310748491, 1 319170190,325625554,323659287,313271576,304849877,298385408, 2 460334155,430974688, 0,441459679,298754971,300721240, 3 313239062,323626706,325559949,321267083,306553804,298230607, 4 296297364,302720215,317466201,323856029,321889696,307232768, 5 458008150,317334803,308913172,298525529,296559517,303015136, 6 311436767,321824409,323626575,317072651,306553804,298254336, 7 451847627,432678932, 0,432678932, 0,447882466, 8 305112027,298525586,300328009,308487492, 0,431104994, 9 305112283,311108882,308716617,300098372, 0,436609995/ data (symbcd(i),i=421,480)/ + 298197965,302392330,300163975, 0,434545548,300262412, 1 300318720,466756356, 0,432777239,432580625, 0, 2 441263246,430679505,451650385, 0,441590919,449979783, 3 460236383,315630752,300917597,296592281,300688471,317367892, 4 323593937,325527116,314942603,300294990, 0,466527124, 5 331710464,432973716,298156032,443688035,303113184,300885020, 6 304981145,306947093,439460897,303015005,307111130,309077142, 7 298460306,308815054,306586699,302294023,304264211,306750607, 8 304522252,300229576,302195781,308412416,435299427,307307744, 9 309273756,304981017,302752917,439461025,307209309,302916570/ data (symbcd(i),i=481,540)/ + 300688406,311043090,300426190,302392395,306488455,304264339, 1 302556175,304522380,308618440,306390085,300023808,462169818, 2 321758619,311239897,306914451,308847952,319301265,325694875, 3 311207126,308913425,313014043,325691089,329787344,338241685, 4 340502618,336471966,328181344,315630815,305079260,298656599, 5 296362897,300393549,308684171,321234700,331786190,464365331, 6 327722832, 0,426321109,325661394,309012178, 0, 7 433202052,435299268,433202532,432153924, 0,443688132, 8 445785348,431105316,430056708, 0,447751044,460334340, 9 432711445,430417615, 0,434938776,300655640,300725197/ data (symbcd(i),i=541,600)/ + 298197963,302392269, 0,434938776,300655640,300725195, 1 298197965,302392330,300163975, 0,435168158,300491806, 2 300954590,300692429,298197963,302392269, 0,432939995, 3 298656603,296625054,300917856,311436767,319759964,321725976, 4 317433045,308884768,315598302,319694362,317465942,442934412, 5 308651276,308707328,468722507,441459998,311305434,304915417, 6 296592221,298820640,307242271,317662878,330278880,459875921, 7 319268365,323331851,331753422,333981522,325648384,468461463, 8 334178327,336340953,332179288,327886481,319235468,310748235, 9 298197838,296264595,311141785,317564381,315598112,307209309/ data (symbcd(i),i=601,640)/ + 304981144,311076430,325461899,333817868,335983691,300295054, 1 298361811,304788571,307013262,327559051, 0,430482259, 2 298525719,306947350,319399570,327755667,334148435,298492950, 3 306914581,319366801,327722898,334145495, 0,435168153, 4 437265305,451945881,454043033, 0,443557017,445654169, 5 0,432351242, 0,429008772, 0,439493700, 6 0,430973849,428876697, 0/ c data istart/ + 1, 5, 16, 26, 34, 39, 43, 54, 58, 60, 66, 70, 1 73, 78, 82, 93, 100, 112, 120, 131, 134, 140, 143, 148, 2 151, 154, 158, 167, 176, 184, 193, 202, 206, 217, 222, 226, 3 232, 236, 238, 247, 252, 261, 270, 279, 283, 292, 296, 301, 4 304, 309, 312, 317, 321, 330, 333, 341, 349, 352, 361, 373, 5 376, 391, 403, 406, 408, 414, 420, 425, 428, 430, 433, 437, 6 450, 452, 454, 473, 492, 519, 523, 528, 533, 538, 544, 551, 7 558, 573, 588, 612, 624, 629, 632, 634, 636, 638/ c data (width(i),i=1,45)/ + 18.0d0,21.0d0,21.0d0,21.0d0,19.0d0,18.0d0,21.0d0,22.0d0, 1 8.0d0,16.0d0,21.0d0,17.0d0,24.0d0,22.0d0,22.0d0,21.0d0, 2 22.0d0,21.0d0,20.0d0,16.0d0,22.0d0,18.0d0,24.0d0,20.0d0, 3 18.0d0,20.0d0,19.0d0,19.0d0,18.0d0,19.0d0,18.0d0,12.0d0, 4 19.0d0,19.0d0, 8.0d0,10.0d0,17.0d0, 8.0d0,30.0d0,19.0d0, 5 19.0d0,19.0d0,19.0d0,13.0d0,17.0d0/ data (width(i),i=46,94)/ + 12.0d0,19.0d0,16.0d0,22.0d0,17.0d0,16.0d0,17.0d0,20.0d0, 1 20.0d0,20.0d0,20.0d0,20.0d0,20.0d0,20.0d0,20.0d0,20.0d0, 2 20.0d0,26.0d0,26.0d0,14.0d0,14.0d0,10.0d0,10.0d0,22.0d0, 3 26.0d0,16.0d0,20.0d0,24.0d0,24.0d0,14.0d0,14.0d0,27.0d0, 4 22.0d0,14.0d0,14.0d0,21.0d0,10.0d0,10.0d0,10.0d0,18.0d0, 5 24.0d0,25.0d0,24.0d0,16.0d0, 8.0d0,26.0d0,22.0d0,14.0d0, 6 8.0d0/ c data map/ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2 0,84,89,81,72,86,87,90,65,66,71,63,67,64,68,69, 3 53,54,55,56,57,58,59,60,61,62,82,83,73,70,74,85, 4 77, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 5 16,17,18,19,20,21,22,23,24,25,26,79,92,80,78,91, 6 94,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41, 7 42,43,44,45,46,47,48,49,50,51,52,75,93,76,88, 0/ c c ixtrct gets nbits from iword starting at the nstart c bit from the right c ixtrct(nstart,nbits,iword)=mod(iword/(2**(nstart-nbits)), + 2**nbits)+((1-isign(1,iword))/2)* 1 (2**nbits-min0(1,mod(-iword,2**(nstart-nbits)))) c if(nchr.le.0) return if(xl.ge.xr) return if(yl.ge.yr) return c do i=1,nchr cc=cchr(i) ii=ichar(cc) ichr(i)=map(ii+1) enddo dx=xr-xl dy=yr-yl c c find width of strings to be plotted c wid=0.0d0 do i=1,nchr ic=ichr(i) if(ic.lt.1.or.ic.gt.94) then wid=wid+20.0d0 else wid=wid+width(ic) endif enddo wid=wid/21.0d0 c height=dmin1(dx/wid,dy) if(height.lt.dy) then x0=xl y0=yl+(dy-height)/2.0d0 else c c justification c y0=yl if(ijust.eq.-1) then x0=xl elseif(ijust.eq.0) then x0=xl+(dx-wid*height)/2.0d0 elseif(ijust.eq.1) then x0=xr-wid*height endif endif c scale=t(3) xshift=t(1) yshift=t(2) zshift=t(5) c rscale=height/21.0d0 xi=x0 yi=y0 c do 100 i=1,nchr ic=ichr(i) if(ic.le.0.or.ic.gt.94)then c c plot a space c xi=xi+20.0d0*rscale else c c plot a double symbol c is=istart(ic) ib=30 70 ipen=ixtrct(ib,3,symbcd(is)) if(ipen.eq.0)then xi=xi+rscale*width(ic) goto 100 endif ix=ixtrct(ib-3,6,symbcd(is)) iy=ixtrct(ib-9,6,symbcd(is)) xx=xi+(ix-10)*rscale yy=yi+(iy-11)*rscale xm=xx*q(1,1)+yy*q(2,1) ym=xx*q(1,2)+yy*q(2,2) zm=xx*q(1,3)+yy*q(2,3) xx=xm*scale+xshift yy=ym*scale+yshift zz=zm*scale+zshift if(ipen.eq.2) then x(2)=xx y(2)=yy z(2)=zz call lwindw(x,y,z,2,t,icolor) endif x(1)=xx y(1)=yy z(1)=zz ib=45-ib if(ib.eq.30)is=is+1 goto 70 endif 100 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pwindw(x,y,z,llen,t,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*),t(25),xn(22),yn(22),zn(22), 1 x0(22),y0(22),z0(22),cx(4),cy(4),cc(4) save cx,cy,cc data cx/1.0d0,-1.0d0,0.0d0,0.0d0/ data cy/0.0d0,0.0d0,1.0d0,-1.0d0/ data cc/0.0d0,0.0d0,0.0d0,0.0d0/ c c map a polygon onto the current window c rmag=t(12) if(rmag.le.1.0d0) then call pfill(x,y,z,llen,icolor) return endif c nmax=22 eps=t(7)/rmag shift=(1.0d0-t(14))/2.0d0 cc(1)=-t(8) cc(2)=t(9) cc(3)=-t(10) cc(4)=t(11) c do i=1,llen xn(i)=x(i) yn(i)=y(i) zn(i)=z(i) enddo num=llen c do k=1,4 len=num num=0 do i=1,len x0(i)=xn(i) y0(i)=yn(i) z0(i)=zn(i) enddo do i=1,len si=x0(i)*cx(k)+y0(i)*cy(k)+cc(k) if(si.ge.eps) then num=num+1 xn(num)=x0(i) yn(num)=y0(i) zn(num)=z0(i) else ibef=i-1 if(i.eq.1) ibef=len iaft=i+1 if(i.eq.len) iaft=1 j=ibef do jj=1,2 s=x0(j)*cx(k)+y0(j)*cy(k)+cc(k) if(s.gt.eps) then num=num+1 f=s/(s-si) xn(num)=x0(i)*f+x0(j)*(1.0d0-f) yn(num)=y0(i)*f+y0(j)*(1.0d0-f) zn(num)=z0(i)*f+z0(j)*(1.0d0-f) endif j=iaft enddo endif enddo if(num.le.2) return if(num.ge.nmax-2) stop 7577 enddo do i=1,num xn(i)=(xn(i)+cc(1))*rmag+shift yn(i)=(yn(i)+cc(3))*rmag+shift cc zn(i)=zn(i)*rmag enddo call pfill(xn,yn,zn,num,icolor) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine lwindw(x,y,z,n,t,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*),t(25),xx(2),yy(2),zz(2) c c draw the part of the picture within the current window c rmag=t(12) if(rmag.le.1.0d0) then call pline(x,y,z,n,icolor) return endif c xl=t(8) xr=t(9) yb=t(10) yt=t(11) shift=(1.0d0-t(14))/2.0d0 c c the main loop c do 100 i=2,n xx(1)=x(i-1) yy(1)=y(i-1) zz(1)=z(i-1) xx(2)=x(i) yy(2)=y(i) zz(2)=z(i) c c fit line into window in x direction c jl=1 if(xx(2).lt.xx(1)) jl=2 jr=3-jl if(xx(jr).le.xl.or.xx(jl).ge.xr) go to 100 c if(xx(jl).lt.xl) then f=(xx(jr)-xl)/(xx(jr)-xx(jl)) xx(jl)=xl yy(jl)=yy(jl)*f+yy(jr)*(1.0d0-f) zz(jl)=zz(jl)*f+zz(jr)*(1.0d0-f) endif c if(xx(jr).gt.xr) then f=(xr-xx(jl))/(xx(jr)-xx(jl)) xx(jr)=xr yy(jr)=yy(jr)*f+yy(jl)*(1.0d0-f) zz(jr)=zz(jr)*f+zz(jl)*(1.0d0-f) endif c c fit line into window in y direction c jb=1 if(yy(2).lt.yy(1)) jb=2 jt=3-jb if(yy(jt).le.yb.or.yy(jb).ge.yt) go to 100 c if(yy(jb).lt.yb) then f=(yy(jt)-yb)/(yy(jt)-yy(jb)) yy(jb)=yb xx(jb)=xx(jb)*f+xx(jt)*(1.0d0-f) zz(jb)=zz(jb)*f+zz(jt)*(1.0d0-f) endif c if(yy(jt).gt.yt) then f=(yt-yy(jb))/(yy(jt)-yy(jb)) yy(jt)=yt xx(jt)=xx(jt)*f+xx(jb)*(1.0d0-f) zz(jt)=zz(jt)*f+zz(jb)*(1.0d0-f) endif c c rescale and then draw c do j=1,2 xx(j)=(xx(j)-xl)*rmag+shift yy(j)=(yy(j)-yb)*rmag+shift cc zz(j)=zz(j)*rmag enddo call pline(xx,yy,zz,2,icolor) 100 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxplt(ja,a,ip,rp,sp,vx,vy,w) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),jp(25),jpl(25),kdist(22) double precision + a(*),w(*),rp(100),t(25),tl(25),q(3,3),ql(3,3), 1 red(256),green(256),blue(256),vx(*),vy(*) character*80 + sp(100) c c user specified ip variables c nvf=ip(2) mpisw=ip(48) nproc=ip(49) irgn=ip(50) if(mpisw.eq.1.and.irgn.ne.1) return imtxsw=iabs(ip(55)) if(imtxsw.le.0.or.imtxsw.gt.7) imtxsw=1 if(ip(55).lt.0) then ip(55)=-imtxsw else ip(55)=imtxsw endif c c error flags c ip(25)=0 if(ip(73).le.0.or.ip(74).le.0) then iflag=25 go to 10 endif c c array pointers...in the order that they c occur in the w array c iuu=ip(83) iux=ip(84) iuy=ip(85) iu0=ip(86) iudot=ip(87) iu0dot=ip(88) iudl=ip(89) ievr=ip(90) ievl=ip(91) jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) c lenw=ip(20) ibegin=iz iend=lenw c ispd=ip(8) level=ip(67) lvl=ip(75) if(level.le.0.or.level.gt.lvl) level=lvl call getptr(level,lvl,nf,nptr,japtr,iaptr,juptr, + iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,w(ka)) c lenja=ja(japtr+nf)-1 lenju=ja(juptr+nf)-1 if(ispd.eq.1) then lena=lenja lenu=lenju else lena=2*lenja-(nf+1) lenu=2*lenju-(nf+1) endif c if(imtxsw.eq.7) then call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ilvl,nvf,'head',ibegin,iend,iflag) call memptr(mark,nvf,'tail',ibegin,iend,iflag) call memptr(ipc,nvf,'tail',ibegin,iend,iflag) call memptr(izc,nvf,'tail',ibegin,iend,iflag) if(iflag.ne.0) then iflag=20 go to 10 endif else if(imtxsw.ge.5) then call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(list,nf,'tail',ibegin,iend,iflag) call memptr(mark,nf,'tail',ibegin,iend,iflag) call memptr(indx,nf,'tail',ibegin,iend,iflag) call memptr(itl,nf,'tail',ibegin,iend,iflag) call memptr(itu,nf,'tail',ibegin,iend,iflag) len=iend-ibegin+1 if(ispd.eq.1) then maxje=len/2 else maxje=len/3 endif maxe=len-maxje call memptr(je,maxje,'head',ibegin,iend,iflag) call memptr(ie,maxe,'head',ibegin,iend,iflag) call sferr(nf,ispd,w(je),w(ie),ja(japtr),a(iaptr), + ja(juptr),a(iuptr),w(list),w(mark),w(indx), 1 w(itl),w(itu),maxje,maxe,iflag) if(iflag.ne.0) then iflag=20 go to 10 endif call memptr(isv,0,'free',ibegin,iend,iflag) lenje=maxje lene=maxe ia=je+lenje do i=1,lene w(ia+i-1)=w(ie+i-1) enddo ibegin=ia+lene call memptr(icolor,lene,'head',ibegin,iend,iflag) if(iflag.ne.0) then iflag=20 go to 10 endif else je=iz if(imtxsw.le.2) then call memptr(ia,lenu,'head',ibegin,iend,iflag) call memptr(icolor,lenu,'head',ibegin,iend,iflag) else call memptr(ia,lena,'head',ibegin,iend,iflag) call memptr(icolor,lena,'head',ibegin,iend,iflag) endif if(iflag.ne.0) then iflag=20 go to 10 endif if(imtxsw.le.2) then do i=1,lenu w(ia+i-1)=a(iuptr+i-1) enddo else do i=1,lena w(ia+i-1)=a(iaptr+i-1) enddo endif endif c if(imtxsw.ge.7) then call ginit(ip,rp,vx,vy,w(ka),ja,w(ilvl), + w(ipc),w(izc),t,tl,q,jp) jtype=-1 else call minit(ip,rp,nf,ja(japtr),ja(juptr),w(je), + w(ia),w(icolor),jp,jpl,t,tl,q,ql,kdist) jtype=imtxsw-(imtxsw/2)*2 endif c call clrmap(red,green,blue,jp) c call pltutl(jp(18),red,green,blue) c c main plot c call pframe(4) call title0(sp(4),0) call pframe(-4) c call pframe(5) if(imtxsw.eq.7) then call dgraph(vx,vy,ja(japtr),w(ilvl),w(ipc), + w(izc),t,jp) else if(imtxsw.ge.5) then call mplot1(jp,t,q,w(je),w(ia),w(icolor)) else if(imtxsw.ge.3) then call mplot1(jp,t,q,ja(japtr),w(ia),w(icolor)) else call mplot1(jp,t,q,ja(juptr),w(ia),w(icolor)) endif call pframe(-5) c c legend plot c call pframe(2) if(jtype.eq.-1) then call legnd1(jp) else if(jtype.eq.1) then call legnd5(jp,t) else call legnd4(jp,tl,kdist) endif call pframe(-2) c c small plot c call pframe(3) if(imtxsw.eq.7) then call dgraph(vx,vy,ja(japtr),w(ilvl),w(ipc), + w(izc),tl,jp) else if(imtxsw.ge.5) then call mplot1(jpl,tl,ql,w(je),w(ia),w(icolor)) else if(imtxsw.ge.3) then call mplot1(jpl,tl,ql,ja(japtr),w(ia),w(icolor)) else call mplot1(jpl,tl,ql,ja(juptr),w(ia),w(icolor)) endif call legnd0(t) call pframe(-3) c call pltutl(-1,red,green,blue) iflag=0 10 if(iflag.eq.0) then sp(11)='mtxplt: ok' else if(iflag.eq.25) then sp(11)='mtxplt: wrong data structure' else if(iflag.ge.18.and.iflag.le.24) then sp(11)='mtxplt: insufficient storage' else sp(11)='mtxplt: error forming matrix' endif ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sferr(n,ispd,je,e,ja,a,ju,u,list,mark,indx, + tl,tu,maxje,maxe,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),list(*),mark(*),indx(*),amtx,umtx, 1 emtx,je(*) double precision + a(*),u(*),tu(*),tl(*),e(*) c c compute sparsity structure for error matrix c if(ispd.ne.1) then lenje=min0(maxje,(maxe+n+1)/2) amtx=ja(n+1)-ja(1) umtx=ju(n+1)-ju(1) emtx=lenje-(n+1) else lenje=min0(maxje,maxe) amtx=0 umtx=0 emtx=0 endif c c c je(1)=n+2 unorm=u(n+1) do i=1,n mark(i)=0 list(i)=0 indx(i)=0 enddo c do i=1,n c c initialize row i and col i in tu and tl c mark(i)=i len=0 tu(i)=a(i) tl(i)=a(i) do jj=ja(i),ja(i+1)-1 j=ja(jj) tu(j)=a(jj) tl(j)=a(jj+amtx) mark(j)=mark(i) mark(i)=j len=len+1 enddo c c do outer product updates c lk=list(i) 10 if(lk.gt.0) then k=lk lk=list(k) j1=indx(k) j2=ju(k+1)-1 if(dabs(u(k)).le.unorm) then uinv=(u(k)/unorm)/unorm else uinv=1.0d0/u(k) endif su=u(j1)*uinv sl=u(j1+umtx)*uinv c do jj=j1,j2 j=ju(jj) if(mark(j).ne.0) then tu(j)=tu(j)-sl*u(jj) tl(j)=tl(j)-su*u(jj+umtx) else tu(j)=-sl*u(jj) tl(j)=-su*u(jj+umtx) mark(j)=mark(i) mark(i)=j len=len+1 endif enddo if(j1.lt.j2) then j=ju(j1+1) list(k)=list(j) list(j)=k indx(k)=j1+1 endif go to 10 endif c tu(i)=tu(i)-u(i) tl(i)=tu(i)-u(i) do jj=ju(i),ju(i+1)-1 j=ju(jj) tu(j)=0.0d0 tl(j)=0.0d0 c tu(j)=tu(j)-u(jj) c tl(j)=tl(j)-u(jj+umtx) enddo c c make je for this row c next=je(i) do j=1,len k=mark(i) tt=dmax1(dabs(tl(k)),dabs(tu(k))) if(tt.gt.0.0d0) then if(next.lt.lenje) then je(next)=k next=next+1 else iflag=i return endif endif mark(i)=mark(k) mark(k)=0 enddo mark(i)=0 je(i+1)=next len=next-je(i) if(len.gt.1) call ihp(je(je(i)),len) c c move tl, tu to e c e(i)=-tu(i) do jj=je(i),je(i+1)-1 j=je(jj) e(jj)=-tu(j) e(jj+emtx)=-tl(j) enddo c if(ju(i).lt.ju(i+1)) then j=ju(ju(i)) list(i)=list(j) list(j)=i indx(i)=ju(i) endif enddo iflag=0 c c shift u for non symmetric case c maxje=je(n+1)-1 if(ispd.ne.1) then nnz=maxje-(n+1) do i=1,nnz e(maxje+i)=e(lenje+i) enddo maxe=maxje+nnz else maxe=maxje endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mplot1(jp,t,q,ju,u,color) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jp(25),ju(*),color(*),ccolor double precision + t(25),u(*),q(3,3) c ispd=jp(7) n=jp(2) isw=1 c lshift=0 if(ispd.ne.1) lshift=ju(n+1)-ju(1) if(q(1,3)+q(2,3).ge.0.0d0) then c c border for lower triangle c call mtxbrd(t,q,0) c c lower triangle c if(q(1,3).lt.0.0d0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(2,3).lt.0.0d0) then i1=0 i2=1 ks=1 else i1=1 i2=0 ks=-1 endif do i=n1,n2,ns do k=ju(i+i1)-i1,ju(i+i2)-i2,ks icolor=ccolor(color(k+lshift),0,jp) call centry(i,ju(k),u(k+lshift),t,q,jp,icolor,isw) enddo enddo c c diagonal c do i=n1,n2,ns icolor=ccolor(color(i),0,jp) call centry(i,i,u(i),t,q,jp,icolor,isw) enddo c c upper triangle c if(q(2,3).gt.0.0d0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(1,3).gt.0.0d0) then i1=0 i2=1 ks=1 else i1=1 i2=0 ks=-1 endif do i=n1,n2,ns do k=ju(i+i1)-i1,ju(i+i2)-i2,ks icolor=ccolor(color(k),0,jp) call centry(ju(k),i,u(k),t,q,jp,icolor,isw) enddo enddo c c border for upper triangle c call mtxbrd(t,q,1) else c c border for upper triangle c call mtxbrd(t,q,1) c c upper triangle c if(q(2,3).gt.0.0d0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(1,3).gt.0.0d0) then i1=0 i2=1 ks=1 else i1=1 i2=0 ks=-1 endif do i=n1,n2,ns do k=ju(i+i1)-i1,ju(i+i2)-i2,ks icolor=ccolor(color(k),0,jp) call centry(ju(k),i,u(k),t,q,jp,icolor,isw) enddo enddo c c diagonal c do i=n1,n2,ns icolor=ccolor(color(i),0,jp) call centry(i,i,u(i),t,q,jp,icolor,isw) enddo c c lower triangle c if(q(1,3).lt.0.0d0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(2,3).lt.0.0d0) then i1=0 i2=1 ks=1 else i1=1 i2=0 ks=-1 endif do i=n1,n2,ns do k=ju(i+i1)-i1,ju(i+i2)-i2,ks icolor=ccolor(color(k+lshift),0,jp) call centry(i,ju(k),u(k+lshift),t,q,jp,icolor,isw) enddo enddo c c border for lower triangle c call mtxbrd(t,q,0) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine centry(ix,iy,val,t,q,jp,icolor,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + face(4,6),jp(25),order(6),index(3,3) double precision + t(25),q(3,3),px(8),py(8),pz(8),xn(5),yn(5),zn(5) character*1 + ichr(20) save px,py,pz,face,order,h,hl,hr,n,istrt,dz,index data px/0.0d0,1.0d0,1.0d0,0.0d0,0.0d0,1.0d0,1.0d0,0.0d0/ data py/0.0d0,0.0d0,1.0d0,1.0d0,0.0d0,0.0d0,1.0d0,1.0d0/ data pz/0.0d0,0.0d0,0.0d0,0.0d0,1.0d0,1.0d0,1.0d0,1.0d0/ data face/4,1,5,8,2,3,7,6,1,2,6,5,3,4,8,7,4,3,2,1,5,6,7,8/ data index/1,2,3,2,3,1,3,1,2/ c if(isw.eq.1) then isw=0 n=jp(2) h=1.0d0/dfloat(n) hl=h/10.0d0 hr=h-hl c c compute order c kmin=1 if(dabs(q(kmin,3)).gt.dabs(q(2,3))) kmin=2 if(dabs(q(kmin,3)).gt.dabs(q(3,3))) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(dabs(q(kmid,3)).gt.dabs(q(kmax,3))) kmid=kmax kmax=6-kmin-kmid c if(q(kmax,3).gt.0.0d0) then order(1)=2*kmax-1 order(6)=2*kmax else order(6)=2*kmax-1 order(1)=2*kmax endif if(q(kmid,3).gt.0.0d0) then order(2)=2*kmid-1 order(5)=2*kmid else order(5)=2*kmid-1 order(2)=2*kmid endif if(q(kmin,3).gt.0.0d0) then order(3)=2*kmin-1 order(4)=2*kmin else order(4)=2*kmin-1 order(3)=2*kmin endif c tol=1.d-3 istrt=6 if(dabs(q(kmin,3)).gt.tol) then istrt=4 else if(dabs(q(kmid,3)).gt.tol) then istrt=5 endif cc istrt=1 zmin=t(24) zmax=t(25) if(zmax.gt.zmin) then dz=1.0d0/(zmax-zmin) else dz=0.0d0 endif endif c lines=jp(20) numbrs=jp(21) i3d=jp(22) xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) zl=t(23) zmin=t(24) zmax=t(25) c x=dfloat(ix-1)*h y=dfloat(n-iy)*h if(i3d.ne.0) then zz=(val-zmin)*dz if(zz.gt.zl) then z=zz else z=zl zl=zz endif else z=zl endif do i=istrt,6 ii=order(i) do j=1,4 xx=x+h*px(face(j,ii)) yy=y+h*py(face(j,ii)) zz=zl+(z-zl)*pz(face(j,ii)) xn(j)=(xx*q(1,1)+yy*q(2,1))*scale+xshift yn(j)=(xx*q(1,2)+yy*q(2,2)+zz*q(3,2))*scale+yshift zn(j)=(xx*q(1,3)+yy*q(2,3)+zz*q(3,3))*scale+zshift enddo xn(5)=xn(1) yn(5)=yn(1) zn(5)=zn(1) call pwindw(xn,yn,zn,4,t,icolor) if(lines.eq.-2) call lwindw(xn,yn,zn,5,t,2) enddo c c c if(numbrs.ge.0) return if(numbrs.eq.-1) then call sreal(ichr,nn,val,3,1) else if(numbrs.eq.-2) then ichr(1)='(' call sint(ichr(2),iylen,iy) ichr(iylen+2)=',' call sint(ichr(iylen+3),ixlen,ix) nn=3+ixlen+iylen ichr(nn)=')' endif xl=x+hl xr=x+hr yb=y+hl yt=y+hr call htext(xl,yb,xr,yt,nn,ichr,0,q,t,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxbrd(t,q,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + t(25),q(3,3),x(3),y(3),z(3) c xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) zl=t(23) c c border for lower triangle c x(1)=q(2,1)*scale+xshift y(1)=(q(2,2)+zl*q(3,2))*scale+yshift z(1)=(q(2,3)+zl*q(3,3))*scale+zshift if(isw.eq.0) then x(2)=xshift y(2)=zl*q(3,2)*scale+yshift z(2)=zl*q(3,3)*scale+zshift else c c border for upper triangle c x(2)=(q(1,1)+q(2,1))*scale+xshift y(2)=(q(1,2)+q(2,2)+zl*q(3,2))*scale+yshift z(2)=(q(1,3)+q(2,3)+zl*q(3,3))*scale+zshift endif x(3)=q(1,1)*scale+xshift y(3)=(q(1,2)+zl*q(3,2))*scale+yshift z(3)=(q(1,3)+zl*q(3,3))*scale+zshift c call lwindw(x,y,z,3,t,2) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mtxclr(ja,ju,je,jp,t,u,color) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),color(*),jp(25),je(*) double precision + u(*),t(25) c c compute types c ispd=jp(7) n=jp(2) imtxsw=iabs(jp(3)) ncolor=jp(5) iscale=jp(19) if(imtxsw.ge.5) then len=je(n+1)-1 icolor=6 else if(imtxsw.ge.3) then len=ja(n+1)-1 icolor=4 else len=ju(n+1)-1 icolor=2 endif if(ispd.eq.1) then lenu=len lshift=0 else lenu=2*len-(n+1) lshift=len-(n+1) endif c ity=imtxsw-(imtxsw/2)*2 if(ity.eq.0) go to 10 c c color by type c c type = 2 fillin (blue) c type = 4 original (green) c type = 5 diagonal (yellow) c type = 6 neglected (red) c do i=1,lenu color(i)=icolor enddo c if(imtxsw.ge.5) then do i=1,n color(i)=5 do j=ju(i),ju(i+1)-1 call jamap(i,ju(j),ij,ji,je,lshift) color(ij)=2 color(ji)=2 enddo do j=ja(i),ja(i+1)-1 call jamap(i,ja(j),ij,ji,je,lshift) color(ij)=4 color(ji)=4 enddo enddo else if(imtxsw.ge.3) then do i=1,n color(i)=5 enddo else do i=1,n color(i)=5 do j=ja(i),ja(i+1)-1 call jamap(i,ja(j),ij,ji,ju,lshift) color(ij)=4 color(ji)=4 enddo c enddo endif return c c 10 umin=t(19) umax=t(20) zmin=fscale(umin,iscale,0) zmax=fscale(umax,iscale,0) eps=t(7) if(zmax.gt.zmin) then zscale=(1.0d0-eps)*dfloat(ncolor)/(zmax-zmin) else zscale=0.0d0 endif c do i=1,lenu zz=(fscale(u(i),iscale,0)-zmin)*zscale color(i)=max0(0,idint(zz))+1 color(i)=min0(color(i),ncolor) enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine minit(ip,rp,n,ja,ju,je,u,color,jp,jpl,t,tl,q,ql, + kdist) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),jp(25),ja(*),ju(*),color(*),jpl(25),je(*), 1 kdist(*) double precision + u(*),t(25),tl(25),rp(100),q(3,3),ql(3,3) c c initialize for mtxplt c do i=1,25 jp(i)=0 enddo call linit(t,q) call linit(tl,ql) call zoombx(rp,t) rmag=t(12) c c check control parameters in ip and rp c ispd=ip(8) iscale=ip(58) if(iscale.lt.0.or.iscale.gt.2) iscale=0 lines=ip(59) if(lines.ne.-2) lines=0 numbrs=ip(60) if(numbrs.gt.0.or.numbrs.lt.-2) numbrs=0 mxcolr=max0(2,ip(51)) mxcolr=min0(256,mxcolr) imtxsw=iabs(ip(55)) jtype=imtxsw-(imtxsw/2)*2 if(jtype.eq.1) then ncolor=6 else ncon=ip(56) ncolor=max0(1,ncon) endif lenja=ja(n+1)-1 lenju=ju(n+1)-1 lenje=je(n+1)-1 if(imtxsw.ge.5) then len=lenje else if(imtxsw.ge.3) then len=lenja else len=lenju endif if(ispd.ne.1) len=2*len-(n+1) u(n+1)=u(1) if(ip(55).ge.0) then do i=1,len u(i)=dabs(u(i)) enddo endif umin=u(1) umax=u(1) do i=1,len umin=dmin1(umin,u(i)) umax=dmax1(umax,u(i)) enddo if(iscale.eq.1.and.umin.le.0.0d0) iscale=2 c c set up rotated coordinate system c nx=ip(64) ny=ip(65) nz=ip(66) i3d=1 if(numbrs.ne.0) i3d=0 cc if(nx.eq.0.and.ny.eq.0) i3d=0 c call mkrot(nx,ny,nz,q) c xmin=dmin1(0.0d0,q(1,1))+dmin1(0.0d0,q(2,1)) xmax=dmax1(0.0d0,q(1,1))+dmax1(0.0d0,q(2,1)) ymin=dmin1(0.0d0,q(1,2))+dmin1(0.0d0,q(2,2)) ymax=dmax1(0.0d0,q(1,2))+dmax1(0.0d0,q(2,2)) zmin=dmin1(0.0d0,q(1,3))+dmin1(0.0d0,q(2,3)) zmax=dmax1(0.0d0,q(1,3))+dmax1(0.0d0,q(2,3)) if(i3d.eq.1) then ymax=ymax+q(3,2) zmin=zmin+dmin1(0.0d0,q(3,3)) zmax=zmax+dmax1(0.0d0,q(3,3)) endif size=t(14) xs=t(15) ys=t(16) zs=t(17) scale=size/dmax1(xmax-xmin,ymax-ymin) xshift=xs-scale*(xmax+xmin)/2.0d0 yshift=ys-scale*(ymax+ymin)/2.0d0 zshift=zs-scale*(zmax+zmin)/2.0d0 c c set up jp c jp(1)=len jp(2)=n jp(3)=imtxsw jp(4)=1 jp(5)=ncolor if(jtype.eq.1) then jp(6)=0 else jp(6)=1 endif jp(7)=ispd c jp(13)=ip(64) jp(14)=ip(65) jp(15)=ip(66) jp(16)=0 c jp(17)=mxcolr jp(18)=min0(ncolor+2,mxcolr) jp(19)=iscale jp(20)=lines jp(21)=numbrs jp(22)=i3d c t(1)=xshift t(2)=yshift t(3)=scale t(5)=zshift c if(rp(8).lt.rp(9)) then t(19)=rp(8) t(20)=rp(9) else t(19)=umin t(20)=umax endif if(i3d.eq.1.and.umin.lt.dmin1(0.0d0,umax)) then t(23)=-umin/(umax-umin) else t(23)=0.0d0 endif t(24)=umin t(25)=umax c c parameters for legend plot c do i=1,25 tl(i)=t(i) jpl(i)=jp(i) enddo tl(12)=1.0d0 c jpl(20)=0 jpl(21)=0 if(rmag.le.1.0d0) jpl(22)=0 c c set q0, scale,xshift, yshift correctly for picture c if(rmag.ne.1.0d0) then do i=1,3 do j=1,3 ql(i,j)=q(i,j) enddo enddo else tl(1)=xs-size/2.0d0 tl(2)=ys-size/2.0d0 tl(5)=zs tl(3)=size jpl(13)=0 jpl(14)=0 jpl(15)=1 endif c c set colors c call mtxclr(ja,ju,je,jp,t,u,color) if(jtype.eq.0) call cdist(jp,t,u,kdist) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ginit(ip,rp,vx,vy,ka,ja,ilvl,pc,qc,t,tl,q,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer 1 ip(100),jp(25),ka(10,*),ja(*),ilvl(*),pc(*),qc(*) double precision + vx(*),vy(*),rp(100),t(25),tl(25),q(3,3) c c make temporary copies of main data structures for graphics c nvf=ip(2) mpisw=ip(48) nproc=ip(49) irgn=ip(50) level=ip(67) lvl=ip(75) if(level.le.0.or.level.gt.lvl) level=lvl call getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) c call linit(t,q) call zoombx(rp,t) c do i=1,25 jp(i)=0 enddo jp(1)=nf jp(2)=nvf jp(4)=1 jp(5)=lvl jp(23)=nproc jp(12)=mpisw c imtxsw=ip(55) jp(9)=imtxsw c numbrs=ip(60) if(numbrs.gt.0.or.numbrs.lt.-2) numbrs=0 jp(21)=numbrs lines=ip(59) if(lines.ne.-2) lines=0 jp(20)=lines c mxcolr=max0(2,ip(51)) mxcolr=min0(256,mxcolr) jp(17)=mxcolr c c compute scaled coordinates c xmin=vx(1) xmax=vx(1) ymin=vy(1) ymax=vy(1) do i=1,nvf xmin=dmin1(xmin,vx(i)) xmax=dmax1(xmax,vx(i)) ymin=dmin1(ymin,vy(i)) ymax=dmax1(ymax,vy(i)) enddo c c size=t(14) xs=t(15) ys=t(16) scale=size/dmax1(xmax-xmin,ymax-ymin) t(1)=xs-scale*(xmin+xmax)/2.0d0 t(2)=ys-scale*(ymin+ymax)/2.0d0 t(3)=scale c c jp(18)=min0(mxcolr,jp(5)+2) c c do i=1,nvf ilvl(i)=1 enddo if(lvl.gt.1) then do ilev=2,lvl call getptr(ilev-1,lvl,nc,ncptr,jacptr,iacptr, + jucptr,iucptr,jvcptr,ivcptr,iqcptr,ibcptr, 1 ncc,nccptr,ka) call getptr(ilev,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) c call cl0(nf,nc,ja(iqcptr),ilvl,qc) enddo call cl0(nf,nf,ja(iqptr),ilvl,qc) do i=1,nvf ilvl(i)=lvl+1-ilvl(i) enddo endif c c compute pointers to level level nodes c call getptr(level,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) do i=1,nvf pc(i)=i enddo do ilev=level+1,lvl call getptr(ilev-1,lvl,nc,ncptr,jacptr,iacptr, + jucptr,iucptr,jvcptr,ivcptr,iqcptr,ibcptr, 1 ncc,nccptr,ka) call getptr(ilev,lvl,nf,nptr,japtr,iaptr, + juptr,iuptr,jvptr,ivptr,iqptr,ibptr,nc,ncptr,ka) c call cl1(nf,nc,ja(iqcptr),pc,qc) enddo call cl1(nf,nf,ja(iqptr),pc,qc) c c compute hmin c iqptr=ja(nvf+1)+nvf do i=1,nvf qc(i)=ja(iqptr+i-1) enddo hmin=((xmin-xmin)**2+(ymax-ymin)**2)/100.0d0 do i=1,nvf ii=qc(i) do j=ja(i),ja(i+1)-1 jj=qc(ja(j)) hh=(vx(ii)-vx(jj))**2+(vy(ii)-vy(jj))**2 hmin=dmin1(hh,hmin) enddo enddo t(19)=dsqrt(hmin) c do i=1,25 tl(i)=t(i) enddo tl(12)=1.0d0 c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine dgraph(vx,vy,ja,ilvl,pc,qc,t,jp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer 1 jp(25),ja(*),ilvl(*),pc(*),qc(*),ccolor double precision + vx(*),vy(*),t(25),x(10),y(10),z(10) n=jp(1) nvf=jp(2) lvl=jp(5) imtxsw=jp(9) c xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h=t(19)*0.25d0*scale c do i=1,nvf qc(i)=0 enddo do i=1,nvf if(pc(i).gt.0) qc(pc(i))=i enddo if(imtxsw.lt.0) go to 10 c c color graph c do ii=1,n i=qc(ii) do jj=ja(ii),ja(ii+1)-1 j=qc(ja(jj)) x(1)=vx(i)*scale+xshift y(1)=vy(i)*scale+yshift z(1)=zshift x(2)=vx(j)*scale+xshift y(2)=vy(j)*scale+yshift z(2)=zshift call lwindw(x,y,z,2,t,2) enddo enddo c c color vertices c 10 do ii=1,n i=qc(ii) xx=vx(i)*scale+xshift yy=vy(i)*scale+yshift ic=ccolor(ilvl(i),0,jp) x(1)=xx-h y(1)=yy-h x(2)=xx+h y(2)=yy-h x(3)=xx+h y(3)=yy+h x(4)=xx-h y(4)=yy+h x(5)=x(1) y(5)=y(1) call pwindw(x,y,z,4,t,ic) if(imtxsw.gt.0) call lwindw(x,y,z,5,t,2) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cl0(nf,nc,q,level,iz) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + q(*),level(*),iz(*) c c update levels c do i=1,nc iz(i)=level(i) enddo do i=1,nf level(i)=1 enddo if(nc.lt.nf) then do i=1,nc level(q(i))=iz(i)+1 enddo else do i=1,nc level(i)=iz(q(i)) enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cl1(nf,nc,q,pc,iz) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + q(*),pc(*),iz(*) c c update pc c do i=1,nc iz(i)=pc(i) enddo do i=1,nf pc(i)=0 enddo if(nc.lt.nf) then do i=1,nc pc(q(i))=iz(i) enddo else do i=1,nc pc(i)=iz(q(i)) enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltevl(x,y,u,ux,uy,vx,vy,xm,ym,itnode,ibndry, + ip,rp,w) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*) double precision + x(*),y(*),u(*),ux(*),uy(*),w(*),vx(*),vy(*),xm(*), 1 ym(*),rp(100) c c evaluate the function and gradient c the coordinates of the points are in x and y c the output values are in u,ux, and uy c ip(25)=0 if(itnode(3,1).eq.0.or.ip(5).ne.0) then ip(25)=25 return endif c c array pointers...in the order that they c occur in the w array c iuu=ip(83) iux=ip(84) iuy=ip(85) iu0=ip(86) iudot=ip(87) iu0dot=ip(88) iudl=ip(89) ievr=ip(90) ievl=ip(91) jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) lenw=ip(20) ntf=ip(1) nvf=ip(2) nbf=ip(4) c c additional pointers c it=iz ibedge=it+6 itedge=ibedge+2*nbf list=itedge+3*ntf iqueue=list+2*nvf mtree=iqueue+2*nvf ltree=(lenw-mtree+1)/5 if(ltree.lt.nvf.or.lenw-mtree+1.lt.3*ntf) then ip(25)=20 return endif c call ueval(ip,x,y,u,ux,uy,vx,vy,w(iuu),w(iux),w(iuy),xm,ym, + w(list),w(mtree),ltree,w(iqueue),w(it),itnode,w(itedge), 1 ibndry,w(ibedge)) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ueval(ip,x,y,u,ux,uy,vx,vy,g,gx,gy,xm,ym,list,qtree, + ltree,queue,p,itnode,itedge,ibndry,ibedge) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),list(*),queue(*),itnode(5,*), 1 ibndry(6,*),itedge(3,*),ip(100),ibedge(2,*) double precision + x(*),y(*),u(*),ux(*),uy(*),vx(*),vy(*),xm(*),ym(*), 1 g(*),c(3),p(6),gx(*),gy(*) data ibit/0/ c c evaluate the function and/or gradient at nevp points c if(ip(16).eq.0) return ntf=ip(1) nvf=ip(2) nbf=ip(4) nevp=iabs(ip(16)) c if(ip(16).gt.0) then call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vx,vy,qtree,jflag) umin=g(1) do i=1,nvf umin=dmin1(umin,g(i)) enddo p(5)=umin p(6)=ceps(ibit)*32.0d0 c c make binary tree c qtree(1,1)=ltree call mktree(qtree,list,ntri,p,ntf,vx,vy,xm,ym,itnode, + itedge,ibndry,iflag) if(iflag.ne.0) then ip(25)=20 return endif endif c c initailization for evaluation loop c umin=p(5) eps=p(6) do 50 i=1,nevp u(i)=umin ux(i)=umin uy(i)=umin c c get list of seed elements for fndtri c call getlst(x(i),y(i),queue,llen,qtree,p) if(llen.le.0) go to 50 c c find triangle containing (x(i),y(i)) c call fndtri(x(i),y(i),it,c,vx,vy,xm,ym,queue, + llen,qtree,list,itnode,itedge,ibndry,eps) if (it.eq.0) go to 50 u(i)=c(1)*g(itnode(1,it))+ + c(2)*g(itnode(2,it))+c(3)*g(itnode(3,it)) ux(i)=c(1)*gx(itnode(1,it))+ + c(2)*gx(itnode(2,it))+c(3)*gx(itnode(3,it)) uy(i)=c(1)*gy(itnode(1,it))+ + c(2)*gy(itnode(2,it))+c(3)*gy(itnode(3,it)) c* call grad(ux(i),uy(i),vx,vy,g,itnode(1,it),0) 50 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fndtri(x,y,i,c,vx,vy,xm,ym,queue, + llen,qtree,list,itnode,itedge,ibndry,eps) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),list(*),queue(*),qtree(5,*), 1 itedge(3,*) double precision + vx(*),vy(*),c(3),xm(*),ym(*),cc(3) c c find the triangle containing (x,y) c i=0 if(llen.le.0) return ib=0 icount=0 do 50 kk=llen,1,-1 call bindex(queue(kk),i1,klen,qtree) if(klen.le.0) go to 50 i2=i1+klen-1 do 40 kl=i2,i1,-1 c c get a seed element c icount=icount+1 i=list(kl) c c check if (x,y) is in straight edge triangle i c 10 call bari(x,y,vx,vy,itnode(1,i),c) do j=1,3 if(c(j)+eps.lt.0.0d0) go to 30 enddo c c check for curved edges c if(min0(itedge(1,i),itedge(2,i), + itedge(3,i)).ge.0) return do 25 j=1,3 if(itedge(j,i).ge.0) go to 25 k=-itedge(j,i) if(ibndry(3,k).le.0) go to 25 x1=vx(ibndry(1,k)) y1=vy(ibndry(1,k)) x2=vx(ibndry(2,k))-x1 y2=vy(ibndry(2,k))-y1 xc=xm(ibndry(3,k)) yc=ym(ibndry(3,k)) if(x2*(yc-y1)-y2*(xc-x1).ge.0.0d0) go to 25 rad=((xc-x1)**2+(yc-y1)**2)*(1.0d0-eps) z=((xc-x)**2+(yc-y)**2)*(1.0d0+eps) if(z.lt.rad) then i=0 return endif 25 continue return c c (x,y) is not in triangle i c 30 if(icount.eq.1) then if(itedge(j,i).gt.0) then i=itedge(j,i)/4 go to 10 endif endif c c check for curved edges c if(min0(itedge(1,i),itedge(2,i), + itedge(3,i)).ge.0) go to 40 do 35 j=1,3 if(c(j).ge.0.0d0) go to 35 if(itedge(j,i).ge.0) go to 35 k=-itedge(j,i) if(ibndry(3,k).le.0) then if(c(j).le.-0.01d0) go to 35 ib=i do m=1,3 cc(m)=c(m) enddo go to 35 endif x1=vx(ibndry(1,k)) y1=vy(ibndry(1,k)) x2=vx(ibndry(2,k))-x1 y2=vy(ibndry(2,k))-y1 xc=xm(ibndry(3,k)) yc=ym(ibndry(3,k)) if(x2*(yc-y1)-y2*(xc-x1).le.0.0d0) go to 35 rad=((xc-x1)**2+(yc-y1)**2)*(1.0d0+eps) z=((xc-x)**2+(yc-y)**2)*(1.0d0-eps) if(z.le.rad) return 35 continue c 40 continue 50 continue if(ib.eq.0) return i=ib do j=1,3 c(j)=cc(j) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mktree(qtree,list,llen,p,ntf,vx,vy,xm,ym,itnode, + itedge,ibndry,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),list(*),itnode(5,*),itedge(3,*),ibndry(6,*) double precision 1 p(6),vx(*),vy(*),xm(*),ym(*) c c set up binary tree data structure c iflag=0 p(1)=vx(1) p(2)=p(1) p(3)=vy(1) p(4)=p(3) llen=0 do i=1,ntf llen=llen+1 list(llen)=i call vari(i,xmin,xmax,ymin,ymax,vx,vy, + xm,ym,itnode,itedge,ibndry) p(1)=dmin1(p(1),xmin) p(2)=dmax1(p(2),xmax) p(3)=dmin1(p(3),ymin) p(4)=dmax1(p(4),ymax) enddo dd=(p(2)-p(1))*p(6) p(1)=p(1)-dd p(2)=p(2)+dd dd=(p(4)-p(3))*p(6) p(3)=p(3)-dd p(4)=p(4)+dd c c now make a binary tree c qtree(2,1)=4 c qtree(1,3)=1 qtree(2,3)=llen qtree(3,3)=0 qtree(4,3)=0 qtree(5,3)=0 c c create refined elements c i=3 20 call refnbx(i,p,qtree,list,vx,vy,xm,ym,itnode, + itedge,ibndry,iflag) if(iflag.ne.0) return i=i+1 if(i.lt.qtree(2,1)) go to 20 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine refnbx(i,p,qtree,list,vx,vy,xm,ym,itnode, + itedge,ibndry,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),list(*),itnode(5,*),ibndry(6,*), 1 lenx(3),leny(3),iptr(3),jptr(3),ib(4), 2 itedge(3,*) double precision + vx(*),vy(*),xm(*),ym(*),p(6),xp(5),yp(5) c c test box i for refinement and refine if necessary c maxlev=2**30 (30 levels are max) c maxlev=1073741824 iflag=0 call bindex(i,i1,ilen,qtree) if(ilen.le.2) return i2=i1+ilen-1 do j=1,3 lenx(j)=0 leny(j)=0 enddo c epsx=p(6)*(p(2)-p(1)) epsy=p(6)*(p(4)-p(3)) call bcoord(i,ib,qtree) if(ib(3).ge.maxlev) return if(ib(4).ge.maxlev) return dx=(p(2)-p(1))/dfloat(2*ib(3)) dy=(p(4)-p(3))/dfloat(2*ib(4)) do j=1,5 xp(j)=p(1)+dfloat(2*ib(1)-4+j)*dx yp(j)=p(3)+dfloat(2*ib(2)-4+j)*dy enddo c c count number of elements in each refined box c do jj=i1,i2 j=list(jj) call vari(j,xmin,xmax,ymin,ymax,vx,vy, + xm,ym,itnode,itedge,ibndry) c xx=(xmax+xmin)/2.0d0 k=2 if(xx.gt.xp(3)) k=3 if(xmax.ge.xp(k+2)-epsx.or.xmin.le.xp(k-1)+epsx) k=1 lenx(k)=lenx(k)+1 c yy=(ymax+ymin)/2.0d0 k=2 if(yy.gt.yp(3)) k=3 if(ymax.ge.yp(k+2)-epsy.or.ymin.le.yp(k-1)+epsy) k=1 leny(k)=leny(k)+1 enddo c if(ilen.lt.2*min0(lenx(1),leny(1))) return if(qtree(2,1)+2.gt.qtree(1,1)) then iflag=1 return endif ison=qtree(2,1) qtree(2,1)=ison+2 qtree(5,i)=ison if(leny(1).gt.lenx(1)) then c c x-refinement c ity=0 qtree(1,ison)=i1+lenx(1) qtree(1,ison+1)=qtree(1,ison)+lenx(2) qtree(2,ison)=qtree(1,ison+1)+lenx(3) qtree(2,ison+1)=ity qtree(3,ison)=2*ib(1)-1 qtree(3,ison+1)=ib(2) qtree(4,ison)=2*ib(3) qtree(4,ison+1)=ib(4) qtree(5,ison)=0 qtree(5,ison+1)=0 else c c y-refinement c ity=1 qtree(1,ison)=i1+leny(1) qtree(1,ison+1)=qtree(1,ison)+leny(2) qtree(2,ison)=qtree(1,ison+1)+leny(3) qtree(2,ison+1)=ity qtree(3,ison)=ib(1) qtree(3,ison+1)=2*ib(2)-1 qtree(4,ison)=ib(3) qtree(4,ison+1)=2*ib(4) qtree(5,ison)=0 qtree(5,ison+1)=0 endif c c reorder list c iptr(1)=i1 iptr(2)=qtree(1,ison) iptr(3)=qtree(1,ison+1) jptr(1)=iptr(2)-1 jptr(2)=iptr(3)-1 jptr(3)=qtree(2,ison)-1 c do 80 kz=1,2 kk=kz if(kz.eq.2.and. + (jptr(2)-iptr(2)).gt.(jptr(3)-iptr(3))) kk=3 j1=iptr(kk) j2=jptr(kk) if(j1.gt.j2) go to 80 do jj=j1,j2 60 j=list(jj) k=2 call vari(j,xmin,xmax,ymin,ymax,vx,vy, + xm,ym,itnode,itedge,ibndry) if(ity.eq.0) then xx=(xmax+xmin)/2.0d0 if(xx.gt.xp(3)) k=3 if(xmax.ge.xp(k+2)-epsx.or. + xmin.le.xp(k-1)+epsx) k=1 else yy=(ymax+ymin)/2.0d0 if(yy.gt.yp(3)) k=3 if(ymax.ge.yp(k+2)-epsy.or. + ymin.le.yp(k-1)+epsy) k=1 endif c if(kk.ne.k) then l=iptr(k) iptr(k)=l+1 list(jj)=list(l) list(l)=j go to 60 endif enddo iptr(kk)=jptr(kk)+1 80 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine getlst(x,y,queue,iptr,qtree,p) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),queue(*) double precision + p(6) c c make a list of elements c iptr=0 if(x.lt.p(1).or.x.gt.p(2)) return if(y.lt.p(3).or.y.gt.p(4)) return c xx=(x-p(1))/(p(2)-p(1)) yy=(y-p(3))/(p(4)-p(3)) iptr=1 queue(iptr)=3 jptr=1 c 50 if(iptr.lt.jptr) return i=queue(jptr) jptr=jptr+1 c c check for son c i=qtree(5,i) if(i.gt.0) then ity=qtree(2,i+1) if(ity.eq.0) then ix=idint(xx*dfloat(qtree(4,i))) ir=qtree(3,i) if(ir.ge.ix.and.ir.le.ix+2) then iptr=iptr+1 queue(iptr)=i endif if(ir+1.ge.ix.and.ir+1.le.ix+2) then iptr=iptr+1 queue(iptr)=i+1 endif else iy=idint(yy*dfloat(qtree(4,i+1))) ir=qtree(3,i+1) if(ir.ge.iy.and.ir.le.iy+2) then iptr=iptr+1 queue(iptr)=i endif if(ir+1.ge.iy.and.ir+1.le.iy+2) then iptr=iptr+1 queue(iptr)=i+1 endif endif endif go to 50 end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine vari(i,xmin,xmax,ymin,ymax,vx,vy,xm,ym, + itnode,itedge,ibndry) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*) double precision + vx(*),vy(*),xm(*),ym(*) c c compute the maximun and minimum c x and y values in triangle i c xmin=dmin1(vx(itnode(1,i)),vx(itnode(2,i)),vx(itnode(3,i))) ymin=dmin1(vy(itnode(1,i)),vy(itnode(2,i)),vy(itnode(3,i))) xmax=dmax1(vx(itnode(1,i)),vx(itnode(2,i)),vx(itnode(3,i))) ymax=dmax1(vy(itnode(1,i)),vy(itnode(2,i)),vy(itnode(3,i))) c c check for curved edges c if(min0(itedge(1,i),itedge(2,i),itedge(3,i)).ge.0) return do 10 j=1,3 if(itedge(j,i).ge.0) go to 10 k=-itedge(j,i) if(ibndry(3,k).le.0) go to 10 x1=vx(ibndry(1,k)) y1=vy(ibndry(1,k)) x2=vx(ibndry(2,k))-x1 y2=vy(ibndry(2,k))-y1 xc=xm(ibndry(3,k))-x1 yc=ym(ibndry(3,k))-y1 if(x2*yc-y2*xc.le.0.0d0) go to 10 rr=dsqrt(xc**2+yc**2) do ic=1,4 xx=xc yy=yc if(ic.eq.1) xx=xx+rr if(ic.eq.2) xx=xx-rr if(ic.eq.3) yy=yy+rr if(ic.eq.4) yy=yy-rr if(x2*yy-y2*xx.lt.0.0d0) then xmax=dmax1(xx,xmax) xmin=dmin1(xx,xmin) ymax=dmax1(yy,ymax) ymin=dmin1(yy,ymin) endif enddo 10 continue c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bindex(i,istart,llen,qtree) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qtree(5,*) c c compute coordinates for the list c istart=qtree(1,i) ison=qtree(5,i) if(ison.gt.0) then llen=qtree(1,ison)-istart return else if(i.eq.3) then llen=qtree(2,3) return else icent=(i/2)*2 if(i.eq.icent) then llen=qtree(1,i+1)-istart return else llen=qtree(2,icent)-istart return endif endif endif end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine bcoord(i,ib,qtree) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),ib(4) c c integer (x,y) coordinates with respect to c a uniform refinement c if(i.le.3) then do j=1,4 ib(j)=1 enddo return else icent=(i/2)*2 ib(1)=qtree(3,icent) ib(2)=qtree(3,icent+1) ib(3)=qtree(4,icent) ib(4)=qtree(4,icent+1) if(i.ne.icent) then ity=qtree(2,icent+1) if(ity.eq.0) then ib(1)=ib(1)+1 else ib(2)=ib(2)+1 endif endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ascutl(id,fname,mode,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + istack(10) character*1 + mode character*80 + sname,fname common /asc/maxid,irw(10),iunit(10) save sname,length,ifirst,next,istack data ifirst/1/ c c iflag= 0 ok c 1 error on open c 2 bad mode (not c,r, or w) c 3 exceed maxid id's c 4 invalid id c 5 file not open c 6 read error c 7 write error c -1 end of file c if(ifirst.eq.1) then maxid=10 do i=1,maxid iunit(i)=20+i irw(i)=0 istack(i)=i+1 enddo istack(maxid)=-1 next=1 ifirst=0 endif iflag=0 c c close c if(mode.eq.'c') then c c ckeck for valid id c if(id.le.0.or.id.gt.maxid) then iflag=4 return endif if(irw(id).eq.0) then iflag=5 return endif irw(id)=0 istack(id)=next next=id close(unit=iunit(id)) return endif c c get next available id c if(next.gt.0) then id=next next=istack(id) else c c too many files open c iflag=3 return endif c c process filename c call fstr(sname,length,fname,0) c c open for write c if(mode.eq.'w') then open(unit=iunit(id),form='formatted',status='unknown', + file=sname,access='sequential',err=10) irw(id)=1 else if(mode.eq.'r') then c c open for read c open(unit=iunit(id),form='formatted',status='old', + file=sname,access='sequential',err=10) irw(id)=-1 else iflag=2 go to 20 endif return c c if open failed, restore id to available stack c 10 iflag=1 20 irw(id)=0 istack(id)=next next=id return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ascstr(id,sval,length,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) character*1 + sval(*) common /asc/maxid,irw(10),iunit(10) c c write a character string c c the long formats are to accomodate xpm files c normally should be (80a1) c iflag =0 if(id.le.0.or.id.gt.maxid) then iflag=4 return endif if(irw(id).eq.0) then iflag=5 return endif if(irw(id).lt.0) then read(iunit(id),fmt='(2000a1)',end=10,err=20) + (sval(i),i=1,length) else write(iunit(id),fmt='(2000a1)',err=30) + (sval(i),i=1,length) endif return 10 iflag=-1 return 20 iflag=6 return 30 iflag=7 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ascint(id,ival,length,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ival(*) common /asc/maxid,irw(10),iunit(10) c c write an integer array c iflag =0 if(id.le.0.or.id.gt.maxid) then iflag=4 return endif if(irw(id).eq.0) then iflag=5 return endif if(irw(id).lt.0) then read(iunit(id),fmt='(6(2x,i11))',end=10,err=20) + (ival(i),i=1,length) else write(iunit(id),fmt='(6(2x,i11))',err=30) + (ival(i),i=1,length) endif return 10 iflag=-1 return 20 iflag=6 return 30 iflag=7 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine ascflt(id,rval,length,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + rval(*) common /asc/maxid,irw(10),iunit(10) c c write a real array c iflag =0 if(id.le.0.or.id.gt.maxid) then iflag=4 return endif if(irw(id).eq.0) then iflag=5 return endif if(irw(id).lt.0) then read(iunit(id),fmt='(3(2x,e23.15))',end=10,err=20) + (rval(i),i=1,length) else write(iunit(id),fmt='(3(2x,e23.15))',err=30) + (rval(i),i=1,length) endif return 10 iflag=-1 return 20 iflag=6 return 30 iflag=7 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine rdwrt(fname,isave,vx,vy,xm,ym,ibndry,itnode,ja,a, + ip,rp,sp,iu,ru,su,w) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),ip(100),iu(100),ja(*) double precision + vx(*),vy(*),xm(*),ym(*),rp(100),ru(100),w(*),a(*) character*8 + keychk,keywrd character*80 + fname,sp(100),su(100),sname common /atest6/nproc,myid,mpisw save jfirst,keywrd data jfirst/1/ data keywrd/'rwdouble'/ c c isave = 0, write a file c isave = 1, read a file c iflag=0 sp(11)='rdwrt: ok' call stfile(sname,fname) cc call fstr(sname,length,fname,0) c if(isave.eq.0) then keychk=keywrd jfirst=1 call xdrutl(id,sname,'w',jflag) else if(isave.eq.1) then call xdrutl(id,sname,'r',jflag) else iflag=18 sp(11)='rdwrt: bad value for isave' go to 40 endif c c call xdrstr(id,keychk,8,jflag) if(keychk.ne.keywrd) then iflag=16 sp(11)='rdwrt: wrong keyword' go to 30 endif c c integer arrays c call xdrint(id,ip,100,jflag) c ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) ifirst=ip(5) maxv=ip(22) nproc0=ip(49) ip(48)=mpisw ip(49)=nproc ip(50)=myid+1 c jtime=ip(92) jhist=ip(93) jpath=ip(94) ka=ip(95) jstat=ip(96) iee=ip(97) ipath=ip(98) iz=ip(99) c lipath=ip(72) lenja=ip(73) lena=ip(74) ngf=ip(77) c call xdrint(id,iu,100,jflag) call xdrint(id,itnode,5*ntf,jflag) call xdrint(id,ibndry,6*nbf,jflag) if(itnode(3,1).ne.0.and.ifirst.eq.0) then if(lipath.gt.0) call xdrint(id,w(ipath),4*lipath,jflag) if(lenja.gt.0) then call xdrint(id,w(ka),1000,jflag) call xdrint(id,ja,lenja,jflag) endif endif c c real arrays c if(keywrd(3:3).eq.'d') then call xdrdbl(id,rp,100,jflag) call xdrdbl(id,ru,100,jflag) call xdrdbl(id,vx,nvf,jflag) call xdrdbl(id,vy,nvf,jflag) if(ncf.gt.0) then call xdrdbl(id,xm,ncf,jflag) call xdrdbl(id,ym,ncf,jflag) endif if(itnode(3,1).ne.0.and.ifirst.eq.0) then do k=1,ngf call xdrdbl(id,w(1+(k-1)*maxv),nvf,jflag) enddo if(jfirst.eq.1) then call xdrdbl(id,w(jpath),606,jflag) call xdrdbl(id,w(jhist),660,jflag) call xdrdbl(id,w(jtime),150,jflag) jfirst=0 else call xdrdbl(id,w(iz),606,jflag) call fixpth(w(jpath),w(iz)) call xdrdbl(id,w(iz),660,jflag) call fixhst(w(jhist),w(iz)) call xdrdbl(id,w(iz),150,jflag) endif call xdrdbl(id,w(jstat),10*nproc0,jflag) call xdrdbl(id,w(iee),ntf,jflag) if(lena.gt.0) call xdrdbl(id,a,lena,jflag) endif else call xdrflt(id,rp,100,jflag) call xdrflt(id,ru,100,jflag) call xdrflt(id,vx,nvf,jflag) call xdrflt(id,vy,nvf,jflag) if(ncf.gt.0) then call xdrflt(id,xm,ncf,jflag) call xdrflt(id,ym,ncf,jflag) endif if(itnode(3,1).ne.0.and.ifirst.eq.0) then do k=1,ngf call xdrflt(id,w(1+(k-1)*maxv),nvf,jflag) enddo if(jfirst.eq.1) then call xdrflt(id,w(jpath),606,jflag) call xdrflt(id,w(jhist),660,jflag) call xdrflt(id,w(jtime),150,jflag) jfirst=0 else call xdrflt(id,w(iz),606,jflag) call fixpth(w(jpath),w(iz)) call xdrflt(id,w(iz),660,jflag) call fixhst(w(jhist),w(iz)) call xdrflt(id,w(iz),150,jflag) endif call xdrflt(id,w(jstat),10*nproc0,jflag) call xdrflt(id,w(iee),ntf,jflag) if(lena.gt.0) call xdrflt(id,a,lena,jflag) endif endif c c string arrays c call xdrstr(id,sp,8000,jflag) call xdrstr(id,su,8000,jflag) c 30 call xdrutl(id,sname,'c',jflag) 40 ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fixpth(path,path0) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + path0(101,*),path(101,*) c c compare old and new paths and start a new branch if reasonable c num=idint(path(101,1)) num0=idint(path0(101,1)) if(num0.gt.num) go to 10 if(num0.gt.1) then do i=1,num0-1 do j=1,6 if(path0(i,j).ne.path(i,j)) go to 10 enddo enddo endif if(path0(num0,1).ne.path(num0,1)) go to 10 if(path0(num0,2).ne.path(num0,2)) go to 10 it=idint(path(num0,6)) it0=idint(path0(num0,6)) if(it.eq.it0.and.it.ne.6) then if(path0(num0,3).ne.path(num0,3)) go to 10 if(path0(num0,4).ne.path(num0,4)) go to 10 if(path0(num0,5).ne.path(num0,5)) go to 10 endif c c restore old path c if(num.ge.100) then do i=1,100 do j=1,6 path(i,j)=path(i+1,j) enddo enddo num=100 else num=num+1 endif c c start a new branch c do j=1,6 path(num,j)=path0(num0,j) enddo path(num,6)=dfloat(7) path(101,1)=dfloat(num) return c c restore current path c 10 do i=1,num0 do j=1,6 path(i,j)=path0(i,j) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fixhst(hist,hist0) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + hist0(22,*),hist(22,*) c c compare old and new histray arrays c mxhist=20 numhst=20 num=idint(hist(mxhist+2,1)) num0=idint(hist0(mxhist+2,1)) istart=1 if(num0.gt.num) go to 10 istart=7 c c save error histories c if(num0.gt.1) then do i=1,num0 isw=0 do j=1,6 if(hist0(i,j).ne.hist(i,j)) isw=1 enddo if(isw.eq.1) then if(num.ge.mxhist) then do k=1,mxhist do j=1,6 hist(k,j)=hist(k+1,j) enddo enddo num=mxhist else num=num+1 endif do j=1,6 hist(num,j)=hist0(i,j) enddo hist(mxhist+2,1)=dfloat(num) endif enddo endif c c restore current history for everything else c 10 do i=1,mxhist+2 do j=istart,numhst hist(i,j)=hist0(i,j) enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine reset(num,name,nptr,labels,values,ip,rp,sp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(*),nptr(*),mark(100) double precision + rp(*) character*15 + name(*) character*80 + sp(*),labels(*),values(*),sval(100),list,ss character*1 + cmd,typ(100) character*6 + cmdtyp character*9 + tval(100) character*80 + msg common /atest3/mode,jnlsw,jnlr,jnlw,ibatch common /atest4/jcmd,cmdtyp,list c c reset user paremeters c cmd=list(1:1) call lookup(name,num,ip,rp,sp,list,ierr,length) c c print parameters c if(mode.eq.-1) call disply(name,num,ip,rp,sp) c if(ierr.ne.0) then ss='command error' call filutl(ss,0) endif if(length.gt.1.and.ierr.eq.0) return c c x-windows display c if(jnlsw.eq.0) then do i=1,num mark(i)=0 call cint(name(i),3,indx,jerr) tval(i)(1:9)=name(i)(5:13) if(tval(i)(9:9).eq.' ') then tval(i)(9:9)=tval(i)(8:8) tval(i)(8:8)=' ' endif typ(i)=name(i)(15:15) sval(i)=' ' if(name(i)(15:15).eq.'i') then call sint(sval(i),length,ip(indx)) else if(name(i)(15:15).eq.'r') then call sreal(sval(i),length,rp(indx),5,0) else sval(i)=sp(indx) endif enddo c if(num.eq.1.and.typ(1).eq.'f') then call xfile(list,sval,tval,jcmd) if(sp(indx).ne.sval(1)) mark(1)=1 else call xreset(list,num,typ,sval,mark,tval, + nptr,labels,values,jcmd) endif c do i=1,num if(mark(i).ne.0) then call cint(name(i),3,indx,jerr) if(name(i)(15:15).eq.'i') then call cint(sval(i),80,ival,jerr) if(jerr.eq.0) ip(indx)=ival else if(name(i)(15:15).eq.'r') then call creal(sval(i),80,rval,jerr) if(jerr.eq.0) rp(indx)=rval else jerr=0 sp(indx)=sval(i) endif if(jerr.eq.0) then ss=' ' if(name(i)(15:15).eq.'l') then call fstr(ss,length,sval(i),1) else call fstr(ss,length,sval(i),0) endif write(unit=msg,fmt='(a1,a6,a1,a72)') + cmd,name(i)(5:10),'=',ss call star0(msg) call filutl(msg,1) endif endif enddo c else if(jnlsw.ne.-2) then call getcmd(list) endif c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine menu(ip,rp,sp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + st(24),ip(*),iptr(525),nptr(301),sptr(101) double precision + rp(*) character*1 + sty(24) character*6 + cmdtyp character*15 + name(300),sname(100),ctable(24) character*80 + sp(100),list,ulist,file(500),labels(500), 1 values(500),slabel(200),svalue(200),filnam common /atest3/mode,jnlsw,jnlr,jnlw,ibatch common /atest4/jcmd,cmdtyp,list common /atest6/nproc,myid,mpisw c save ncmd,ctable,iptr,st,sty,name,nptr,labels,values save ifirst,iustat,ulist,lowera,lowerz c data ifirst/-1/ data lowera,lowerz/97,122/ c if(ifirst.eq.-1) then call mpiutl(1) mode=0 if(myid.ne.0) mode=-2 do i=1,100 ip(i)=0 rp(i)=0.0d0 sp(i)=' ' enddo call gtfile(file,len) call mkcmd(file,len,name,nlen,nptr,labels,values, + ncmd,ctable,st,sty,iptr,ip,rp,sp) c************************* cc call prtfl(file,len) cc call prtfl0(file,len) c********************** ip(42)=mode ip(48)=mpisw ip(49)=nproc ip(50)=myid+1 ifirst=1 return endif sp(12)=' ' if(ifirst.eq.1) then jcmd=ncmd sp(12)(1:6)='quit ' mode=ip(42) if(mode.gt.1.or.mode.lt.-2) then sp(11)='menu: bad value for mode' return endif if(mode.eq.0) then call xwinit(ncmd,ctable,sp(13)) call grinit(ip(43)) do i=1,ncmd if(ctable(i)(10:15).eq.'mpicmd') call xmpi(mpisw) enddo else if(mode.eq.1) then call mkjnl(sp,kflag) if(kflag.ne.0) go to 40 call stfile(filnam,sp(10)) call ascutl(jnlr,filnam,'r',kflag) if(kflag.ne.0) go to 40 endif jnlsw=mode call stfile(filnam,sp(8)) call ascutl(jnlw,filnam,'w',kflag) if(kflag.ne.0) go to 40 call stfile(filnam,sp(9)) call ascutl(ibatch,filnam,'w',kflag) if(kflag.ne.0) go to 40 c ulist=' ' list=' ' iustat=0 ifirst=0 endif c ierr=0 5 if(ierr.gt.0) sp(11)='command error' if(sp(11).ne.' ') call filutl(sp(11),0) if(iustat.eq.1.and.ulist.eq.list) iustat=0 if(iustat.eq.0) then if(jnlsw.eq.0) then call xgtcmd(list) else if(jnlsw.ne.-2) then call getcmd(list) endif endif c c mpi communication c if(mode.eq.-2.and.jnlsw.eq.-2) then call star0(list) call parcmd(ncmd,ctable,list,length,nequal, + jcmd,cmdtyp,ierr) else call parcmd(ncmd,ctable,list,length,nequal, + jcmd,cmdtyp,ierr) call star0(list) endif c iustat=0 sp(11)=' ' if(ierr.ne.0) go to 5 if(length.eq.0) then if(mode.eq.-1) call discmd(ncmd,ctable) ierr=0 go to 5 endif c c quit and mpicmd are always executed by all processors c if(mode.eq.-2.and.jnlsw.eq.1.and.mpisw.eq.-1) then if(cmdtyp.ne.'mpicmd'.and.cmdtyp.ne.'quit ') then ii=ichar(list(1:1)) if(ii.ge.lowera.and.ii.le.lowerz) list(1:1)=char(ii-32) if(length.le.1) go to 5 endif endif if(list(1:1).eq.ctable(jcmd)(8:8)) go to 30 c c reset parameters with display c iustat=1 ulist=list if(nequal.eq.0.and.st(jcmd).gt.0.and.length.gt.1) then call shrtfm(ip,rp,sp,length,sty,st,ierr) else num=iptr(jcmd+1)-iptr(jcmd) call mktabl(jcmd,name,iptr,sname, + nptr,labels,values,sptr,slabel,svalue) call reset(num,sname,sptr,slabel,svalue,ip,rp,sp) ierr=0 endif sp(11)=' ' go to 5 c 30 sp(12)(1:6)=ctable(jcmd)(1:6) if(length.eq.1) go to 40 c c short form of command c if(nequal.eq.0.and.st(jcmd).gt.0) then call shrtfm(ip,rp,sp,length,sty,st,ierr) c c long form of command c else num=iptr(jcmd+1)-iptr(jcmd) call mktabl(jcmd,name,iptr,sname, + nptr,labels,values,sptr,slabel,svalue) call lookup(sname,num,ip,rp,sp,list,ierr,length) endif c if(ierr.ne.0) go to 5 c c quit command c 40 if(sp(12)(1:6).eq.'quit '.or.cmdtyp.eq.'quit ') then call mpiutl(-1) jcmd=-1 if(mode.eq.0) call xwinit(jcmd,ctable,sp(13)) if(jnlsw.eq.1) call ascutl(jnlr,filnam,'c',kflag) call ascutl(jnlw,filnam,'c',kflag) call ascutl(ibatch,filnam,'c',kflag) c c journal command c else if(cmdtyp.eq.'journl') then ierr=0 if(jnlsw.le.0) then call mkjnl(sp,kflag) if(kflag.ne.0) go to 5 call stfile(filnam,sp(10)) call ascutl(jnlr,filnam,'r',kflag) if(kflag.ne.0) then sp(11)='journl: cannot open file' else sp(11)='journl: ok' jnlsw=1 endif go to 5 else go to 5 endif c c user command c else if(cmdtyp.eq.'usrcmd') then iustat=1 ulist=list sp(11)='usrcmd: ok' c c mpi command c else if(cmdtyp.eq.'mpicmd') then if(length.eq.1) then mpisw=-mpisw ip(48)=mpisw else if(ip(48).ne.1) ip(48)=-1 mpisw=ip(48) endif if(mpisw.eq.1) then sp(11)='mpi is on' else sp(11)='mpi is off' endif ierr=0 if(mode.eq.0) call xmpi(mpisw) go to 5 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine parcmd(ncmd,ctable,list,length,nequal, + jcmd,cmdtyp,ierr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + lequal(24),lcomma(24) character*1 + lcmd,ucmd character*6 + cmdtyp character*15 + ctable(*) character*80 + list c call fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) c c obvious errors c call filutl(list,1) if(length.eq.0) then ierr=0 return endif ierr=1 jcmd=0 cmdtyp=' ' if(icomnt.eq.1) then ierr=-1 return endif if(nequal.gt.0) then if(ncomma.ne.nequal-1) return else if(ncomma.gt.0) return endif if((ndbleq/2)*2.ne.ndbleq) return c c find command code c do icmd=1,ncmd lcmd=ctable(icmd)(8:8) ii=ichar(lcmd)-32 ucmd=char(ii) if(lcmd.eq.list(1:1).or.ucmd.eq.list(1:1)) go to 20 enddo return 20 if(lcmd.eq.list(1:1)) cmdtyp=ctable(icmd)(10:15) jcmd=icmd ierr=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine shrtfm(ip,rp,sp,length,sty,st,ierr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + st(*),ip(*) double precision + rp(*) character*1 + sty(*) character*6 + cmdtyp character*80 + sp(100),list common /atest4/jcmd,cmdtyp,list c c short form of command c ierr=0 ll=length-1 if(sty(jcmd).eq.'i') then call cint(list(2:2),ll,ival,ierr) if(ierr.eq.0) ip(st(jcmd))=ival else if(sty(jcmd).eq.'r') then call creal(list(2:2),ll,rval,ierr) if(ierr.eq.0) rp(st(jcmd))=rval else if(sty(jcmd).eq.'l') then sp(st(jcmd))=' ' sp(st(jcmd))(1:ll-2)=list(3:length-1) else sp(st(jcmd))=' ' sp(st(jcmd))(1:ll)=list(2:length) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine prtfl(file,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + lcomma(24),lequal(24) character*80 + file(*),lstr,line character*1 + mark(10),cc(4) save mark,cc data mark/'+','1','2','3','4','5','6','7','8','9'/ data cc/'n','c','r','s'/ c c get rid of comments, blank lines and spaces c ishift=0 do i=1,len lstr=file(i) call fxcase(lstr,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(icomnt.eq.1.or.length.eq.0) then ishift=ishift+1 else file(i-ishift)=' ' file(i-ishift)(1:length)=lstr(1:length) endif enddo len=len-ishift c c c ii=1 k=1 is=8 do m=1,4 do 10 i=1,len if(file(i)(1:1).ne.cc(m)) go to 10 call fstr(lstr,length,file(i),0) line=' ' line(6:6)=mark(ii) line(is+1:is+1)=char(39) ll=is+1+length line(is+2:ll)=lstr(1:length) line(ll+1:ll+1)=char(39) if(ii.ne.10.and.k.lt.len) then line(ll+2:ll+2)=',' else line(ll+2:ll+2)='/' endif if(ii.eq.1) then k9=min0(k+9,len) write(unit=10,fmt='(12x,a17,i3,a1,i3,a2)') + 'data (file0(i),i=',k,',',k9,')/' endif write(unit=10,fmt='(a80)') line k=k+1 ii=ii+1 if(ii.gt.10) ii=1 10 continue enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine prtfl0(file,len) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + lcomma(24),lequal(24) character*80 + file(*),lstr character*1 + cc(4) save cc data cc/'n','c','r','s'/ c c get rid of comments, blank lines and spaces c ishift=0 do i=1,len lstr=file(i) call fxcase(lstr,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(icomnt.eq.1.or.length.eq.0) then ishift=ishift+1 else file(i-ishift)=' ' file(i-ishift)(1:length)=lstr(1:length) endif enddo len=len-ishift c c do m=1,4 do 10 i=1,len if(file(i)(1:1).ne.cc(m)) go to 10 call fstr(lstr,length,file(i),0) write(unit=11,fmt='(a80)') lstr 10 continue enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine getnam(name,nlen) c implicit double precision (a-h,o-z) implicit integer (i-n) c integer + lcomma(24),lequal(24),ig(2) double precision + rg(2) character*15 + name(*),name0(20) character*80 + lstr,file(500),sg(5) save name0 data (name0(i),i= 1, 5)/ + ' 1 index i s',' 2 vname n s',' 3 alias a s', 1 ' 4 vtype t s',' 5 deflt d l'/ c c call gtfile(file,len) nlen=0 do 5 i=1,len lstr=file(i) call fxcase(lstr,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(icomnt.eq.1.or.length.eq.0) go to 5 if(lstr(1:1).ne.'n') go to 5 c nlen=nlen+1 name(nlen)=' ' do j=1,5 sg(j)=' ' enddo call lookup(name0,5,ig,rg,sg,lstr,ierr,length) name(nlen)(1:3)=sg(1)(1:3) name(nlen)(5:10)=sg(2)(1:6) name(nlen)(12:13)=sg(3)(1:2) name(nlen)(15:15)=sg(4)(1:1) 5 continue return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkcmd(file,len,name,nlen,nptr,labels,values, + ncmd,ctable,st,sty,iptr,ip,rp,sp) c implicit double precision (a-h,o-z) implicit integer (i-n) c integer + iptr(*),st(*),nptr(*),lcomma(24),lequal(24),num(300), 1 inum(24),snum(24),ig(2),jv(500),iv(200),ic(200),ip(100) double precision + rg(2),rp(100) character*1 + typ,jtyp,uppera,upperz,cc,sty(*) character*15 + name(*),ctable(*),name0(20),ntemp character*80 + lstr,labels(*),values(*),file(*),sg(5),sp(100), 1 l0(500),v0(500) save name0,mxnam,mxcmd,mxvar,mxlst data (name0(i),i= 1, 14)/ + ' 1 index i s',' 2 vname n s',' 3 alias a s', 1 ' 4 vtype t s',' 5 deflt d l',' 1 cname c s', 2 ' 2 cmdkey k s',' 3 ctype t s',' 1 cname c s', 3 ' 2 vname n s',' 3 short s s',' 1 vname n s', 4 ' 2 value v s',' 3 label l l'/ data mxnam,mxcmd,mxvar,mxlst/300,24,500,500/ c c get rid of comments, blank lines and spaces c ishift=0 uppera=char(65) upperz=char(90) do i=1,len lstr=file(i) call fxcase(lstr,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(icomnt.eq.1.or.length.eq.0) then ishift=ishift+1 else cc=lstr(1:1) if(cc.ge.uppera.and.cc.le.upperz) then ii=ichar(cc)+32 lstr(1:1)=char(ii) endif file(i-ishift)=' ' file(i-ishift)(1:length)=lstr(1:length) endif enddo len=len-ishift c c name and ctable c ncmd=0 ilen=0 nlen=0 do i=1,len c c name c if(file(i)(1:1).eq.'n') then nlen=nlen+1 if(nlen.gt.mxnam) stop 3001 name(nlen)=' ' do j=1,5 sg(j)=' ' enddo call lookup(name0(1),5,ig,rg,sg,file(i),ierr,length) name(nlen)(1:3)=sg(1)(1:3) name(nlen)(5:10)=sg(2)(1:6) name(nlen)(12:13)=sg(3)(1:2) typ=sg(4)(1:1) name(nlen)(15:15)=typ if(typ.eq.'i'.or.typ.eq.'r'.or.typ.eq.'s') ilen=ilen+1 if(sg(5).ne.' ') then call cint(sg(1),3,indx,ierr) call fstr(lstr,length,sg(5),0) if(typ.eq.'i') then call cint(lstr,length,ip(indx),ierr) else if(typ.eq.'r') then call creal(lstr,length,rp(indx),ierr) else sp(indx)=' ' sp(indx)(1:length)=lstr(1:length) endif endif c c command c else if(file(i)(1:1).eq.'c') then ncmd=ncmd+1 if(ncmd.gt.mxcmd) stop 3002 ctable(ncmd)=' ' do j=1,3 sg(j)=' ' enddo call lookup(name0(6),3,ig,rg,sg,file(i),ierr,length) ctable(ncmd)(1:6)=sg(1)(1:6) ctable(ncmd)(8:8)=sg(2)(1:1) ctable(ncmd)(10:15)=sg(3)(1:6) endif enddo c c sort c nn=ilen+1 do i=1,ilen typ=name(i)(15:15) if(typ.ne.'i'.and.typ.ne.'r'.and.typ.ne.'s') then do j=nn,nlen jtyp=name(j)(15:15) if(jtyp.eq.'i'.or.jtyp.eq.'r'.or.jtyp.eq.'s') then ntemp=name(i) name(i)=name(j) name(j)=ntemp nn=j+1 go to 5 endif enddo stop 9413 endif 5 enddo c c iptr, nptr c do i=1,nlen num(i)=0 enddo do i=1,ncmd inum(i)=0 snum(i)=0 enddo c ilen=0 jlen=0 do i=1,len c c reset variable c if(file(i)(1:1).eq.'r') then ilen=ilen+1 if(ilen.gt.mxvar) stop 3003 do j=1,3 sg(j)=' ' enddo call lookup(name0(9),3,ig,rg,sg,file(i),ierr,length) do j=1,ncmd if(sg(1)(1:6).eq.ctable(j)(1:6)) go to 10 enddo stop 1001 10 ic(ilen)=j do j=1,nlen if(sg(2)(1:6).eq.name(j)(5:10)) go to 20 enddo stop 1002 20 iv(ilen)=j if(sg(3)(1:1).eq.'1') iv(ilen)=-j typ=name(j)(15:15) if(typ.eq.'i'.or.typ.eq.'r'.or.typ.eq.'s') then inum(ic(ilen))=inum(ic(ilen))+1 else snum(ic(ilen))=snum(ic(ilen))+1 endif c c switch c else if(file(i)(1:1).eq.'s') then jlen=jlen+1 if(jlen.gt.mxlst) stop 3004 do j=1,3 sg(j)=' ' enddo call lookup(name0(12),3,ig,rg,sg,file(i),ierr,length) do j=1,nlen if(sg(1)(1:6).eq.name(j)(5:10)) go to 30 enddo stop 1003 30 jv(jlen)=j v0(jlen)=sg(2) l0(jlen)=sg(3) num(j)=num(j)+1 endif enddo c c compute start of iptr c iptr(1)=ncmd+2 do i=1,ncmd iptr(i+1)=iptr(i)+inum(i)+snum(i) snum(i)=iptr(i)+inum(i) inum(i)=iptr(i) st(i)=0 enddo c c compute the rest of iptr c do i=1,ilen icmd=ic(i) ivar=iabs(iv(i)) typ=name(ivar)(15:15) if(typ.eq.'i'.or.typ.eq.'r'.or.typ.eq.'s') then k=inum(icmd) inum(icmd)=k+1 else k=snum(icmd) snum(icmd)=k+1 endif iptr(k)=ivar if(iv(i).lt.0) then call cint(name(ivar),3,indx,jerr) st(icmd)=indx sty(icmd)=typ endif enddo c c compute nptr c nptr(1)=1 do i=1,nlen nptr(i+1)=nptr(i)+num(i) num(i)=nptr(i) enddo c c compute labels and values c do i=1,jlen ivar=jv(i) k=num(ivar) num(ivar)=k+1 labels(k)=l0(i) values(k)=v0(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine usrset(file,len,ip,rp,sp) c implicit double precision (a-h,o-z) implicit integer (i-n) c integer + iptr(5),st(5),nptr(301),ip(100) double precision + rp(100) character*1 + sty(5) character*15 + name(300),ctable(5) character*80 + labels(500),values(500),file(*),sp(100) c c mkcmd interface for usrcmd c if(len.gt.500) return call mkcmd(file,len,name,nlen,nptr,labels,values, + ncmd,ctable,st,sty,iptr,ip,rp,sp) call reset(nlen,name,nptr,labels,values,ip,rp,sp) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine gtfile(file,len) c implicit double precision (a-h,o-z) implicit integer (i-n) character*80 + file0(500),file(*) c data (file0(i),i= 1, 10)/ + 'ni=1,n=ntf,t=i', 1 'ni=2,n=nvf,t=i', 2 'ni=3,n=ncf,t=i', 3 'ni=4,n=nbf,t=i', 4 'ni=5,n=ifirst,t=i,a=f,d="1"', 5 'ni=6,n=iprob,t=i,a=p,d="1"', 6 'ni=7,n=idbc,t=i,d="0"', 7 'ni=8,n=ispd,t=i,a=i,d="0"', 8 'ni=9,n=itask,t=i,a=t,d="0"', 9 'ni=10,n=mxcg,t=i,a=c,d="10"'/ data (file0(i),i= 11, 20)/ + 'ni=11,n=mxnwtt,t=i,a=n,d="10"', 1 '#ni=14,n=mxstep,t=i,a=ms,d="20"', 2 'ni=16,n=nevp,t=i', 3 'ni=18,n=maxja,t=i', 4 'ni=19,n=maxa,t=i', 5 'ni=20,n=lenw,t=i', 6 'ni=21,n=maxt,t=i', 7 'ni=22,n=maxv,t=i', 8 'ni=23,n=maxc,t=i', 9 'ni=24,n=maxb,t=i'/ data (file0(i),i= 21, 30)/ + 'ni=25,n=iflag,t=i', 1 'ni=26,n=iadapt,t=i,a=a,d="1"', 2 'ni=27,n=irefn,t=i,a=ir,d="2"', 3 'ni=28,n=nvtrgt,t=i,a=n', 4 'ni=29,n=nrgn,t=i,a=nr,d="10"', 5 'ni=31,n=newntf,t=i', 6 'ni=32,n=newnvf,t=i', 7 'ni=33,n=newnbf,t=i', 8 'ni=34,n=nvv,t=i', 9 'ni=35,n=nbb,t=i'/ data (file0(i),i= 31, 40)/ + 'ni=36,n=nvi,t=i', 1 'ni=37,n=nbi,t=i', 2 'ni=38,n=ntg,t=i', 3 'ni=39,n=nvg,t=i', 4 'ni=40,n=nbg,t=i', 5 'ni=41,n=iusrsw,t=i,d="1"', 6 'ni=42,n=mode,t=i,d="0"', 7 'ni=43,n=ngraph,t=i,d="0"', 8 'ni=44,n=fdevce,t=i,a=d,d="0"', 9 'ni=45,n=gdevce,t=i,a=d,d="1"'/ data (file0(i),i= 41, 50)/ + 'ni=46,n=jdevce,t=i,a=d,d="2"', 1 'ni=47,n=mdevce,t=i,a=d,d="3"', 2 'ni=48,n=mpisw,t=i,a=i,d="-1"', 3 'ni=49,n=nproc,t=i,d="1"', 4 'ni=50,n=irgn,t=i,d="1"', 5 'ni=51,n=mxcolr,t=i,a=mc,d="100"', 6 'ni=52,n=ifun,t=i,a=f,d="0"', 7 'ni=53,n=inplsw,t=i,a=i,d="0"', 8 'ni=54,n=igrsw,t=i,a=i,d="0"', 9 'ni=55,n=imtxsw,t=i,a=i,d="2"'/ data (file0(i),i= 51, 60)/ + 'ni=56,n=ncon,t=i,a=c,d="11"', 1 'ni=57,n=icont,t=i,a=ic,d="0"', 2 'ni=58,n=iscale,t=i,a=s,d="0"', 3 'ni=59,n=lines,t=i,a=l,d="0"', 4 'ni=60,n=numbrs,t=i,a=n,d="0"', 5 'ni=61,n=nx,t=i,a=nx,d="0"', 6 'ni=62,n=ny,t=i,a=ny,d="0"', 7 'ni=63,n=nz,t=i,a=nz,d="1"', 8 'ni=64,n=mx,t=i,a=mx,d="1"', 9 'ni=65,n=my,t=i,a=my,d="1"'/ data (file0(i),i= 61, 70)/ + 'ni=66,n=mz,t=i,a=mz,d="1"', 1 'ni=67,n=level,t=i,a=lv,d="0"', 2 'ni=68,n=icrsn,t=i,a=cr,d="0"', 3 'ni=69,n=itrgt,t=i,a=it,d="10000"', 4 'ni=70,n=ibase,t=i', 5 'ni=71,n=nvdd,t=i', 6 'ni=72,n=lipath,t=i', 7 'ni=73,n=lenja,t=i', 8 'ni=74,n=lena,t=i', 9 'ni=75,n=lvl,t=i'/ data (file0(i),i= 71, 80)/ + 'ni=76,n=nef,t=i', 1 'ni=77,n=ngf,t=i', 2 'ni=78,n=dbctag,t=i', 3 'ni=79,n=ievals,t=i', 4 'ni=80,n=itnum,t=i', 5 'ni=81,n=maxpth,t=i', 6 'ni=83,n=iuu,t=i', 7 'ni=84,n=iux,t=i', 8 'ni=85,n=iuy,t=i', 9 'ni=86,n=iu0,t=i'/ data (file0(i),i= 81, 90)/ + 'ni=87,n=iudot,t=i', 1 'ni=88,n=iu0dot,t=i', 2 'ni=89,n=iudl,t=i', 3 'ni=90,n=ievr,t=i', 4 'ni=91,n=ievl,t=i', 5 'ni=92,n=jtime,t=i', 6 'ni=93,n=jhist,t=i', 7 'ni=94,n=jpath,t=i', 8 'ni=95,n=ka,t=i', 9 'ni=96,n=jstat,t=i'/ data (file0(i),i= 91,100)/ + 'ni=97,n=iee,t=i', 1 'ni=98,n=ipath,t=i', 2 'ni=99,n=iz,t=i', 3 'ni=1,n=rltrgt,t=r,a=l,d="0.0e0"', 4 'ni=2,n=rtrgt,t=r,a=r,d="0.0e0"', 5 'ni=3,n=rmtrgt,t=r,a=m,d="0.1e0"', 6 'ni=4,n=rllwr,t=r,a=lw,d="0.0e0"', 7 'ni=5,n=rlupr,t=r,a=up,d="1.0e0"', 8 'ni=6,n=dtol,t=r,a=d,d="1.0e-4"', 9 'ni=8,n=smin,t=r,a=sn,d="0.0e0"'/ data (file0(i),i=101,110)/ + 'ni=9,n=smax,t=r,a=sx,d="0.0e0"', 1 'ni=10,n=rmag,t=r,a=m,d="1.0e0"', 2 'ni=11,n=cenx,t=r,a=cx,d="0.5e0"', 3 'ni=12,n=ceny,t=r,a=cy,d="0.5e0"', 4 'ni=15,n=hmax,t=r,a=hx,d="0.1e0"', 5 'ni=16,n=grade,t=r,a=g,d="1.5e0"', 6 'ni=17,n=hmin,t=r,a=hn,d="0.05e0"', 7 'ni=21,n=rl,t=r', 8 'ni=22,n=r,t=r', 9 'ni=23,n=rldot,t=r'/ data (file0(i),i=111,120)/ + 'ni=24,n=rdot,t=r', 1 'ni=25,n=sval,t=r', 2 'ni=26,n=rlstrt,t=r', 3 'ni=27,n=rstrt,t=r', 4 'ni=31,n=rl0,t=r', 5 'ni=32,n=r0,t=r', 6 'ni=33,n=rl0dot,t=r', 7 'ni=34,n=r0dot,t=r', 8 'ni=35,n=sval0,t=r', 9 'ni=37,n=enorm1,t=r'/ data (file0(i),i=121,130)/ + 'ni=38,n=unorm1,t=r', 1 'ni=39,n=enorm2,t=r', 2 'ni=40,n=unorm2,t=r', 3 '#ni=42,n=tstart,t=r,a=s,d="0.0e0"', 4 '#ni=43,n=tend,t=r,a=e,d="0.0e0"', 5 '#ni=44,n=tmtol,t=r,a=tt,d="1.0e-2"', 6 '#ni=45,n=sh,t=r,d="0.0e0"', 7 '#ni=46,n=tcur,t=r', 8 '#ni=47,n=deltat,t=r', 9 '#ni=48,n=dtmin,t=r'/ data (file0(i),i=131,140)/ + '#ni=49,n=dtmax,t=r', 1 '#ni=50,n=utnorm,t=r', 2 'ni=51,n=eps,t=r', 3 'ni=52,n=step,t=r', 4 'ni=53,n=bnorm,t=r', 5 'ni=54,n=relerr,t=r', 6 'ni=55,n=anorm,t=r', 7 'ni=56,n=relres,t=r', 8 'ni=57,n=bratio,t=r', 9 'ni=58,n=bnorm0,t=r'/ data (file0(i),i=141,150)/ + 'ni=59,n=reler0,t=r', 1 'ni=60,n=dnew,t=r', 2 'ni=63,n=rmu,t=r', 3 'ni=64,n=rmu0,t=r', 4 'ni=67,n=scleqn,t=r', 5 'ni=68,n=scale,t=r', 6 'ni=69,n=thetal,t=r', 7 'ni=70,n=thetar,t=r', 8 'ni=71,n=sigma,t=r', 9 'ni=72,n=delta,t=r'/ data (file0(i),i=151,160)/ + 'ni=73,n=drdrl,t=r', 1 'ni=74,n=seqdot,t=r', 2 'ni=76,n=qual,t=r', 3 'ni=77,n=angmn,t=r', 4 'ni=78,n=diam,t=r', 5 'ni=79,n=best,t=r', 6 'ni=80,n=area,t=r', 7 'ni=81,n=tola,t=r', 8 'ni=82,n=arcmin,t=r', 9 'ni=83,n=arcmax,t=r'/ data (file0(i),i=161,170)/ + 'ni=84,n=tolz,t=r', 1 'ni=85,n=tolf,t=r', 2 'ni=87,n=xmin,t=r', 3 'ni=88,n=xmax,t=r', 4 'ni=89,n=ymin,t=r', 5 'ni=90,n=ymax,t=r', 6 'ni=1,n=ftitle,t=l,a=t,d="triplt"', 7 'ni=2,n=ititle,t=l,a=t,d="inplt"', 8 'ni=3,n=gtitle,t=l,a=t,d="gphplt"', 9 'ni=4,n=mtitle,t=l,a=t,d="mtxplt"'/ data (file0(i),i=171,180)/ + 'ni=5,n=shcmd,t=l,a=c', 1 'ni=6,n=rwfile,t=f,a=f,d="pltmg_mpixxx.rw"', 2 'ni=7,n=jrfile,t=f,a=f,d="pltmg.jnl"', 3 'ni=8,n=jwfile,t=f,d="journl_mpixxx.jnl"', 4 'ni=9,n=bfile,t=f,d="output_mpixxx.out"', 5 'ni=10,n=jtfile,t=f,d="jnltmp_mpixxx.jnl"', 6 'ni=11,n=iomsg,t=l', 7 'ni=12,n=cmd,t=s', 8 'ni=13,n=logo,t=l,d="pltmg 8.6"', 9 'ni=14,n=bgclr,t=l,d="gray85"'/ data (file0(i),i=181,190)/ + 'ni=15,n=btnbg,t=l,d="gray30"', 1 'ni=18,n=psfile,t=f,d="figxxx.ps"', 2 'ni=19,n=xpfile,t=f,d="figxxx.xpm"', 3 'ni=20,n=bhfile,t=f,d="figxxx.bh"', 4 'ni=21,n=sghost,t=f,d="localhost"', 5 'cc=pltmg,k=s,t=popup', 6 'cc=trigen,k=t,t=popup', 7 'cc=triplt,k=f,t=popup', 8 'cc=gphplt,k=g,t=popup', 9 'cc=inplt,k=i,t=popup'/ data (file0(i),i=191,200)/ + 'cc=mtxplt,k=m,t=popup', 1 'cc=read,k=r,t=file', 2 'cc=write,k=w,t=file', 3 'cc=usrcmd,k=u,t=usrcmd', 4 'cc=journl,k=j,t=journl', 5 'cc=shell,k=k,t=popup', 6 'cc=mpi,k=p,t=mpicmd', 7 'cc=quit,k=q,t=quit', 8 'rc=pltmg,n=iprob', 9 'rc=pltmg,n=ifirst'/ data (file0(i),i=201,210)/ + 'rc=pltmg,n=ispd', 1 'rc=pltmg,n=itask', 2 'rc=pltmg,n=mxcg', 3 'rc=pltmg,n=mxnwtt', 4 'rc=pltmg,n=rltrgt', 5 'rc=pltmg,n=rtrgt', 6 'rc=pltmg,n=rmtrgt', 7 'rc=pltmg,n=dtol', 8 'rc=pltmg,n=rllwr', 9 'rc=pltmg,n=rlupr'/ data (file0(i),i=211,220)/ + '#rc=pltmg,n=mxstep', 1 '#rc=pltmg,n=tmtol', 2 '#rc=pltmg,n=tstart', 3 '#rc=pltmg,n=tend', 4 'rc=trigen,n=iadapt', 5 'rc=trigen,n=ifirst', 6 'rc=trigen,n=nvtrgt', 7 'rc=trigen,n=irefn', 8 'rc=trigen,n=nrgn', 9 'rc=trigen,n=hmax'/ data (file0(i),i=221,230)/ + 'rc=trigen,n=hmin', 1 'rc=trigen,n=grade', 2 'rc=triplt,n=ifun,s=1', 3 'rc=triplt,n=iscale', 4 'rc=triplt,n=lines', 5 'rc=triplt,n=numbrs', 6 'rc=triplt,n=fdevce', 7 'rc=triplt,n=nx', 8 'rc=triplt,n=ny', 9 'rc=triplt,n=nz'/ data (file0(i),i=231,240)/ + 'rc=triplt,n=ncon', 1 'rc=triplt,n=icont', 2 'rc=triplt,n=icrsn', 3 'rc=triplt,n=itrgt', 4 'rc=triplt,n=mxcolr', 5 'rc=triplt,n=smin', 6 'rc=triplt,n=smax', 7 'rc=triplt,n=rmag', 8 'rc=triplt,n=cenx', 9 'rc=triplt,n=ceny'/ data (file0(i),i=241,250)/ + 'rc=triplt,n=ftitle', 1 'rc=gphplt,n=igrsw,s=1', 2 'rc=gphplt,n=mx', 3 'rc=gphplt,n=my', 4 'rc=gphplt,n=mz', 5 'rc=gphplt,n=gdevce', 6 'rc=gphplt,n=mxcolr', 7 'rc=gphplt,n=gtitle', 8 'rc=inplt,n=inplsw,s=1', 9 'rc=inplt,n=iscale'/ data (file0(i),i=251,260)/ + 'rc=inplt,n=lines', 1 'rc=inplt,n=numbrs', 2 'rc=inplt,n=jdevce', 3 'rc=inplt,n=rmag', 4 'rc=inplt,n=cenx', 5 'rc=inplt,n=ceny', 6 'rc=inplt,n=ncon', 7 'rc=inplt,n=mxcolr', 8 'rc=inplt,n=icrsn', 9 'rc=inplt,n=itrgt'/ data (file0(i),i=261,270)/ + 'rc=inplt,n=ititle', 1 'rc=inplt,n=smin', 2 'rc=inplt,n=smax', 3 'rc=mtxplt,n=imtxsw,s=1', 4 'rc=mtxplt,n=iscale', 5 'rc=mtxplt,n=lines', 6 'rc=mtxplt,n=numbrs', 7 'rc=mtxplt,n=mdevce', 8 'rc=mtxplt,n=mx', 9 'rc=mtxplt,n=my'/ data (file0(i),i=271,280)/ + 'rc=mtxplt,n=mz', 1 'rc=mtxplt,n=ncon', 2 'rc=mtxplt,n=level', 3 'rc=mtxplt,n=mxcolr', 4 'rc=mtxplt,n=smin', 5 'rc=mtxplt,n=smax', 6 'rc=mtxplt,n=rmag', 7 'rc=mtxplt,n=cenx', 8 'rc=mtxplt,n=ceny', 9 'rc=mtxplt,n=mtitle'/ data (file0(i),i=281,290)/ + 'rc=read,n=rwfile,s=1', 1 'rc=write,n=rwfile,s=1', 2 'rc=journl,n=jrfile,s=1', 3 'rc=shell,n=shcmd,s=1', 4 'rc=mpi,n=mpisw,s=1', 5 'sn=ifirst,v=0,l="default"', 6 'sn=ifirst,v=1,l="initialize"', 7 'sn=iprob,v=1,l="simple pde"', 8 'sn=iprob,v=2,l="obstacle problem"', 9 'sn=iprob,v=3,l="continuation problem"'/ data (file0(i),i=291,300)/ + 'sn=iprob,v=4,l="parameter identification"', 1 'sn=iprob,v=5,l="optimal control"', 2 '#sn=iprob,v=6,l="parabolic problem"', 3 'sn=iprob,v=-1,l="dd solve - simple pde (mpi) "', 4 'sn=iprob,v=-2,l="dd solve - obstacle (mpi)"', 5 'sn=iprob,v=-3,l="dd solve - continuation (mpi)"', 6 'sn=iprob,v=-4,l="dd solve - parameter identification (mpi)"', 7 'sn=iprob,v=-5,l="dd solve - optimal control (mpi)"', 8 'sn=ispd,v=0,l="nonsymmetric"', 9 'sn=ispd,v=1,l="symmetric"'/ data (file0(i),i=301,310)/ + 'sn=itask,v=0,l="target point"', 1 'sn=itask,v=1,l="compute singular point"', 2 'sn=itask,v=2,l="switch branches"', 3 'sn=itask,v=3,l="initialize, lambda fixed"', 4 'sn=itask,v=4,l="initialize, rho fixed"', 5 'sn=itask,v=5,l="sigma = 0, lambda fixed"', 6 'sn=itask,v=6,l="sigma = 0, rho fixed"', 7 'sn=itask,v=7,l="sigma = 0, theta = 1"', 8 'sn=itask,v=8,l="new lambda"', 9 '#sn=itask,v=9,l="time steps"'/ data (file0(i),i=311,320)/ + '#sn=itask,v=10,l="fixed time"', 1 'sn=iadapt,v=0,l="error estimates"', 2 'sn=iadapt,v=1,l="refine or unrefine"', 3 'sn=iadapt,v=-1,l="refine or unrefine (qxy)"', 4 'sn=iadapt,v=2,l="unrefine and refine"', 5 'sn=iadapt,v=-2,l="unrefine and refine (qxy)"', 6 'sn=iadapt,v=3,l="mesh smoothing"', 7 'sn=iadapt,v=-3,l="mesh smoothing (qxy)"', 8 'sn=iadapt,v=4,l="uniform refinement"', 9 'sn=iadapt,v=5,l="skeleton --> triangulation"'/ data (file0(i),i=321,330)/ + 'sn=iadapt,v=6,l="triangulation --> skeleton"', 1 'sn=iadapt,v=-6,l="triangulation --> skeleton (qxy)"', 2 'sn=iadapt,v=7,l="load balance (mpi)"', 3 'sn=iadapt,v=8,l="reconcile mesh (mpi)"', 4 'sn=iadapt,v=9,l="gather global mesh (mpi)"', 5 'sn=fdevce,v=0,l="socket 0"', 6 'sn=fdevce,v=1,l="socket 1"', 7 'sn=fdevce,v=2,l="socket 2"', 8 'sn=fdevce,v=3,l="socket 3"', 9 'sn=fdevce,v=4,l="bh file"'/ data (file0(i),i=331,340)/ + 'sn=fdevce,v=5,l="ps file"', 1 'sn=fdevce,v=6,l="xpm file"', 2 'sn=fdevce,v=7,l="popup 0"', 3 'sn=fdevce,v=8,l="popup 1"', 4 'sn=fdevce,v=9,l="popup 2"', 5 'sn=fdevce,v=10,l="popup 3"', 6 'sn=gdevce,v=0,l="socket 0"', 7 'sn=gdevce,v=1,l="socket 1"', 8 'sn=gdevce,v=2,l="socket 2"', 9 'sn=gdevce,v=3,l="socket 3"'/ data (file0(i),i=341,350)/ + 'sn=gdevce,v=4,l="bh file"', 1 'sn=gdevce,v=5,l="ps file"', 2 'sn=gdevce,v=6,l="xpm file"', 3 'sn=gdevce,v=7,l="popup 0"', 4 'sn=gdevce,v=8,l="popup 1"', 5 'sn=gdevce,v=9,l="popup 2"', 6 'sn=gdevce,v=10,l="popup 3"', 7 'sn=jdevce,v=0,l="socket 0"', 8 'sn=jdevce,v=1,l="socket 1"', 9 'sn=jdevce,v=2,l="socket 2"'/ data (file0(i),i=351,360)/ + 'sn=jdevce,v=3,l="socket 3"', 1 'sn=jdevce,v=4,l="bh file"', 2 'sn=jdevce,v=5,l="ps file"', 3 'sn=jdevce,v=6,l="xpm file"', 4 'sn=jdevce,v=7,l="popup 0"', 5 'sn=jdevce,v=8,l="popup 1"', 6 'sn=jdevce,v=9,l="popup 2"', 7 'sn=jdevce,v=10,l="popup 3"', 8 'sn=mdevce,v=0,l="socket 0"', 9 'sn=mdevce,v=1,l="socket 1"'/ data (file0(i),i=361,370)/ + 'sn=mdevce,v=2,l="socket 2"', 1 'sn=mdevce,v=3,l="socket 3"', 2 'sn=mdevce,v=4,l="bh file"', 3 'sn=mdevce,v=5,l="ps file"', 4 'sn=mdevce,v=6,l="xpm file"', 5 'sn=mdevce,v=7,l="popup 0"', 6 'sn=mdevce,v=8,l="popup 1"', 7 'sn=mdevce,v=9,l="popup 2"', 8 'sn=mdevce,v=10,l="popup 3"', 9 'sn=ifun,v=0,l="u"'/ data (file0(i),i=371,380)/ + 'sn=ifun,v=1,l="|grad u|"', 1 'sn=ifun,v=2,l="grad u"', 2 'sn=ifun,v=3,l="qxy"', 3 'sn=ifun,v=4,l="vector qxy"', 4 'sn=ifun,v=5,l="error"', 5 'sn=ifun,v=6,l="udot"', 6 'sn=ifun,v=7,l="evr"', 7 'sn=ifun,v=8,l="evl"', 8 'sn=ifun,v=9,l="um"', 9 'sn=ifun,v=10,l="uc"'/ data (file0(i),i=381,390)/ + 'sn=ifun,v=11,l="dual"', 1 '#sn=ifun,v=12,l="du/dt"', 2 '#sn=ifun,v=13,l="(dx/dt,dy/dt)"', 3 'sn=inplsw,v=0,l="region tag"', 4 'sn=inplsw,v=1,l="load balance"', 5 'sn=inplsw,v=2,l="element quality"', 6 'sn=inplsw,v=3,l="max angle"', 7 'sn=inplsw,v=4,l="min angle"', 8 'sn=inplsw,v=5,l="element diameter"', 9 'sn=inplsw,v=6,l="error"'/ data (file0(i),i=391,400)/ + 'sn=igrsw,v=0,l="newton conv"', 1 'sn=igrsw,v=1,l="multigraph conv"', 2 'sn=igrsw,v=-1,l="matrix size"', 3 'sn=igrsw,v=2,l="subroutine times"', 4 'sn=igrsw,v=-2,l="time pie chart"', 5 'sn=igrsw,v=3,l="continuation path"', 6 'sn=igrsw,v=-3,l="load balance"', 7 'sn=igrsw,v=4,l="h1 error"', 8 'sn=igrsw,v=-4,l="l2 error"', 9 'sn=igrsw,v=5,l="ip array"'/ data (file0(i),i=401,410)/ + 'sn=igrsw,v=-5,l="sp array"', 1 'sn=igrsw,v=6,l="rp array"', 2 'sn=igrsw,v=-6,l="ka array"', 3 'sn=imtxsw,v=1,l="|ilu| by type"', 4 'sn=imtxsw,v=-1,l="ilu by type"', 5 'sn=imtxsw,v=2,l="|ilu| by value"', 6 'sn=imtxsw,v=-2,l="ilu by value"', 7 'sn=imtxsw,v=3,l="|mtx a| by type"', 8 'sn=imtxsw,v=-3,l="mtx a by type"', 9 'sn=imtxsw,v=4,l="|mtx a| by value"'/ data (file0(i),i=411,420)/ + 'sn=imtxsw,v=-4,l="mtx a by value"', 1 'sn=imtxsw,v=5,l="|error| by type"', 2 'sn=imtxsw,v=-5,l="error by type"', 3 'sn=imtxsw,v=6,l="|error| by value"', 4 'sn=imtxsw,v=-6,l="error by value"', 5 'sn=imtxsw,v=7,l="matrix graph"', 6 'sn=imtxsw,v=-7,l="vertex levels"', 7 'sn=icont,v=0,l="do not smooth function"', 8 'sn=icont,v=1,l="smooth function"', 9 'sn=iscale,v=0,l="linear"'/ data (file0(i),i=421,430)/ + 'sn=iscale,v=1,l="log"', 1 'sn=iscale,v=2,l="arcsinh"', 2 'sn=lines,v=0,l="triangulation"', 3 'sn=lines,v=1,l="regions"', 4 'sn=lines,v=2,l="load balance"', 5 'sn=lines,v=3,l="contours"', 6 'sn=lines,v=-1,l="graphics triangulation"', 7 'sn=lines,v=-2,l="matrix elements"', 8 'sn=numbrs,v=0,l="none"', 9 'sn=numbrs,v=1,l="triangles/regions"'/ data (file0(i),i=431,440)/ + 'sn=numbrs,v=2,l="vertices"', 1 'sn=numbrs,v=3,l="edges"', 2 'sn=numbrs,v=4,l="arcs"', 3 'sn=numbrs,v=5,l="bdy cond"', 4 'sn=numbrs,v=6,l="bdy tag"', 5 'sn=numbrs,v=7,l="processor"', 6 'sn=numbrs,v=8,l="vertex type"', 7 'sn=numbrs,v=-1,l="mtx value"', 8 'sn=numbrs,v=-2,l="mtx index"', 9 'sn=icrsn,v=0,l="no coarsening"'/ data (file0(i),i=441,443)/ + 'sn=icrsn,v=1,l="coarsening"', 1 'sn=mpisw,v=1,l="turn on mpi"', 2 'sn=mpisw,v=-1,l="turn off mpi"'/ c data len0/443/ c len=len0 do i=1,len file(i)=file0(i) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mktabl(icmd,name,iptr,sname, + nptr,labels,values,sptr,slabel,svalue) c implicit double precision (a-h,o-z) implicit integer (i-n) c integer + iptr(*),nptr(*),sptr(*) character*15 + name(*),sname(*) character*80 + labels(*),values(*),slabel(*),svalue(*) c c compute sname, sptr, slabel, svalue c sptr(1)=1 do i=iptr(icmd),iptr(icmd+1)-1 k=i+1-iptr(icmd) nl=iptr(i) sname(k)=name(nl) ii=sptr(k) do j=nptr(nl),nptr(nl+1)-1 slabel(ii)=labels(j) svalue(ii)=values(j) ii=ii+1 enddo sptr(k+1)=ii enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine getcmd(list) c implicit double precision (a-h,o-z) implicit integer (i-n) character*80 + list common /atest3/mode,jnlsw,jnlr,jnlw,ibatch c c get the next command from c the tty or the command file c c jnlsw > 0 get command from journal file c = 0 get command from x-windows interface c < 0 get command for terminal window c c c print a prompt symbol c if(jnlsw.lt.0) then call crtutl(list,'r','command:') else if(jnlsw.gt.0) then call ascstr(jnlr,list,80,kflag) if(kflag.ne.0) then call ascutl(jnlr,list,'c',kflag) jnlsw=mode if(mode.eq.1) then list='q' else list=' ' endif endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine lookup(name,num,ip,rp,sp,list,ierr,length) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ival(24),ip(*),lequal(24),lcomma(24),iptr(24) double precision + rp(*),rval(24) character*80 + sp(*),sval(24) character*15 + name(*) character*6 + lname character*2 + sname character*1 + list(*),dbleq c save dbleq data dbleq/'"'/ c c determine number of entries c ierr=0 call fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(num.le.0.or.length.eq.1) return ierr=1 if(icomnt.eq.1.or.(ndbleq/2)*2.ne.ndbleq) return if(nequal.eq.0.or.ncomma.ne.nequal-1) return if(ncomma.gt.0) then do i=1,ncomma if(lcomma(i).lt.lequal(i).or. + lcomma(i).gt.lequal(i+1)) return enddo endif c c the main loop c do ii=1,nequal lname=' ' sname=' ' istart=2 imid=lequal(ii) iend=length if(ii.gt.1) istart=lcomma(ii-1)+1 if(ii.lt.nequal) iend=lcomma(ii)-1 if(iend.le.imid) return if(istart.ge.imid) return if(istart+6.lt.imid) return c c search name array for the variable c do i=istart,imid-1 j=i+1-istart if(imid.le.istart+2) sname(j:j)=list(i) lname(j:j)=list(i) enddo do i=1,num if(name(i)(12:13).ne.' '.and. + name(i)(12:13).eq.sname) go to 9 if(name(i)(5:10).eq.lname) go to 9 enddo return c c compute the value c 9 iptr(ii)=i ll=iend-imid if(name(i)(15:15).eq.'i') then call cint(list(imid+1),ll,ival(ii),jerr) if(jerr.ne.0) return else if(name(i)(15:15).eq.'r') then call creal(list(imid+1),ll,rval(ii),jerr) if(jerr.ne.0) return else if(name(i)(15:15).eq.'s') then sval(ii)=' ' do j=imid+1,iend k=j-imid sval(ii)(k:k)=list(j) enddo else if(name(i)(15:15).eq.'f') then sval(ii)=' ' do j=imid+1,iend k=j-imid sval(ii)(k:k)=list(j) enddo else if(list(iend).ne.dbleq) return if(list(imid+1).ne.dbleq) return sval(ii)=' ' do j=imid+2,iend-1 k=j-imid-1 sval(ii)(k:k)=list(j) enddo endif enddo c c update ip and rp arrays c do ii=1,nequal i=iptr(ii) call cint(name(i),3,indx,jerr) if(name(i)(15:15).eq.'i') then ip(indx)=ival(ii) else if(name(i)(15:15).eq.'r') then rp(indx)=rval(ii) else sp(indx)=sval(ii) endif enddo ierr=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine disply(name,num,ip,rp,sp) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + ip(*) double precision + rp(*) character*15 + name(*) character*80 + sp(*),sval(100),stemp character*100 + msg c c print reset paremeters c nn=0 do i=1,num call cint(name(i),3,indx,jerr) if(name(i)(15:15).eq.'i') then sval(i)=' ' call sint(sval(i),ll,ip(indx)) nn=nn+1 else if(name(i)(15:15).eq.'r') then sval(i)=' ' nn=nn+1 call sreal(sval(i),ll,rp(indx),3,0) else go to 10 endif enddo c 10 do i=1,nn,4 write(unit=msg,fmt='(4(a9,1x,a10))') + (name(j)(5:13),sval(j)(1:10), 1 j=i,min0(i+3,nn)) call crtutl(msg,'w',msg) enddo c do i=nn+1,num call cint(name(i),3,indx,jerr) if(name(i)(15:15).eq.'s') then call fstr(stemp,length,sp(indx),0) else if(name(i)(15:15).eq.'f') then call fstr(stemp,length,sp(indx),0) else call fstr(stemp,length,sp(indx),1) endif write(unit=msg,fmt='(a9,1x,80a1)') + name(i)(5:13),(stemp(k:k),k=1,length) call crtutl(msg,'w',msg) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine discmd(ncmd,ctable) c implicit double precision (a-h,o-z) implicit integer (i-n) character*15 + ctable(*) character*100 + msg c c print command list c if(ncmd.le.6) then nstep=ncmd else nstep=min0((ncmd+1)/2,6) endif do k=1,ncmd,nstep write(unit=msg,fmt='(6(a8,4x))') + (ctable(j)(1:8),j=k,min0(k+nstep-1,ncmd)) call crtutl(msg,'w',msg) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + lequal(*),lcomma(*) character*1 + list(*),blank,comma,equal,dbleq, 1 cc,uppera,upperz,commnt c save blank,comma,equal,dbleq,commnt data blank,comma,equal,dbleq,commnt/' ',',','=','"','#'/ c llist=80 length=0 ncomma=0 nequal=0 ndbleq=0 if(list(1).eq.commnt) then icomnt=1 do i=llist,1,-1 if(list(i).ne.blank) then length=i return endif enddo return else icomnt=0 endif uppera=char(65) upperz=char(90) c c delete blanks, find equal, commas, and double quotes c convert upper to lower case except for command code c do i=1,llist cc=list(i) list(i)=blank if(ndbleq-(ndbleq/2)*2.eq.0) then if(cc.ne.blank) then length=length+1 if(cc.eq.comma) then ncomma=ncomma+1 lcomma(ncomma)=length elseif(cc.eq.equal) then nequal=nequal+1 lequal(nequal)=length elseif(cc.eq.dbleq) then ndbleq=ndbleq+1 else if(cc.ge.uppera.and.cc.le.upperz) then ii=ichar(cc)+32 if(length.gt.1.and.nequal.eq.ncomma) + cc=char(ii) endif list(length)=cc endif else length=length+1 list(length)=cc if(cc.eq.dbleq) ndbleq=ndbleq+1 endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sreal(list,length,val,ndig,just) c implicit double precision (a-h,o-z) implicit integer (i-n) character*1 + list(*),zero,minus,ex(100),mant(100),e,dot integer elen,mlen,just save minus,zero,e,dot data minus,e,dot,zero/'-','e','.','0'/ c c compute character string for floating point number c if(val.eq.0.0d0) then length=3 list(1)=zero list(2)=dot list(3)=zero else zc=dabs(val) zz=dlog10(zc) iex=idint(zz) ratio=10.0d0**(zz-dfloat(iex)) c** ratio=zc*(10.0e0**(-iex)) if(iex.eq.-1) then h=0.5d0*10.0d0**(2-ndig) else h=0.5d0*10.0d0**(1-ndig) endif if(ratio+h.lt.1.0d0) then ratio=ratio*10.0d0 iex=iex-1 else if(ratio+h.ge.10.0d0) then ratio=ratio/10.0d0 iex=iex+1 endif c c exponent field c call sint(ex,elen,iex) c c mantissa field c if(iex.eq.-1) then n=idint(ratio*10.0d0**(ndig-2)+0.5d0) else n=idint(ratio*10.0d0**(ndig-1)+0.5d0) endif c if(just.ne.1) then 90 k=n/10 j=n-10*k if(j.eq.0) then n=k go to 90 endif endif call sint(mant,mlen,n) if(val.gt.0) then is=0 else is=1 list(1)=minus endif if(iex.eq.-1) then list(is+1)=zero list(is+2)=dot do i=1,mlen list(is+i+2)=mant(i) enddo mlen=mlen+1 iex=0 else if(iex.eq.1) then list(is+1)=mant(1) list(is+2)=zero list(is+3)=dot list(is+4)=zero if(mlen.le.2) then if(mlen.eq.2) list(is+2)=mant(2) mlen=3 else list(is+2)=mant(2) do i=3,mlen list(is+i+1)=mant(i) enddo endif iex=0 else list(is+1)=mant(1) list(is+2)=dot if(mlen.eq.1) then list(is+3)=zero mlen=mlen+1 else do i=2,mlen list(is+i+1)=mant(i) enddo endif endif if(iex.ne.0) then length=elen+mlen+2+is list(is+mlen+2)=e do i=1,elen list(is+mlen+2+i)=ex(i) enddo else length=mlen+1+is endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sint(list,length,ival) c implicit double precision (a-h,o-z) implicit integer (i-n) character*1 + list(*),num(10),minus integer temp(100) save minus,num data minus/'-'/ data num/'0','1','2','3','4','5','6','7','8','9'/ c c compute character string for integer c if(ival.eq.0) then length=1 list(1)=num(1) else length=0 n=iabs(ival) 10 j=n/10 i=n-j*10 length=length+1 temp(length)=i+1 n=j if(n.gt.0) go to 10 if(ival.lt.0) then list(1)=minus do i=1,length list(i+1)=num(temp(length+1-i)) enddo length=length+1 else do i=1,length list(i)=num(temp(length+1-i)) enddo endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine fstr(ss,length,sval,iquote) c implicit double precision (a-h,o-z) implicit integer (i-n) character*1 + blank,dbleq character*80 + ss,sval save blank,dbleq,mxchar data blank,dbleq,mxchar/' ','"',80/ c istart=mxchar+1 istop=0 ss=' ' do i=1,mxchar if(sval(i:i).ne.blank) then istart=min0(istart,i) istop=max0(istop,i) endif enddo if(iquote.eq.1) then ss(1:1)=dbleq if(istart.gt.istop) then length=3 else length=istop-istart+3 if(length.gt.mxchar) then istop=istop-(length-mxchar) length=mxchar endif ss(2:length-1)=sval(istart:istop) endif ss(length:length)=dbleq else if(istart.gt.istop) then length=1 else length=istop-istart+1 ss(1:length)=sval(istart:istop) endif endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkname(outnam,innam) c implicit double precision (a-h,o-z) implicit integer (i-n) character*80 + innam,outnam,temp common /atest6/nproc,myid,mpisw save num data num/0/ c c look for key string and insert number c num=num+1 cccc if(mpisw.eq.1) call exnum(num) call fstr(outnam,length,innam,0) do i=6,length if(outnam(i-5:i).eq.'figxxx') then outnam(i-2:i)='000' call sint(temp,len,num) outnam(i+1-len:i)=temp(1:len) return endif enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine creal(list,length,val,ierr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + zero character*1 + list(*),dot,lce,uce,blank,temp(80),cc,plus,minus, 1 lcd,ucd save dot,lce,blank,plus,minus,lcd data dot,lce,lcd,blank,plus,minus/'.','e','d',' ','+','-'/ c c compute a real number from a-format input c ii=ichar(lce)-32 uce=char(ii) ii=ichar(lcd)-32 ucd=char(ii) val=0.0d0 ierr=1 newlen=0 idot=length+1 iee=length+1 do i=1,length cc=list(i) list(i)=blank if(cc.ne.blank) then newlen=newlen+1 temp(newlen)=cc list(newlen)=cc if(temp(newlen).eq.lce) iee=newlen if(temp(newlen).eq.uce) iee=newlen if(temp(newlen).eq.lcd) iee=newlen if(temp(newlen).eq.ucd) iee=newlen if(temp(newlen).eq.dot) idot=newlen endif enddo if(newlen.eq.0) return c c exponent c if(iee.le.newlen) then if(iee.eq.1.or.iee.eq.newlen) return ll=newlen-iee call cint(temp(iee+1),ll,ix,jerr) if(jerr.ne.0) return newlen=iee-1 else ix=0 endif c c mantissa c if(idot.le.newlen) then if(newlen.eq.1) return ix=ix+idot-newlen newlen=newlen-1 if(idot.le.newlen) then do i=idot,newlen temp(i)=temp(i+1) enddo endif endif c c sign c if(temp(1).eq.minus.or.temp(1).eq.plus) then if(newlen.eq.1) return ii=2 else ii=1 endif c zero=ichar('0') value=0.0d0 do i=ii,newlen kx=ichar(temp(i))-zero if(kx.lt.0.or.kx.gt.9) return value=10.0d0*value+dfloat(kx) enddo if(temp(1).eq.minus) then val=-value*(10.0d0**ix) else val=value*(10.0d0**ix) endif ierr=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cint(list,length,ival,ierr) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + zero character*1 + list(*),blank,plus,minus,temp(80),cc save plus,minus,blank data plus,minus,blank/'+','-',' '/ c c compute an integer from a-format input c ierr=1 ival=0 newlen=0 do i=1,length cc=list(i) list(i)=blank if(cc.ne.blank) then newlen=newlen+1 temp(newlen)=cc list(newlen)=cc endif enddo if(newlen.eq.0) return c c sign c if(temp(1).eq.minus.or.temp(1).eq.plus) then if(newlen.eq.1) return ii=2 else ii=1 endif c c zero=ichar('0') do i=ii,newlen ix=ichar(temp(i))-zero if(ix.lt.0.or.ix.gt.9) return ival=10*ival+ix enddo if(temp(1).eq.minus) ival=-ival ierr=0 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine cpause() c implicit double precision (a-h,o-z) implicit integer (i-n) character*80 + cc common /atest3/mode,jnlsw,jnlr,jnlw,ibatch c c wait for user to view picture c if(mode.eq.0.and.jnlsw.eq.1) then call xpause() else if(mode.eq.-1.and.jnlsw.eq.1) then call crtutl(cc,'r','pause:') endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine crtutl(list,mode,prompt) c implicit double precision (a-h,o-z) implicit integer (i-n) character*1 + mode character*8 + prompt character*80 + list data icrtr,icrtw/5,6/ save icrtr,icrtw c c print a prompt symbol c if(mode.eq.'r') then write(icrtw,fmt='(/ a8 $)') prompt read(icrtr,fmt='(a80)') list else if(mode.eq.'w') then write(icrtw,fmt='(a80)') list endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine filutl(list,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) character*1 + lowerj character*80 + list,blank character*100 + msg common /atest3/mode,jnlsw,jnlr,jnlw,ibatch save blank,lowerj data blank,lowerj/' ','j'/ c if(isw.eq.1) then if(list(1:1).eq.lowerj) then write(unit=msg,fmt='(a1,a80)') '#',list else write(unit=msg,fmt='(a80)') list endif len=1 do i=2,80 if(msg(i:i).ne.' ') len=i enddo call ascstr(jnlw,msg,len,iflag) write(unit=msg,fmt='(a8,a80)') 'command:',list c call ascstr(ibatch,blank,1,iflag) call ascstr(ibatch,msg,80,iflag) c if(mode.eq.0) then call xtext(blank) call xtext(msg) endif c if(mode.eq.-1.and.jnlsw.eq.1) then call crtutl(blank,'w',blank) call crtutl(msg,'w',blank) endif else call ascstr(ibatch,list,80,iflag) if(mode.eq.0) call xtext(list) if(mode.eq.-1) call crtutl(list,'w',blank) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine mkjnl(sp,iflag) c implicit double precision (a-h,o-z) implicit integer (i-n) integer + jnlr(11),lequal(24),lcomma(24) character*1 + lowerj,upperj character*80 + sp(100),name(11),list,filnam save maxd data maxd/10/ c c make journal file c lowerj=char(106) upperj=char(74) do i=1,maxd name(i)=' ' jnlr(i)=-1 enddo if(sp(10).eq.' ') then sp(11)='journl: bad filename' go to 50 endif call stfile(filnam,sp(10)) call ascutl(jnlr(maxd+1),filnam,'w',kflag) if(kflag.ne.0) then sp(11)='journl: cannot open file' go to 50 endif iflag=0 sp(11)='journl: ok' level=1 name(1)=sp(7) c c open file c 10 if(name(level).eq.' ') then sp(11)='journl: bad filename' go to 50 endif if(level.ge.maxd) then sp(11)='journl: too many levels' go to 50 endif do i=1,level-1 if(name(level).eq.name(i)) then sp(11)='journl: bad filename' go to 50 endif enddo call stfile(filnam,name(level)) call ascutl(jnlr(level),filnam,'r',kflag) if(kflag.ne.0) then sp(11)='journl: cannot open file' go to 50 endif c c read next command c 20 call ascstr(jnlr(level),list,80,kflag) if(kflag.gt.0) then sp(11)='journl: read error' go to 50 endif if(kflag.eq.-1) then c c close current file, reduce level c call ascutl(jnlr(level),filnam,'c',jflag) if(jflag.ne.0) then sp(11)='journl: cannot close file' return endif jnlr(level)=-1 level=level-1 if(level.ge.1) go to 20 call ascutl(jnlr(maxd+1),filnam,'c',jflag) return endif c c process this command c call fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(length.le.0) then go to 20 c c check for journal commands c else if(list(1:1).eq.lowerj.or.list(1:1).eq.upperj) then if(ncomma.gt.0.or.ndbleq.gt.0.or.nequal.ge.2) then sp(11)='journl: command error' go to 50 endif if(nequal.eq.1) then ll=length-lequal(1) name(level+1)=' ' name(level+1)(1:ll)=list(lequal(1)+1:length) endif if(list(1:1).eq.lowerj) then level=level+1 go to 10 else go to 20 endif else c c print this command c call ascstr(jnlr(maxd+1),list,length,kflag) if(kflag.gt.0) then sp(11)='journl: write error' go to 50 endif go to 20 endif c c close all open files c 50 do i=1,maxd+1 if(jnlr(i).ne.-1) then call ascutl(jnlr(i),filnam,'c',kflag) endif enddo iflag=29 return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine stfile(outnam,innam) c implicit double precision (a-h,o-z) implicit integer (i-n) character*80 + innam,outnam,temp common /atest6/nproc,myid,mpisw c c look for key strng and replace with proc number c call fstr(outnam,length,innam,0) do i=6,length if(outnam(i-5:i).eq.'mpixxx') then outnam(i-2:i)='000' call sint(temp,len,myid+1) outnam(i+1-len:i)=temp(1:len) return endif enddo return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pltutl(ncolor,red,green,blue) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + red(*),green(*),blue(*) character*80 + fname,fname0,sp common /atest1/ip(100),rp(100),sp(100) common /atest5/idevce common /atest6/nproc,myid,mpisw c c ncolor .gt. 0 -- initialize graphics using ncolor colors c ncolor .le. 0 -- exit graphics c c socket graphics c if(idevce.ge.0.and.idevce.le.3) then isock=idevce call fstr(fname,length,sp(21),0) call vutl(ncolor,red,green,blue,isock,fname) if(ncolor.lt.0) call cpause() c c bh file c else if(idevce.eq.4) then if(ncolor.gt.0) then call mkname(fname0,sp(20)) call stfile(fname,fname0) endif call vutl(ncolor,red,green,blue,-1,fname) c c postscript file c else if(idevce.eq.5) then if(ncolor.gt.0) then call mkname(fname0,sp(18)) call stfile(fname,fname0) endif call psutl(ncolor,red,green,blue,fname) c c xpm file c else if(idevce.eq.6) then if(ncolor.gt.0) then call mkname(fname0,sp(19)) call stfile(fname,fname0) endif call xpmutl(ncolor,red,green,blue,fname) c c classic x graphics c else if(idevce.ge.7.and.idevce.le.10) then isock=idevce-7 call xutl(ncolor,red,green,blue,isock) if(ncolor.lt.0) call cpause() endif return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pframe(iframe) c implicit double precision (a-h,o-z) implicit integer (i-n) common /atest5/idevce c c frame/list equivalence table c ___ ___ ___ ___ ___ ___ c | | | | | c | | 2 | | | c | 4 |___| | 1 | c | | | | | c | | 3 | | | c |___ ___|___| |___ ___ ___| c c list frame type c c 1 1 non-rotating, non-lighted c c 2 2 non-rotating, non-lighted c c 3 3 non-rotating, non-lighted c c 4 4 non-rotating, non-lighted c 5 4 rotating, non-lighted c 6 4 rotating, non-lighted c 7 4 rotating, lighted c 8 4 rotating, lighted c 9 4 non-rotating, lighted c c if(idevce.ge.0.and.idevce.le.4) then call vframe(iframe) else if(idevce.eq.5) then call sframe(iframe) else if(idevce.ge.6.and.idevce.le.10) then call xframe(iframe) endif return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pline(x,y,z,n,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*) common /atest5/idevce c c subroutine pline moves the pen (or whatever) c to the point (x(1),y(1)), and then draws the c n-1 line segments (x(i-1),y(i-1)) to (x(i),y(i)), c i=2,3,....n. c if(idevce.ge.0.and.idevce.le.4) then call vline(x,y,z,n,icolor) else if(idevce.eq.5) then call pspath(x,y,z,n,icolor,0) else if(idevce.ge.6.and.idevce.le.10) then call xline(x,y,z,n,icolor) endif return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pfill(x,y,z,n,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*) common /atest5/idevce c c subroutine pfill fills the n-sided polygon with c vertices (x(i),y(i)) with the indicated color c if(idevce.ge.0.and.idevce.le.4) then call vfill(x,y,z,n,icolor) else if(idevce.eq.5) then call pspath(x,y,z,n,icolor,1) else if(idevce.ge.6.and.idevce.le.10) then call xfill(x,y,z,n,icolor) endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine psutl(ncolor,red,green,blue,fname) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + red(*),green(*),blue(*) character*1 + hex(16) character*80 + msg,fname,sname common /ps0/id,scale,fscale,xshift,yshift c save hex,sname,length data hex/'0','1','2','3','4','5','6','7','8','9', + 'a','b','c','d','e','f'/ c c postscript graphics implementation for pltutl c this version is based on suggestions of klas samuelsson for c reducing the size of the postscript files c c print picture c if(ncolor.le.0) then call ascstr(id,'showpage',8,iflag) call ascutl(id,sname,'c',iflag) return endif c c ipl = 1 (0) is portrait (landscape) mode c center in 8.5 x 11 inch paper c picture is 8 (10.5) inches wide in portrait (landscape) c note there are 72 points per inch c ipl=1 c c scale factor is 5.e3 (about 4 digits of resolution) c scale=5.0d3 fscale=1.0d0 xshift=0.0d0 yshift=0.0d0 c call fstr(sname,length,fname,0) call ascutl(id,sname,'w',iflag) c c set main definitions c call ascstr(id,'%!',2,iflag) c if(ipl.eq.1) then c*** call ascstr(id,'%%BoundingBox: 18 204 402 588',29,iflag) call ascstr(id,'%%BoundingBox: 18 204 594 588',29,iflag) call ascstr(id,'[384 0 0 384 18 204] concat',27,iflag) else call ascstr(id,'%%BoundingBox: 54 18 558 774',28,iflag) call ascstr(id,'[0 504 -504 0 558 18] concat',28,iflag) endif c si=1.0d0/scale write(unit=msg,fmt='(2(f8.6,1x),a5)') si,si,'scale' call ascstr(id,msg,23,iflag) c call ascstr(id,'1 setlinewidth',14,iflag) call ascstr(id,'2 setlinejoin',13,iflag) call ascstr(id,'/s {setrgbcolor newpath moveto} def',35,iflag) call ascstr(id,'/r {count 2 idiv {rlineto} repeat} def', + 38,iflag) call ascstr(id,'/f {s r closepath fill} def',27,iflag) call ascstr(id,'/g {s r stroke} def',19,iflag) c c define colors c do i=1,ncolor i1=(i-1)/16 i0=i-1-i1*16 c write(unit=msg,fmt='(a2,a1,a1,a2,3(f4.2,1x),a6)') + '/b',hex(i1+1),hex(i0+1),' {', 1 red(i),green(i),blue(i),'g} def' call ascstr(id,msg,27,iflag) c write(unit=msg,fmt='(a2,a1,a1,a2,3(f4.2,1x),a6)') + '/c',hex(i1+1),hex(i0+1),' {', 1 red(i),green(i),blue(i),'f} def' call ascstr(id,msg,27,iflag) c enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine sframe(iframe) c implicit double precision (a-h,o-z) implicit integer (i-n) character*80 + msg common /ps0/id,scale,fscale,xshift,yshift c write(unit=msg,fmt='(a3,i3)') '%%l',iframe call ascstr(id,msg,6,iflag) c if(iframe.eq.2) then fscale=scale/2.0d0 xshift=scale yshift=scale/2.0d0 else if(iframe.eq.3) then fscale=scale/2.0d0 xshift=scale yshift=0.0d0 else fscale=scale xshift=0.0d0 yshift=0.0d0 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine pspath(x,y,z,n,icolor,itype) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*) character*1 + list(100),hex(16) common /ps0/id,scale,fscale,xshift,yshift save hex data hex/'0','1','2','3','4','5','6','7','8','9', + 'a','b','c','d','e','f'/ c c print a path in compact integer form c c look for first nontrivial entry c c*** if(scale.ne.fscale) return length=0 npts=0 do i=n-1,1,-1 ix=idnint((x(i+1)-x(i))*fscale) iy=idnint((y(i+1)-y(i))*fscale) if(ix.ne.0.or.iy.ne.0) then npts=npts+1 call sint(list(length+1),lenx,ix) length=length+lenx+1 list(length)=' ' call sint(list(length+1),leny,iy) length=length+leny+1 list(length)=' ' c if(length.gt.60) then call ascstr(id,list,length-1,iflag) length=0 endif endif enddo c c first point c if(npts.eq.0) return ix=idnint(x(1)*fscale+xshift) iy=idnint(y(1)*fscale+yshift) call sint(list(length+1),lenx,ix) length=length+lenx+1 list(length)=' ' call sint(list(length+1),leny,iy) length=length+leny+1 list(length)=' ' c c set color, and line/fill c if(itype.eq.1) then list(length+1)='c' else list(length+1)='b' endif i1=(icolor-1)/16 i0=icolor-1-i1*16 list(length+2)=hex(i1+1) list(length+3)=hex(i0+1) length=length+3 call ascstr(id,list,length,iflag) c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xutl(ncolor,red,green,blue,id) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + red(*),green(*),blue(*) common /xpm0/iscale,ishift,image(540000) common /xpm1/scale,fscale,xshift,yshift save nx,ny c c xwindows graphics implementation for pltutl c if(ncolor.le.0) then call xgdisp(nx,ny,ishift,image) return endif c c initialize bitmap c do i=1,ncolor image(3*i-2)=idint(red(i)*65535.0d0) image(3*i-1)=idint(green(i)*65535.0d0) image(3*i)=idint(blue(i)*65535.0d0) enddo call xginit(ncolor,image,id,ix,iy) ny=min0(600,iy) nx=ny*3/2 scale=dfloat(ny) iscale=nx ishift=512 do k=1,nx*ny image(k)=0 enddo c return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xpmutl(ncolor,red,green,blue,fname) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + red(*),green(*),blue(*) character*1 + cdef(92) character*2 + cmap(256),cs character*80 + fname,sname character*2000 + msg common /xpm0/iscale,ishift,image(540000) common /xpm1/scale,fscale,xshift,yshift c save sname,length,cdef,nc,nx,ny,lenc,cmap,id data (cdef(i),i=1,92)/ + ' ','.','X','o','O','+','@','#','$','%', 1 '&','*','=','-',';',':','>',',','<','1', 2 '2','3','4','5','6','7','8','9','0','q', 3 'w','e','r','t','y','u','i','p','a','s', 4 'd','f','g','h','j','k','l','z','x','c', 5 'v','b','n','m','M','N','B','V','C','Z', 6 'A','S','D','F','G','H','J','K','L','P', 7 'I','U','Y','T','R','E','W','Q','!','~', 8 '^','/','(',')','_','`','|',']','[','{', 9 '}','|'/ c c xpm graphics implementation for pltutl c if(ncolor.le.0) go to 10 c ny=400 nx=ny*3/2 c*** nx=ny scale=dfloat(ny) iscale=nx ishift=512 nc=1 lenc=91 if(ncolor.gt.lenc) nc=2 c c initialize bitmap c do k=1,nx*ny image(k)=0 enddo c call fstr(sname,length,fname,0) call ascutl(id,sname,'w',iflag) c c set main definitions c call ascstr(id,'/* XPM */',9,iflag) msg(1:14)='static char * ' if(sname(length-3:length).eq.'.xpm') then msg(15:10+length)=sname(1:length-4) ll=10+length else msg(15:14+length)=sname(1:length) ll=14+length endif msg(ll+1:ll+10)='_xpm[] = {' call ascstr(id,msg,ll+10,iflag) c write(unit=msg,fmt='(a1,i4,1x,i4,1x,i3,1x,i1,a2)') + '"',nx,ny,ncolor,nc,'",' call ascstr(id,msg,18,iflag) c c define colors c do i=1,ncolor msg='" c #ffffffffffff",' i2=(i-1)/lenc i1=i-1-lenc*i2 cs(1:1)=cdef(i1+1) cs(2:2)=cdef(i2+1) msg(2:3)=cs cmap(i)=cs call hexclr(red(i),green(i),blue(i),msg(12:12)) call ascstr(id,msg,25,iflag) enddo return c c print bitmap c 10 do j=ny,1,-1 msg(1:1)='"' if(nc.eq.1) then do i=1,nx idx=i+(j-1)*iscale ic=image(idx)-(image(idx)/ishift)*ishift+1 msg(i+1:i+2)=cmap(ic) enddo else do i=1,nx idx=i+(j-1)*iscale ic=image(idx)-(image(idx)/ishift)*ishift+1 msg(2*i:2*i+1)=cmap(ic) enddo endif if(j.ne.1) then msg(nc*nx+2:nc*nx+3)='",' call ascstr(id,msg,nc*nx+3,iflag) else msg(nc*nx+2:nc*nx+2)='"' call ascstr(id,msg,nc*nx+2,iflag) endif enddo msg(1:2)='};' call ascstr(id,msg,2,iflag) call ascutl(id,sname,'c',iflag) return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine hexclr(r,g,b,color) c implicit double precision (a-h,o-z) implicit integer (i-n) c integer + ic(3) character*1 + color(12),hex(16) save hex data hex/'0','1','2','3','4','5','6','7','8','9', + 'a','b','c','d','e','f'/ c c translate (r,g,b) colors to hexidecimal c ic(1)=idint(r*65535.0d0) ic(2)=idint(g*65535.0d0) ic(3)=idint(b*65535.0d0) do i=1,3 jj=max0(0,ic(i)) jj=min0(65535,jj) do j=1,4 kk=jj/16 ii=jj-kk*16 color(4*i+1-j)=hex(ii+1) jj=kk enddo enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xframe(iframe) c implicit double precision (a-h,o-z) implicit integer (i-n) common /xpm1/scale,fscale,xshift,yshift c c if(iframe.eq.2) then fscale=scale/2.0d0 xshift=scale yshift=scale/2.0d0 else if(iframe.eq.3) then fscale=scale/2.0d0 xshift=scale yshift=0.0d0 else fscale=scale xshift=0.0d0 yshift=0.0d0 endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xline(x,y,z,n,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*) common /xpm1/scale,fscale,xshift,yshift c c pline for xpm graphics c c*** if(scale.ne.fscale) return zshift=fscale*0.01d0 ix=idint(x(1)*fscale+xshift+0.5d0) iy=idint(y(1)*fscale+yshift+0.5d0) iz=idint(z(1)*fscale+zshift+0.5d0) do i=2,n jx=ix jy=iy jz=iz ix=idint(x(i)*fscale+xshift+0.5d0) iy=idint(y(i)*fscale+yshift+0.5d0) iz=idint(z(i)*fscale+zshift+0.5d0) call iline(ix,iy,iz,jx,jy,jz,icolor) enddo return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine iline(ix,iy,iz,jx,jy,jz,ic) c implicit double precision (a-h,o-z) implicit integer (i-n) common /xpm0/iscale,ishift,image(540000) c c update bitmap for a line segment c if(ix.ne.jx) then kmin=min0(ix,jx) kmax=max0(ix,jx) do k=kmin,kmax x=dfloat((k-ix)*jx+(jx-k)*ix)/dfloat(jx-ix) y=dfloat((k-ix)*jy+(jx-k)*iy)/dfloat(jx-ix) z=dfloat((k-ix)*jz+(jx-k)*iz)/dfloat(jx-ix) kx=idint(x+0.5d0) ky=idint(y+0.5d0) kz=idint(z+0.5d0) idx=kx+(ky-1)*iscale if(kz.ge.image(idx)/ishift) image(idx)=kz*ishift+ic-1 enddo endif if(iy.ne.jy) then kmin=min0(iy,jy) kmax=max0(iy,jy) do k=kmin,kmax x=dfloat((k-iy)*jx+(jy-k)*ix)/dfloat(jy-iy) y=dfloat((k-iy)*jy+(jy-k)*iy)/dfloat(jy-iy) z=dfloat((k-iy)*jz+(jy-k)*iz)/dfloat(jy-iy) kx=idint(x+0.5d0) ky=idint(y+0.5d0) kz=idint(z+0.5d0) idx=kx+(ky-1)*iscale if(kz.ge.image(idx)/ishift) image(idx)=kz*ishift+ic-1 enddo endif return end c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine xfill(x,y,z,n,icolor) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + x(*),y(*),z(*),rm(200),rz(200) common /xpm1/scale,fscale,xshift,yshift c c pfill for xpm graphics c c*** if(scale.ne.fscale) return ixmin=idint(x(1)*fscale+xshift+0.5d0) ixmax=ixmin iymin=idint(y(1)*fscale+yshift+0.5d0) iymax=iymin do i=2,n ix=idint(x(i)*fscale+xshift+0.5d0) iy=idint(y(i)*fscale+yshift+0.5d0) ixmin=min0(ixmin,ix) ixmax=max0(ixmax,ix) iymin=min0(iymin,iy) iymax=max0(iymax,iy) enddo if(ixmax-ixmin.lt.iymax-iymin) then c c scan by row index c do k=ixmin,ixmax c c find intersections c xx=(dfloat(k)-xshift)/fscale np=0 nm=0 num=0 j=n do i=1,n if(x(i).gt.xx.and.x(j).le.xx) then np=np+1 else if(x(i).le.xx.and.x(j).gt.xx) then nm=nm+1 else go to 5 endif num=num+1 rm(num)=((xx-x(j))*y(i)+(x(i)-xx)*y(j))/(x(i)-x(j)) rz(num)=((xx-x(j))*z(i)+(x(i)-xx)*z(j))/(x(i)-x(j)) do m=num-1,1,-1 if(rm(m).lt.rm(m+1)) go to 5 rr=rm(m) rm(m)=rm(m+1) rm(m+1)=rr rr=rz(m) rz(m)=rz(m+1) rz(m+1)=rr enddo 5 j=i enddo if(nm.ne.np) stop 6123 c c update bitmap along line k c do j=1,num,2 iy=idint(rm(j )*fscale+yshift+0.5d0) iz=idint(rz(j )*fscale +0.5d0) jy=idint(rm(j+1)*fscale+yshift+0.5d0) jz=idint(rz(j+1)*fscale +0.5d0) call iline(k,iy,iz,k,jy,jz,icolor) enddo enddo else c c scan by column index c do k=iymin,iymax c c find intersections c yy=(dfloat(k)-yshift)/fscale np=0 nm=0 num=0 j=n do i=1,n if(y(i).gt.yy.and.y(j).le.yy) then np=np+1 else if(y(i).le.yy.and.y(j).gt.yy) then nm=nm+1 else go to 10 endif num=num+1 rm(num)=((yy-y(j))*x(i)+(y(i)-yy)*x(j))/(y(i)-y(j)) rz(num)=((yy-y(j))*z(i)+(y(i)-yy)*z(j))/(y(i)-y(j)) do m=num-1,1,-1 if(rm(m).lt.rm(m+1)) go to 10 rr=rm(m) rm(m)=rm(m+1) rm(m+1)=rr rr=rz(m) rz(m)=rz(m+1) rz(m+1)=rr enddo 10 j=i enddo if(nm.ne.np) stop 6124 c c update bitmap along line k c do j=1,num,2 ix=idint(rm(j )*fscale+xshift+0.5d0) iz=idint(rz(j )*fscale +0.5d0) jx=idint(rm(j+1)*fscale+xshift+0.5d0) jz=idint(rz(j+1)*fscale +0.5d0) call iline(ix,k,iz,jx,k,jz,icolor) enddo enddo endif c c trace boundary c ix=idint(x(n)*fscale+xshift+0.5d0) iy=idint(y(n)*fscale+yshift+0.5d0) iz=idint(z(n)*fscale +0.5d0) do i=1,n jx=ix jy=iy jz=iz ix=idint(x(i)*fscale+xshift+0.5d0) iy=idint(y(i)*fscale+yshift+0.5d0) iz=idint(z(i)*fscale +0.5d0) call iline(ix,iy,iz,jx,jy,jz,icolor) enddo return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise linear triangle multi grid package c c edition 9.0 - - - march, 2004 c c----------------------------------------------------------------------- subroutine timer(time,isw) c implicit double precision (a-h,o-z) implicit integer (i-n) double precision + time(3,*) real temp(2),etime save tx,len data tx/0.0d0/ data len/50/ c c call the clock and return the time in seconds c (time differences are used to compute the elapsed time) c ty=tx tx=etime(temp) c c udpate time array (1.0e-10 is below resolution of timer) c if(isw.gt.0) then dt=dmax1(tx-ty,1.0d-10) time(1,isw)=time(1,isw)+dt time(2,isw)=time(2,isw)+dt else if(isw.eq.-1) then do i=1,len time(1,i)=0.0d0 enddo else if(isw.eq.-2) then do i=1,len time(1,i)=0.0d0 time(2,i)=0.0d0 time(3,i)=0.0d0 enddo endif return end