c***************************** file: mg1.f ***************************** c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 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 real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),ja(*) real + vx(*),vy(*),xm(*),ym(*),w(*),rp(100),a(*) character*80 + sp(100) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy c c user specified ip variables c if(ip(6).lt.0.or.ip(6).gt.3) ip(6)=1 if(ip(7).lt.-5.or.ip(7).gt.6) ip(7)=1 if(ip(12).ne.1) ip(12)=0 if(ip(8).ne.1) ip(8)=0 ip(10)=max0(1,ip(10)) ip(11)=max0(1,ip(11)) rp(3)=amax1(rp(3),0.0e0) ip(25)=0 if(ip(6).ne.0) ip(24)=0 c c storage allocation c if(ip(6).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(90) itdof=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 ntf=ip(1) nvf=ip(2) nbf=ip(4) ispd=ip(8) iprob=ip(7) itask=ip(9) iord=ip(26) ndof=(iord+1)*(iord+2)/2 lenw=ip(82) mpisw=ip(48) nproc=ip(49) irgn=ip(50) ndf=ip(5) maxd=ip(89) ibegin=iz iend=lenw c c check for mpi status c if(iprob.lt.0) then if(mpisw.ne.1) then ip(25)=48 go to 20 endif call exflag(ip(24)) if(ip(24).ne.0) then ip(25)=24 go to 20 endif endif c if(ip(6).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 rp(21)=rp(1) rp(31)=rp(1) rp(33)=1.0e0 rp(45)=0.0e0 rp(53)=1.0e0 rp(59)=0.0e0 rp(60)=0.0e0 rp(64)=1.0e-3 if(ip(7).eq.3.and.ip(9).lt.3) ip(9)=3 if(ip(7).eq.4) ip(9)=8 ip(6)=0 ip(70)=0 c c setup itdof c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(iequv,nvf,'head',ibegin,iend,iflag) call memptr(itedge,3*ntf,'head',ibegin,iend,iflag) call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) ll=3*ntf+nbf+nvf call memptr(mark,ll,'head',ibegin,iend,iflag) call mkdof(ip,itnode,ibndry,w(itedge),w(ibedge), + w(iequv),w(mark),ndof,w(itdof)) call memptr(isv,0,'free',ibegin,iend,iflag) c ndf=ip(5) maxd=ip(89) c call gfinit(ip,maxd,w(iuu),w(iee)) else call timer(w(jtime),-1) endif c call gfptr(iprob,itask,maxd,iuu,iu0,iudot,iu0dot, + ievr,ievl,ivx0,ivy0,ium,iuc,ngf,nef) c call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) c ndd=max0(0,ip(33)) nvdd=max0(0,ip(71)) jbegin=ibegin call lsptr(iprob,ispd,iord,ndf,ndd,nvdd,jbegin,jend, + ihh,isu,ism,ia0,ih0,ig0,isu0,ism0,ibb,idd, 1 ird,ipp,idl,ibdlwr,ibdupr,idu,idum,iduc) ll=jend-jbegin call memptr(ils,ll,'head',ibegin,iend,iflag) if(iprob.lt.0) then maxja0=9*iord*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) endif c maxn=2*ndf nvdd=0 if(iprob.lt.0) nvdd=ip(71) if(ispd.eq.1) then ii=max0(13*ndf,7*ndf+2*maxn,12*ndf+nvdd) else ii=max0(13*ndf,12*ndf+2*maxn,12*ndf+nvdd) endif if(iabs(iprob).eq.4) then ii=max0(ii,6*ndf+10*nvdd) else if(iabs(iprob).eq.5) then ii=max0(ii,6*ndf+22*nvdd,20*ndf) else ii=max0(ii,6*ndf+4*nvdd) endif call memptr(izz,ii,'head',ibegin,iend,iflag) maxja=ip(87) if(maxja.lt.10*ndf) iflag=82 maxa=ip(88) if(iabs(iprob).eq.5) then if(ispd.eq.1) then maxa=maxa/2 else maxa=2*maxa/3 endif igg=maxa+1 else igg=1 endif if(ispd.eq.1) then if(maxa.lt.8*ndf) iflag=82 else if(maxa.lt.14*ndf) iflag=82 endif if(iprob.lt.0) call exflag(iflag) if(iflag.ne.0) then ip(25)=82 go to 20 endif c c call cedge3(nvf,ntf,nbf,itnode,ibndry,w(ibedge), + w(izz),iflag) if(iprob.lt.0) call exflag(iflag) if(iflag.ne.0) then ip(25)=iflag go to 20 endif c c continuation options c if(iprob.eq.3) then c call pltmgc(ip,rp,vx,vy,xm,ym,itnode,ibndry,w(ibedge), + w(iuu),w(iu0),w(iudot),w(iu0dot),w(ievr), 1 w(ievl),w(ium),w(iuc),w(ivx0),w(ivy0),ndof,w(itdof), 2 w(ka),ja,a,w(ihh),a(igg),w(isu),w(ism),w(ibb),w(idd), 3 w(ird),w(ipp),w(idl),w(ibdlwr),w(ibdupr),w(idu), 4 w(idum),w(iduc),w(jtime),w(jhist),w(jpath),w(izz), 5 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c c time dependent options c else if(iprob.eq.6) then call pltmgp(ip,rp,vx,vy,xm,ym,itnode,ibndry,w(ibedge), + w(iuu),w(iu0),w(iudot),w(iu0dot),w(ievr), 1 w(ievl),w(ium),w(iuc),w(ivx0),w(ivy0),ndof,w(itdof), 2 w(ka),ja,a,w(ihh),a(igg),w(isu),w(ism),w(ibb),w(idd), 3 w(ird),w(ipp),w(idl),w(ibdlwr),w(ibdupr),w(idu), 4 w(idum),w(iduc),w(jtime),w(jhist),w(jpath),w(izz), 5 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,vx,vy,xm,ym,itnode,ibndry,w(ibedge), + w(iuu),w(iu0),w(iudot),w(iu0dot),w(ievr), 1 w(ievl),w(ium),w(iuc),w(ivx0),w(ivy0),ndof,w(itdof), 2 w(ka),ja,a,w(ihh),a(igg),w(isu),w(ism),w(ibb),w(idd), 3 w(ird),w(ipp),w(idl),w(ibdlwr),w(ibdupr),w(idu), 4 w(idum),w(iduc),w(jtime),w(jhist),w(jpath),w(izz), 5 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,vx,vy,xm,ym,itnode,ibndry,w(ibedge), + w(iuu),w(iu0),w(iudot),w(iu0dot),w(ievr), 1 w(ievl),w(ium),w(iuc),w(ivx0),w(ivy0),ndof,w(itdof), 2 w(ka),ja,a,w(ihh),a(igg),w(isu),w(ism),w(ibb),w(idd), 3 w(ird),w(ipp),w(idl),w(ibdlwr),w(ibdupr),w(idu), 4 w(idum),w(iduc),w(jtime),w(jhist),w(jpath),w(izz), 5 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c c domain decomposition solve c else if(iprob.lt.0) then call pltmgd(ip,rp,vx,vy,xm,ym,itnode,ibndry,w(ibedge), + w(iuu),w(iu0),w(iudot),w(iu0dot),w(ievr), 1 w(ievl),w(ium),w(iuc),w(ivx0),w(ivy0),ndof,w(itdof), 2 w(ka),ja,a,w(ihh),a(igg),w(isu),w(ism),w(ibb),w(idd), 3 w(ird),w(ipp),w(idl),w(ibdlwr),w(ibdupr),w(idu), 4 w(idum),w(iduc),w(ipath),w(jeq),w(ja0),w(ia0),w(ih0), 5 w(ig0),w(isu0),w(ism0),nvdd,w(iudd),w(jtime),w(jhist), 6 w(jpath),w(izz),a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) else ip(25)=7 endif c call timer(w(jtime),33) c 20 iflag=ip(25) c c successful return c if(iflag.eq.0) then if(ip(7).lt.0) then write(unit=sp(11),fmt='(a17,i2,a8,i2,a6,i8,a1)') + 'pltmg: ok (iprob=',ip(7),', itask=',ip(9), 1 ', ndg=',ip(40),')' else write(unit=sp(11),fmt='(a17,i2,a8,i2,a6,i6,a1)') + 'pltmg: ok (iprob=',ip(7),', itask=',ip(9), 1 ', ndf=',ip(5),')' endif c c insufficient storage errors, wrong input data structure c else if(iflag.ge.82.and.iflag.le.89) then write(unit=sp(11),fmt='(a11,i3,a22)') + 'pltmg error',iflag,': insufficient storage' if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.25) then write(unit=sp(11),fmt='(a11,i3,a28)') + 'pltmg error',iflag,': wrong input data structure' c c convergence errors c else if(iflag.eq.1) then write(unit=sp(11),fmt='(a11,i2,a29)') + 'pltmg error',iflag,': zero pivot in factorization' if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.2) then write(unit=sp(11),fmt='(a11,i2,a27)') + 'pltmg error',iflag,': newton line search failed' if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.7) then write(unit=sp(11),fmt='(a11,i2,a22)') + 'pltmg error',iflag,': illegal problem type' else if(iflag.eq.9) then write(unit=sp(11),fmt='(a11,i2,a31)') + 'pltmg error',iflag,': continuation procedure failed' else if(iflag.eq.10) then write(unit=sp(11),fmt='(a11,i3,a29)') + 'pltmg error',iflag,': multigraph iteration failed' if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.11) then if(ip(7).lt.0) then write(unit=sp(11),fmt='(a11,i3,a28)') + 'pltmg error',iflag,': newton/dd iteration failed' else write(unit=sp(11),fmt='(a11,i3,a25)') + 'pltmg error',iflag,': newton iteration failed' endif if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.24) then write(unit=sp(11),fmt='(a11,i3,a8,i4)') + 'pltmg error',iflag,': region',ip(24) else if(iflag.eq.48) then write(unit=sp(11),fmt='(a11,i3,a12)') + 'pltmg error',iflag,': mpi is off' else if(iflag.eq.71.or.iflag.eq.72) then write(unit=sp(11),fmt='(a11,i3,a27)') + 'pltmg error',iflag,': dd solver not initialized' if(nproc.gt.1) ip(24)=irgn else write(unit=sp(11),fmt='(a11,i3,a15)') + 'pltmg error',iflag,': unknown error' if(nproc.gt.1) ip(24)=irgn endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltmgd(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 ipath,jequv,ja0,a0,h0,g0,su0,sm0,nn,gf, 3 time,hist,path,z,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ka(*),ja(*),ipath(6,*),jequv(*),ja0(*), 2 itdof(ndof,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 u0dot(*),evr(*),evl(*),um(*),uc(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),p(*), 3 d(*),rd(*),dl(*),bdlwr(*),bdupr(*),du(*),dum(*), 4 duc(*),time(3,*),hist(22,*),path(101,*),z(*), 5 a0(*),h0(*),g0(*),su0(*),sm0(*),gf(nn,*),t(20) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy data ibit/0/ c c make sure the system is solved on each domain c iprob=iabs(ip(7)) ip(7)=iprob jflag=0 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.1) then if(ip(9).ne.9) ip(9)=0 else ip(9)=0 endif c call nwtt(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,-1,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c irgn=ip(50) ip(7)=-ip(7) call exflag(ip(25)) if(ip(25).ne.0) return c c initialize global parameters on all processors c nproc=ip(49) irgn=ip(50) eps=ceps(ibit)*1.0e2 epsmg=amax1(1.0e-4,eps) ndf=ip(5) if(iprob.eq.4) then t(1)=rp(21) call pl2ip(t,1) rl=t(1)/float(nproc) rmu=rp(3) rllwr=rp(4) rlupr=rp(5) tol=amax1(1.0e-2*rmu,eps) c if(rlupr.ne.0.0e0) then rup=abs(rlupr)*tol else rup=tol endif if(rllwr.ne.0.0e0) then rlw=abs(rllwr)*tol else rlw=tol endif if(rllwr+rlw.le.rlupr-rup) then rl=amax1(rl,rllwr+rlw) rl=amin1(rl,rlupr-rup) else rr=tol*(rlupr-rllwr) rl=amax1(rl,rllwr+rr) rl=amin1(rl,rlupr-rr) endif c rp(21)=rl else if(iprob.eq.3) then do k=1,ndf u0(k)=u(k) u0dot(k)=udot(k) enddo do k=1,7 t(k)=rp(20+k) enddo t(8)=rp(68) call pl2ip(t,8) do k=1,7 rp(20+k)=t(k)/float(nproc) enddo rp(68)=t(8)/float(nproc) do k=1,5 rp(30+k)=rp(20+k) enddo endif c c initialize for domain decomposition solve c ntf=ip(1) ndf=ip(5) ising=ip(12) itask=ip(9) newndf=ip(30) ndd=ip(33) ndi=ip(36) iord=ip(26) c nvdd=ip(71) lipath=ip(72) if(nvdd.le.0) then ip(25)=71 else if(lipath.le.0) then ip(25)=72 else if(ipath(2,nproc+2).lt.ipath(1,nproc+2)) then ip(25)=72 else ip(25)=0 endif call exflag(ip(25)) if(ip(25).ne.0) return c c initialize for domain decomposition c rp(52)=1.0e0 rp(56)=1.0e0 rp(57)=1.0e0 rp(54)=0.0e0 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 ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 mxcg=ip(10) mxnwtt=ip(11) jnwtt=mxnwtt if(iprob.eq.3) jnwtt=mxnwtt+1 c ir=1 img=ir+ndf igm=img+ndf iadu=igm+ndf ihdu=iadu+ndf iadm=ihdu+ndf ismdm=iadm+ndf ismdc=ismdm+ndf isudu=ismdc+ndf isudc=isudu+ndf igdc=isudc+ndf isv=igdc+ndf iin=isv+ndf imk=iadu id1=ihdu id2=iadm mm1=1 mm2=mm1+3*ndf mm3=mm2+3*ndf mm4=mm3+3*ndf mm5=mm4+3*ndf mm6=mm5+3*ndf c maxja0=9*iord*nvdd/2 call cequv2(irgn,nproc,iord,newndf,ndi,ipath,jequv,ja0) call setgr2(irgn,nproc,ntf,ndd,newndf,ndi,itnode, + ndof,itdof,ipath,jequv,ja0,z(ir),maxja0,kflag) if(kflag.ne.0) stop 9011 c iqptr=ja(ndf+1) c c linear system c call timer(time,33) call rgnsys(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,um,uc,z(id1),z(id2),vx0,vy0,ndof,itdof, 1 ja,ja(iqptr),a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,z(imk), 2 z(imk),jequv,ipath,ja0,a0,h0,g0,su0,sm0,nn,gf, 3 z(igm),z(iin),1,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) call timer(time,32) c c solve equations c call hist3(hist(1,11),-1,1.0e0,1.0e0) do itnum=1,jnwtt c if(itnum.gt.0) then call timer(time,33) call mgilu(ja,a,ka,z(img)) call timer(time,22) endif c c multi-level solution of newton equations c call timer(time,33) if(iprob.eq.3) then call blk3(ip,rp,vx,vy,ndof,itdof,itnode,du,dum, + ka,ja,a,b,rd,p,udot,u0dot,epsmg,z(ir), 1 z(img),hist,jflag,1) call timer(time,26) if(iconv.eq.1) go to 170 if(itnum.gt.mxnwtt) go to 100 else if(iprob.eq.4) then call blk4(ip,rp,du,dum,ka,ja,a,h,b,p,dl, + rd,udot,epsmg,z(ir),z(img),hist,jflag,1) call timer(time,27) else if(iprob.eq.5) then call mgilu(ja,g,ka(101),z(img)) call timer(time,22) call blk5(ip,epsmg,ka,ja,a,h,g,su,sm, + du,dum,duc,p,b,dl,z(mm1),z(mm2),z(mm3), 1 z(mm4),z(mm5),hist(1,7),z(mm6),reler5,jflag) c call blk5x(ip,du,dum,duc,ka,ja,a,h,g,su,sm, c + b,p,dl,epsmg,z(ir),z(img),hist,jflag) call timer(time,28) else do i=1,ndf z(ir+i-1)=b(i) enddo call mg(ispd,mxcg,epsmg,ja,a,du,z(ir), + ka,ising,reler1,jflag,z(img),hist(1,7)) if(iprob.eq.1.and.itask.eq.9) then do i=1,ndf z(ir+i-1)=p(i) enddo call mg(jspd,mxcg,epsmg,ja,a,dum,z(ir), + ka,ising,reler2,jflag,z(img),hist(1,8)) endif call timer(time,21) endif c c line search loop c isw=0 call timer(time,33) call tpickd(ip,rp,vx,vy,itnode,u,um,uc,z(isv), + z(ir),z(img),ja,a,h,g,su,sm,b,d,p,dl,bdlwr,bdupr, 1 du,dum,duc,ipath,jequv,ja0,a0,h0,g0,su0,sm0,nn,gf, 2 z(iadu),z(iadm),z(ihdu),z(igdc),z(isudu),z(isudc), 3 z(ismdm),z(ismdc),z(igm),z(iin),isw,itnum,ndof,itdof) call timer(time,31) c c initializization for itnum=1 c dnew=rp(58) if(dnew.gt.0.0e0) then call hist3(hist(1,11),itnum,rp(56),rp(54)) iconv=icvtst(itnum,-iprob,itask,itype,rp) c**** iconv=jcvtst(itnum,-iprob,itask,itype,rp) if(iconv.eq.1) go to 170 ip(25)=2 if(jflag.ne.0) ip(25)=11 go to 130 endif iter=0 70 iter=iter+1 c c linear system c call timer(time,33) call rgnsys(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,um,uc,z(id1),z(id2),vx0,vy0,ndof,itdof, 1 ja,ja(iqptr),a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,z(imk), 2 z(imk),jequv,ipath,ja0,a0,h0,g0,su0,sm0,nn,gf, 3 z(igm),z(iin),0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) ievals=ievals+1 call timer(time,32) c call tpickd(ip,rp,vx,vy,itnode,u,um,uc,z(isv), + z(ir),z(img),ja,a,h,g,su,sm,b,d,p,dl,bdlwr,bdupr, 1 du,dum,duc,ipath,jequv,ja0,a0,h0,g0,su0,sm0,nn,gf, 2 z(iadu),z(iadm),z(ihdu),z(igdc),z(isudu),z(isudc), 3 z(ismdm),z(ismdc),z(igm),z(iin),isw,itnum,ndof,itdof) 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(56),rp(54)) iconv=icvtst(itnum,-iprob,itask,itype,rp) c**** iconv=jcvtst(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 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltmgp(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,path,z,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ka(*),ja(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 u0dot(*),evr(*),evl(*),um(*),uc(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),p(*), 3 d(*),rd(*),dl(*),bdlwr(*),bdupr(*),du(*),dum(*), 4 duc(*),time(3,*),hist(22,*),path(101,*),z(*) 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) ndf=ip(5) iord=ip(26) c call filutl(msg,0) c call uinit(ip,rp,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,z,ndof,itdof,z(ndf+1),gdxy) c if(itask.eq.10) then tstart=rp(42) tend=rp(43) if(tstart.ge.tend) return mxstep=max0(1,ip(15)) mxfail=5 rp(46)=tstart rp(49)=tend-tstart rp(48)=rp(49)/float(mxstep) tnew=rp(46) ifirst=1 c c compute time step c 60 call dtpick(ntf,ndf,itnode,vx,vy,u,u0,rp,z,itflag,ifirst, + z(ndf+1),ndof,itdof) c c update solution c if(itflag.ne.-1.and.ifirst.ne.-1) then rp(46)=tnew do i=1,ndf u0(i)=u(i) enddo do i=1,nvf 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=amax1(rp(47),rp(48)) rp(21)=tcur+deltat if(deltat.gt.0) then rp(45)=1.0e0/deltat else rp(45)=0.0e0 endif call nwtt(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) if(ip(25).ne.0) then if(idsp.lt.mxfail) then rp(47)=rp(47)/2.0e0 go to 220 else do i=1,ndf 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=amax1(rp(47),rp(48)) rp(21)=tcur if(deltat.gt.0) then rp(45)=1.0e0/deltat else rp(45)=0.0e0 endif call nwtt(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltmgc(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,path,z,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ka(*),ja(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 u0dot(*),evr(*),evl(*),um(*),uc(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),p(*), 3 d(*),rd(*),dl(*),bdlwr(*),bdupr(*),du(*),dum(*), 4 duc(*),time(3,*),hist(22,*),path(101,*),z(*) 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) nbf=ip(4) ndf=ip(5) eps=1.0e2*ceps(ibit) iord=ip(26) c c call filutl(msg(1),0) c istep=0 idsp=0 mxbis=10 mxfail=10 mxstep=10 c igm=1 ipp=igm+ndf iz1=ipp+ndf iz2=iz1+ndf iz3=iz2+ndf iz4=iz3+ndf c c restore solution c call uinit(ip,rp,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,z(igm),ndof,itdof,z(ipp),gdxy) do i=1,ndf 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=abs(rltrgt-rp(21))+abs(rtrgt-rp(22)) if(dd.eq.0.0e0.and.itask.le.1) itask=7 if(dd.ne.0.0e0.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,33) call swbrch(ndf,ntf,nbf,itnode,ibndry,ndof,itdof,vx,vy, + xm,ym,evl,evr,udot,u,u0dot,z(ipp),z(iz1),z(iz2), 1 z(iz3),z(igm),z(iz4),rp,ibedge,ispd,iord, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,0) call timer(time,29) call updpth(path,0,6,rp) do i=1,ndf 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,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,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,33) call predct(ip,itnode,ibndry,vx,vy,xm,ym,z(ipp),z(iz1), + z(igm),u0,u0dot,rp,ibedge,idsp,mxfail,ndof,itdof, 1 z(iz2),z(iz3),z(iz3),a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) call timer(time,25) 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,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,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.0e0.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=amax1(abs(sval),abs(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,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,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(abs(sigma).eq.abs(rp(71))) then rp(71)=sigma*(1.0e0-eps) go to 20 else if(abs(sigma).lt.abs(rp(71))) then rp(71)=sigma*(1.0e0+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(ndf,udot)*rl2nrm(ndf,evr) if(dnorm.gt.0.0e0) dnorm=1.0e0/dnorm udr=rl2ip(ndf,evr,udot)*dnorm if(abs(udr).gt.1.0e-1.and.rlsign.lt.0.0e0) then call filutl(msg(3),0) call updpth(path,0,2,rp) else if(abs(rp(25)).gt.rqmx*1.0e-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,33) call swbrch(ndf,ntf,nbf,itnode,ibndry,ndof,itdof,vx,vy, + xm,ym,evl,evr,udot,u,u0dot,z(ipp),z(iz1),z(iz2), 1 z(iz3),z(igm),z(iz4),rp,ibedge,ispd,iord, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,1) call timer(time,29) 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,ndf 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltmgo(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,path,z,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ka(*),ja(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 u0dot(*),evr(*),evl(*),um(*),uc(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),p(*), 3 d(*),rd(*),dl(*),bdlwr(*),bdupr(*),du(*),dum(*), 4 duc(*),time(3,*),hist(22,*),path(101,*),z(*) character*80 + iostr external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy save isw data isw/1/ c c solve equations c rp(21)=rp(1) rp(22)=rp(2) iprob=ip(7) if(iprob.eq.2) then rp(63)=rp(3) else if(ip(9).ne.9) ip(9)=0 endif call nwtt(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) if(iprob.eq.2.and.ip(25).eq.0) then 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltmgi(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,path,z,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ka(*),ja(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 u0dot(*),evr(*),evl(*),um(*),uc(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),p(*), 3 d(*),rd(*),dl(*),bdlwr(*),bdupr(*),du(*),dum(*), 4 duc(*),time(3,*),hist(22,*),path(101,*),z(*) 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(7) 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.0e0*ceps(ibit) tol=amax1(1.0e-2*rmu,eps) rl=rp(21) c if(rlupr.ne.0.0e0) then rup=abs(rlupr)*tol else rup=tol endif if(rllwr.ne.0.0e0) then rlw=abs(rllwr)*tol else rlw=tol endif if(rllwr+rlw.le.rlupr-rup) then rl=amax1(rl,rllwr+rlw) rl=amin1(rl,rlupr-rup) else rr=tol*(rlupr-rllwr) rl=amax1(rl,rllwr+rr) rl=amin1(rl,rlupr-rr) endif c rp(21)=rl endif rp(63)=rp(3) call nwtt(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c if(ip(25).eq.0) then 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine nwtt(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,u0dot,evr,evl,um,uc,vx0,vy0,ndof,itdof, 1 ka,ja,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc, 2 time,hist,z,itype,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ka(*),ja(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 u0dot(*),evr(*),evl(*),um(*),uc(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),d(*), 3 rd(*),p(*),dl(*),bdlwr(*),bdupr(*),du(*),dum(*), 4 duc(*),time(3,*),hist(22,*),z(*),rpsv(100) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy data ibit/0/ c c approximate newton method c ntf=ip(1) ndf=ip(5) itask=ip(9) iprob=ip(7) ising=ip(12) iord=ip(26) eps=1.0e2*ceps(ibit) c rp(52)=1.0e0 rp(56)=1.0e0 rp(57)=1.0e0 if(itype.eq.0) then epsmg=amax1(1.0e-3,eps) else epsmg=amax1(1.0e-4,eps) endif epsmg0=epsmg mxdamp=20 iconv=0 jflag=0 c ncfact=4 maxlvl=20 ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 maxja=ip(87) maxa=ip(88) if(iprob.eq.5) then if(ispd.eq.1) then maxa=maxa/2 else maxa=2*maxa/3 endif maxg=ip(88)-maxa endif lenz=30*ndf mxcg=ip(10) mxnwtt=ip(11) jnwtt=mxnwtt if(iprob.eq.3) jnwtt=mxnwtt+1 dtol=rp(6) c c get pointers (len = 13 ispd=0, 16/17 ispd=0,iprob eq/ne 3 c isav=1 m1=isav+ndf m2=m1+ndf m3=m2+ndf m4=m3+ndf m5=m4+ndf m6=m5+ndf img=m1 if(ispd.eq.1) then ns1=m1 ns2=m2 ns3=m3 kmg=m4 else ns1=m4 ns2=m5 ns3=m6 kmg=m6+ndf endif mm1=1 mm2=mm1+3*ndf mm3=mm2+3*ndf mm4=mm3+3*ndf mm5=mm4+3*ndf mm6=mm5+3*ndf c c save rp c do i=1,100 rpsv(i)=rp(i) enddo c maxlnk=ndf*4 if(iord.eq.2) maxlnk=ndf*25/4 if(iord.eq.3) maxlnk=ndf*81/9 call setgr1(ntf,ndf,ndof,itdof,ja,a,maxlnk,kflag) call mdinit(ndf,ispd,ja,ka,lenz,z,kflag) if(kflag.ne.0) then ip(25)=kflag return endif c iqptr=ja(ndf+1) call uinit(ip,rp,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,z(m1),ndof,itdof,z(m2),gdxy) if(iprob.eq.3) call evinit(ip,evl,evr,ndof,itdof,ibndry, + ibedge,ja(iqptr),z(m1)) if(iprob.eq.2) call bdinit(ip,rp,u,vx,vy,xm,ym,ndof,itdof, + itnode,ibndry,ibedge,bdlwr,bdupr,z(m1),z(m2),gdxy) if(iprob.eq.5) call bdinit(ip,rp,uc,vx,vy,xm,ym,ndof,itdof, + itnode,ibndry,ibedge,bdlwr,bdupr,z(m1),z(m2),gdxy) c if(iprob.eq.3.and.itask.le.1) then seqdot=rp(74) sigma=rp(71) rl0dot=rp(33) if(seqdot.ne.0.0e0) then ss=sqrt(eps)*rl0dot*sigma/seqdot else ss=sqrt(eps)*rl0dot endif do j=1,ndf u(j)=u(j)+ss*u0dot(j) enddo endif c c first matrix and right hand side c call timer(time,33) call linsys(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,um,uc,z(m3),z(m4),vx0,vy0,ndof,itdof, 1 ja,ja(iqptr),a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,z(m5), 2 z(m6),1,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) call timer(time,24) c c print out matrix and return (for mutigraph testing) c c call mkmtx(ndf,ispd,ja,a,b,ja(iqptr),z(m1)) c ip(25)=82 c if(ip(25).ne.0) return c ievals=1 c c compute ordering symbolic factorization c call timer(time,33) call mgilu0(maxja,ja,maxa,a,ncfact,maxlvl,ka,dtol,z,kflag) call timer(time,20) if(kflag.ne.0) then ip(25)=kflag return endif ip(73)=ka(17) ip(74)=ka(18) ip(75)=ka(2) c c ka array for matrix g c if(iprob.eq.5) then do i=1,100 ka(i+100)=ka(i) enddo ka(106)=ka(6)+ka(10) ka(107)=ka(3) ka(114)=1 call timer(time,33) call mgilu0(maxja,ja,maxg,g,ncfact,maxlvl,ka(101), + dtol,z,kflag) call timer(time,20) if(kflag.ne.0) then ip(25)=kflag return endif endif c c the main loop c call hist3(hist(1,11),0,1.0e0,1.0e0) do itnum=1,jnwtt c c compute approximate factorization c if(itnum.gt.1) then call timer(time,33) call mgilu(ja,a,ka,z(img)) call timer(time,22) if(itype.eq.0) then epsmg=amax1(epsmg0,rp(57)) epsmg=amin1(1.0e-1,rp(57)) endif endif c c compute singular vectors c if(iprob.eq.3) then call timer(time,33) call cev(ip,rp,ja,a,ka,evl,evr,z(m1),z(ns1), + z(m2),z(ns2),z(m3),z(ns3),z(kmg),hist) call timer(time,23) endif c c multi-level solution of newton equations c call timer(time,33) if(iprob.eq.3) then call blk3(ip,rp,vx,vy,ndof,itdof,itnode,du,dum, + ka,ja,a,b,rd,p,udot,u0dot,epsmg,z(isav), 1 z(img),hist,jflag,0) call timer(time,26) if(iconv.eq.1) go to 170 if(itnum.gt.mxnwtt) go to 100 else if(iprob.eq.4) then call blk4(ip,rp,du,dum,ka,ja,a,h,b,p,dl, + rd,udot,epsmg,z(isav),z(img),hist,jflag,0) call timer(time,27) else if(iprob.eq.5) then if(itnum.gt.1) then call mgilu(ja,g,ka(101),z(img)) call timer(time,22) endif call blk5(ip,epsmg,ka,ja,a,h,g,su,sm, + du,dum,duc,p,b,dl,z(mm1),z(mm2),z(mm3), 1 z(mm4),z(mm5),hist(1,7),z(mm6),reler5,jflag) c call blk5x(ip,du,dum,duc,ka,ja,a,h,g,su,sm, c + b,p,dl,epsmg,z(isav),z(img),hist,jflag) call timer(time,28) else do j=1,ndf z(isav+j-1)=b(j) enddo call mg(ispd,mxcg,epsmg,ja,a,du,z(isav), + ka,ising,reler1,jflag,z(img),hist(1,7)) if(iprob.eq.1.and.itask.eq.9) then do j=1,ndf z(isav+j-1)=p(j) enddo call mg(jspd,mxcg,epsmg,ja,a,dum,z(isav), + ka,ising,reler2,jflag,z(img),hist(1,8)) endif call timer(time,21) endif c c line search and sufficient decrease loop c isw=0 call timer(time,33) call tpick(ip,rp,vx,vy,itnode,ndof,itdof,u,um,uc, + z(isav),z(m1),z(m2),ja,a,h,g,su,sm,b,d,p,dl,bdlwr, 1 bdupr,du,dum,duc,z(m3),z(m4),z(m5),z(m6),isw,itnum) call timer(time,30) dnew=rp(58) cc write(6,*) itnum,dnew,rp(52) if(dnew.gt.0.0e0) then call hist3(hist(1,11),itnum,rp(56),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)=11 go to 130 endif iter=0 70 iter=iter+1 c call timer(time,33) call linsys(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,um,uc,z(m3),z(m4),vx0,vy0,ndof,itdof, 1 ja,ja(iqptr),a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,z(m5), 2 z(m6),0,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) ievals=ievals+1 call timer(time,24) call tpick(ip,rp,vx,vy,itnode,ndof,itdof,u,um,uc, + z(isav),z(m1),z(m2),ja,a,h,g,su,sm,b,d,p,dl,bdlwr, 1 bdupr,du,dum,duc,z(m3),z(m4),z(m5),z(m6),isw,itnum) call timer(time,30) 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)=11 go to 130 endif c c convergence test c call hist3(hist(1,11),itnum,rp(56),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)=rpsv(i) enddo if(iprob.eq.3) then do j=1,ndf udot(j)=u0dot(j) u(j)=u0(j) enddo else if(iprob.eq.6) then do j=1,ndf 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 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function icvtst(itnum,iprob,itask,itype,rp) c implicit real (a-h,o-z) implicit integer (i-n) real + rp(100) save tola,tolb,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.0e2*ceps(ibit) tola=eps if(itype.eq.1) tola=sqrt(tola) tolb=tola trf=0.5e0 erf=1.0e0-eps egf=0.1e0 if(ii.eq.1) then tole=1.0e-1 tolr=1.0e-2 else if(ii.eq.2) then tole=1.0e-2 tolr=1.0e-4 else tole=1.0e-2 tolr=1.0e-4 endif endif c reler0=rp(53) relerr=rp(54) relres=rp(56) ratio=rp(57) c c revise tol if indicated c if(isw.eq.0.and.ii.ge.1.and.relerr.lt.trf) then isw=1 tola=amax1(relerr*tole,tola) if(relres.le.1.0e0) tolb=amax1(relres*tole,tolb) if(reler0.lt.0.5e0) tola=amax1(reler0*tole,tola) endif c c convergence test c icvtst=0 if(relerr.lt.tole.or.relres.lt.tolr) icvtst=-1 if(relerr.le.tola.and.ratio.le.erf) icvtst=-1 if(relerr.le.tola.and.relres.le.tolb) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function jcvtst(itnum,iprob,itask,itype,rp) c implicit real (a-h,o-z) implicit integer (i-n) real + rp(100) save tola,tolb,eps,erf,egf,tole,tolr,isw,trf data ibit/0/ c c debug convergence test for outer parallel solve c c jcvtst = -1 making progress c jcvtst = 0 not converged c jcvtst = 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.0e2*ceps(ibit) tola=eps if(itype.eq.1) tola=sqrt(tola) tolb=tola trf=0.5e0 erf=1.0e0-eps egf=0.1e0 if(ii.eq.1) then tole=1.0e-4 tolr=1.0e-6 else if(ii.eq.2) then tole=1.0e-2 tolr=1.0e-4 else tole=1.0e-2 tolr=1.0e-4 endif endif c reler0=rp(53) relerr=rp(54) relres=rp(56) ratio=rp(57) c c revise tol if indicated c if(isw.eq.0.and.ii.ge.1.and.relerr.lt.trf) then isw=1 tola=amax1(relerr*tole,tola) if(relres.le.1.0e0) tolb=amax1(relres*tole,tolb) if(reler0.lt.0.5e0) tola=amax1(reler0*tole,tola) endif c c convergence test c jcvtst=0 if(relerr.lt.tole.or.relres.lt.tolr) jcvtst=-1 if(relerr.le.tola.and.ratio.le.erf) jcvtst=-1 if(relerr.le.tola.and.relres.le.tolb) jcvtst=1 if(relres.lt.eps.and.ratio.ge.egf) jcvtst=1 if(relerr.lt.eps) jcvtst=1 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cev(ip,rp,ja,a,ka,evl,evr,br,bl,devr,devl, + evr0,evl0,z,hist) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),ka(*) real + rp(100),a(*),evl(*),evr(*),bl(*),br(*),evr0(*), 1 evl0(*),devr(*),devl(*),z(*),hist(22,*) save ibit data ibit/0/ 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 ndf=ip(5) ispd=ip(8) mxcg=ip(10) anorm=rp(55) jspd=1 if(ispd.ne.1) jspd=-1 i1=1 i2=i1+ndf i3=i2+ndf iqptr=ka(3) japtr=ka(4) iaptr=ka(5) juptr=ka(6) iuptr=ka(7) nsum=ka(8) c tol=1.0e-3 eps=ceps(ibit)*1.0e2 tol1=amax1(tol*1.0e-1,sqrt(eps)) itmax=max0(10,mxcg) c c check for null vectors c sval=1.0e0 evrn=rl2nrm(ndf,evr) evln=rl2nrm(ndf,evl) if(evrn.eq.0.0e0.or.evln.eq.0.0e0) then rp(25)=sval return endif c c normalize initial vectors c dp=rl2ip(ndf,evl,evr) if(dp.lt.0.0e0) evln=-evln do i=1,ndf ee=evr(i)/evrn evl(i)=evl(i)/evln evr(i)=ee enddo do i=1,ndf ii=ja(iqptr+i-1) z(i1+ii-1)=evr(i) z(i2+ii-1)=evl(i) enddo do i=1,ndf evr(i)=z(i1+i-1) evl(i)=z(i2+i-1) devr(i)=0.0e0 devl(i)=0.0e0 evr0(i)=0.0e0 evl0(i)=0.0e0 enddo c c inverse iteration loop c call hist1(hist(1,14),0,1.0e0) do itnum=1,itmax c c a evr = sval * evl c a(transpose) evl = sval * evr c call mtxmlt(ndf,ja,a,evr,z,ispd) sval=rl2ip(ndf,evl,z) do i=1,ndf br(i)=sval*evl(i)-z(i) bl(i)=br(i) enddo brnorm=rl2nrm(ndf,br) dr=brnorm/(abs(sval)+tol*anorm) if(ispd.ne.1) then call mtxmlt(ndf,ja,a,evl,z,jspd) svll=rl2ip(ndf,evr,z) do i=1,ndf bl(i)=svll*evr(i)-z(i) enddo blnorm=rl2nrm(ndf,bl) dl=blnorm/(abs(svll)+tol*anorm) dr=amax1(dr,dl) endif call hist1(hist(1,14),itnum,dr) if(dr.lt.tol.and.itnum.gt.1) go to 100 c c add small perturbation c ee=tol1*brnorm do i=1,ndf br(i)=br(i)+ee ee=-ee enddo c call cycle(ispd,ka,ja(japtr),a(iaptr), + ja(juptr),a(iuptr),devr,br,z,z(nsum+1)) call csv(ndf,ja,a,evr,z(i1),devr,z(i2),evr0,z(i3),ispd) c if(ispd.ne.1) then ee=tol1*blnorm do i=1,ndf bl(i)=bl(i)+ee ee=-ee enddo c call cycle(jspd,ka,ja(japtr),a(iaptr), + ja(juptr),a(iuptr),devl,bl,z,z(nsum+1)) call csv(ndf,ja,a,evl,z(i1),devl,z(i2),evl0,z(i3),jspd) else do i=1,ndf 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(ndf,evr,evl) if(dp.lt.0.0e0) then sval=-sval do i=1,ndf evl(i)=-evl(i) enddo endif do i=1,ndf ii=ja(iqptr+i-1) z(i1+i-1)=evr(ii) z(i2+i-1)=evl(ii) enddo do i=1,ndf evr(i)=z(i1+i-1) evl(i)=z(i2+i-1) enddo rp(25)=sval return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine csv(n,ja,a,ev,aev,dev,adev,ev0,aev0,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*),ev(*),aev(*),dev(*),adev(*),ev0(*),aev0(*), 1 aa(3,3),r(3),q(3,3) c c orthogonalize c 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,aev,aev) aa(1,2)=rl2ip(n,aev,adev) aa(1,3)=rl2ip(n,aev,aev0) aa(2,1)=aa(1,2) aa(2,2)=rl2ip(n,adev,adev) aa(2,3)=rl2ip(n,adev,aev0) aa(3,1)=aa(1,3) aa(3,2)=aa(2,3) aa(3,3)=rl2ip(n,aev0,aev0) call ev3x3(aa,r,q,irank) c c reset ev c 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 enddo evnorm=rl2nrm(n,ev) if(evnorm.gt.0.0e0) evnorm=1.0e0/evnorm ev0nrm=rl2nrm(n,ev0) if(ev0nrm.gt.0.0e0) ev0nrm=1.0e0/ev0nrm do i=1,n ev(i)=ev(i)*evnorm ev0(i)=ev0(i)*ev0nrm enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine c3x3(a,b,num) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + a(3,3),b(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c this routine solves 3 x 3 linear systems c c scale rows so that largest element is one c do j=1,3 rmax=amax1(abs(a(j,1)),abs(a(j,2)),abs(a(j,3))) if(rmax.ne.0.0e0) rmax=1.0e0/rmax do k=1,3 a(j,k)=a(j,k)*rmax enddo do k=1,num b(j,k)=b(j,k)*rmax enddo enddo c j1=1 if(abs(a(1,1)).lt.abs(a(2,1))) j1=2 if(abs(a(j1,1)).lt.abs(a(3,1))) j1=3 j2=index(2,j1) j3=index(3,j1) c if(a(j1,1).ne.0.0e0) a(j1,1)=1.0e0/a(j1,1) q2=a(j2,1)*a(j1,1) q3=a(j3,1)*a(j1,1) do k=1,num b(j2,k)=b(j2,k)-b(j1,k)*q2 b(j3,k)=b(j3,k)-b(j1,k)*q3 enddo c a(j2,2)=a(j2,2)-a(j1,2)*q2 a(j2,3)=a(j2,3)-a(j1,3)*q2 a(j3,2)=a(j3,2)-a(j1,2)*q3 a(j3,3)=a(j3,3)-a(j1,3)*q3 c if(abs(a(j2,2)).lt.abs(a(j3,2))) j2=j3 j3=6-j1-j2 if(a(j2,2).ne.0.0e0) a(j2,2)=1.0e0/a(j2,2) q3=a(j3,2)*a(j2,2) do k=1,num b(j3,k)=b(j3,k)-b(j2,k)*q3 enddo a(j3,3)=a(j3,3)-a(j2,3)*q3 c if(a(j3,3).ne.0.0e0) a(j3,3)=1.0e0/a(j3,3) do k=1,num x3=b(j3,k)*a(j3,3) x2=(b(j2,k)-a(j2,3)*x3)*a(j2,2) b(1,k)=(b(j1,k)-a(j1,2)*x2-a(j1,3)*x3)*a(j1,1) b(2,k)=x2 b(3,k)=x3 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ev3x3(a,r,q,irank) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 do j=1,3 q(i,j)=0.0e0 enddo q(i,i)=1.0e0 enddo as=amax1(a(1,1),a(2,2),a(3,3)) if(as.eq.0.0e0) 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.0e0 c0=amax1(a11*a22-d12,0.0e0) d=(a11-a22)/2.0e0 d=sqrt(d*d+d12) r1=c0/(b+d) r(1)=r1*as r(2)=(b+d)*as r(3)=0.0e0 d1=a11-r1 d2=a22-r1 if(amax1(abs(d1),abs(d2)).eq.0.0e0) then c=1.0e0 s=0.0e0 else if(abs(d1).gt.abs(d2)) then dd=1.0e0/sqrt(d1**2+d12) c=-a12*dd s=d1*dd else dd=1.0e0/sqrt(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.0e-3 d12=a12**2 d13=a13**2 d23=a23**2 p=-(a11+a22+a33)/3.0e0 qq=a11*a22+a22*a33+a33*a11-d12-d13-d23 s=a11*d23+a22*d13+a33*d12 + -a11*a22*a33-2.0e0*a12*a23*a13 c c solve cubic equation (all roots should be real and non-neg.) c aa=qq/3.0e0-p**2 bb=p**3-(p*qq-s)/2.0e0 if(bb**2+aa**3.ge.0.0e0) then c c case of two equal roots (assume b*b+a*a*a=0) c sgn=2.0e0 if(bb.gt.0.0e0) sgn=-2.0e0 bb=sgn*(abs(bb)**(1.0e0/3.0e0)) r(1)=bb-p r(2)=-bb/2.0e0-p r(3)=r(2) else c c three distinct roots c d=sqrt(-aa)*2.0e0 theta=2.0e0*bb/(aa*d) theta=amin1(1.0e0,theta) theta=amax1(-1.0e0,theta) theta=acos(theta)/3.0e0 pi=3.141592653589793e0/3.0e0 r(1)=d*cos(theta)-p r(2)=d*cos(theta+2.0e0*pi)-p r(3)=d*cos(theta+4.0e0*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(amin1(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.amax1(s2,s3)) then qq=1.0e0/sqrt(s1) v1=qq*a1 v2=qq*a12 v3=qq*a13 else if(s2.gt.s3) then qq=1.0e0/sqrt(s2) v1=qq*a12 v2=qq*a2 v3=qq*a23 else qq=1.0e0/sqrt(s3) v1=qq*a13 v2=qq*a23 v3=qq*a3 endif if(v1.eq.0.0e0) then w1=1.0e0 w2=0.0e0 w3=0.0e0 else if(v2.eq.0.0e0) then w1=0.0e0 w2=1.0e0 w3=0.0e0 else qq=1.0e0/sqrt(v1**2+v2**2) w1=-v2*qq w2=v1*qq w3=0.0e0 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=sqrt((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=sqrt((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.e-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.amax1(ww,zz)) then qq=1.0e0/sqrt(vv) q(1,i)=qq*v1 q(2,i)=qq*v2 q(3,i)=qq*v3 else if(ww.gt.zz) then qq=1.0e0/sqrt(ww) q(1,i)=qq*w1 q(2,i)=qq*w2 q(3,i)=qq*w3 else qq=1.0e0/sqrt(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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine orthog(n,v1,v2,v3,irank) c implicit real (a-h,o-z) implicit integer (i-n) real + v1(*),v2(*),v3(*),r(3) c c orthogonalize, normalize, determine rank c tol=1.e-1 a11=0.0e0 a22=0.0e0 a33=0.0e0 do i=1,n a11=a11+v1(i)**2 a22=a22+v2(i)**2 a33=a33+v3(i)**2 enddo if(a11.gt.0.0e0) a11=1.0e0/sqrt(a11) if(a22.gt.0.0e0) a22=1.0e0/sqrt(a22) if(a33.gt.0.0e0) a33=1.0e0/sqrt(a33) d12=0.0e0 d13=0.0e0 do i=1,n 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.0e0 a33=0.0e0 do i=1,n 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.0e0) a22=1.0e0/sqrt(a22) if(a33.gt.0.0e0) a33=1.0e0/sqrt(a33) d23=0.0e0 do i=1,n v2(i)=v2(i)*a22 v3(i)=v3(i)*a33 d23=d23+v2(i)*v3(i) enddo a33=0.0e0 do i=1,n v3(i)=v3(i)-d23*v2(i) a33=a33+v3(i)**2 enddo if(a33.gt.0.0e0) a33=1.0e0/sqrt(a33) a12=0.0e0 a13=0.0e0 a23=0.0e0 do i=1,n 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.0e0) a11=1.0e0 if(a22.gt.0.0e0) a22=1.0e0 if(a33.gt.0.0e0) a33=1.0e0 d12=a12**2 d13=a13**2 d23=a23**2 p=-(a11+a22+a33)/3.0e0 qq=a11*a22+a22*a33+a33*a11-d12-d13-d23 s=a11*d23+a22*d13+a33*d12 + -a11*a22*a33-2.0e0*a12*a23*a13 c c solve cubic equation (all roots should be real and non-neg.) c aa=qq/3.0e0-p**2 bb=p**3-(p*qq-s)/2.0e0 if(bb**2+aa**3.ge.0.0e0) then c c case of two equal roots (assume b*b+a*a*a=0) c sgn=2.0e0 if(bb.gt.0.0e0) sgn=-2.0e0 bb=sgn*(abs(bb)**(1.0e0/3.0e0)) r(1)=bb-p r(2)=-bb/2.0e0-p r(3)=r(2) else c c three distinct roots c d=sqrt(-aa)*2.0e0 theta=2.0e0*bb/(aa*d) theta=amin1(1.0e0,theta) theta=amax1(-1.0e0,theta) theta=acos(theta)/3.0e0 pi=3.141592653589793e0/3.0e0 r(1)=d*cos(theta)-p r(2)=d*cos(theta+2.0e0*pi)-p r(3)=d*cos(theta+4.0e0*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,n v2(i)=0.0e0 v3(i)=0.0e0 enddo else if(irank.eq.2.and.a33.gt.0.0e0) then if(a22.le.0.0e0) then do i=1,n v2(i)=v3(i) enddo else if(abs(a13).lt.abs(a12)) then do i=1,n v2(i)=v3(i) enddo endif do i=1,n v3(i)=0.0e0 enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine grad(ux,uy,vx,vy,u,iv,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + iv(3) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function carea(ntf,itnode,itedge, + ibndry,vx,vy,xm,ym) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3) real + 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.0e0 pi=3.141592653589793e0 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=abs(x2*y3-x3*y2)/2.0e0 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=abs(theta2-theta1)*pi aa=(rad**2/2.0e0)*(theta-sin(theta)) if(c(j).lt.0.0e0) aa=-aa det=det+aa 5 enddo carea=carea+det enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bari(x,y,vx,vy,iv,c) c implicit real (a-h,o-z) implicit integer (i-n) integer + iv(3) real + 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.0e0-c(2)-c(3) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function rl2nrm(n,b) c implicit real (a-h,o-z) implicit integer (i-n) real + b(*) c c compute norm of b and update history c bnorm=0.0e0 bmax=0.0e0 do i=1,n if(abs(b(i)).lt.bmax) then bnorm=bnorm+(b(i)/bmax)**2 else if(b(i).ne.0.0e0) then bnorm=1.0e0+bnorm*(bmax/b(i))**2 bmax=abs(b(i)) endif enddo rl2nrm=sqrt(bnorm)*bmax return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function rl2ip(n,x,y) c implicit real (a-h,o-z) implicit integer (i-n) real + x(*),y(*) c c compute dot product c rl2ip=0.0e0 spmax=0.0e0 snmax=0.0e0 sp=0.0e0 sn=0.0e0 do i=1,n t=x(i)*y(i) if(t.ge.0.0e0) then if(t.lt.spmax) then sp=sp+t/spmax else if(t.ne.0.0e0) then sp=1.0e0+sp*(spmax/t) spmax=t endif else if(-t.lt.snmax) then sn=sn+t/snmax else sn=-(1.0e0+sn*(snmax/t)) snmax=-t endif endif enddo rl2ip=sp*spmax+sn*snmax return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pnorm(ip,rp,itnode,vx,vy,lenb,bump,maxd,nef, + u,mark,ndof,itdof,hist) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),mark(*),idof(10),itdof(ndof,*) real + bump(lenb,*),rp(100),u(maxd,*),vx(*),vy(*),t(6), 1 hist(22,*) c c compute global errors estimate on distributed mesh c irgn=ip(50) ntf=ip(1) ndf=ip(5) iord=ip(26) c do i=1,ndf mark(i)=0 enddo enorm1=0.0e0 enorm2=0.0e0 unorm1=0.0e0 unorm2=0.0e0 do i=1,ntf if(itnode(4,i).eq.irgn) then call l2gmap(i,idof,ndof,itdof) do j=1,ndof mark(idof(j))=1 enddo e1=tqual(i,itnode,vx,vy,lenb,bump,iord) e2=tqual2(i,itnode,vx,vy,lenb,bump,iord) enorm1=enorm1+e1 enorm2=enorm2+e2 c do ifn=1,nef unorm1=unorm1+eh1nrm(i,itnode,vx,vy, + u(1,ifn),idof,iord) unorm2=unorm2+el2nrm(i,itnode,vx,vy, + u(1,ifn),idof,iord) enddo endif enddo ndg=0 do i=1,ndf if(mark(i).eq.1) ndg=ndg+1 enddo t(1)=unorm2 t(2)=unorm1 t(3)=enorm2 t(4)=enorm1 t(5)=float(ndg) c call pl2ip(t,5) c enorm1=sqrt(t(4)) rp(37)=enorm1 unorm1=sqrt(t(2)) rp(38)=unorm1 rp(39)=sqrt(t(3)) rp(40)=sqrt(t(1)) ndg=int(t(5)) relerr=1.0e0 if(unorm1.ne.0.0e0) relerr=enorm1/unorm1 if(unorm1+enorm1.le.0.0e0) relerr=0.0e0 rp(53)=relerr c call hist2(hist,rp,-2,ndg) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2mtx1(nvf,ntf,vx,vy,itnode,ja,a) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ja(*) real + vx(*),vy(*),a(*) c c mass matrix for linear elements with node numbering c do i=1,ja(nvf+1)-1 a(i)=0.0e0 enddo 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=abs(x2*y3-x3*y2)/24.0e0 do k=1,3 ivk=itnode(k,i) a(ivk)=a(ivk)+2.0e0*det do j=k+1,3 call jamap(ivk,itnode(j,i),kj,jk,ja,ishift) a(jk)=a(jk)+det enddo enddo enddo anorm=0.0e0 do i=1,nvf anorm=amax1(anorm,abs(a(i))) enddo do i=1,nvf if(a(i).eq.0.0e0) a(i)=anorm enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine h1mtx1(nvf,ntf,vx,vy,itnode,ja,a) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ja(*) real + vx(*),vy(*),a(*),tx(3),ty(3),x(3),y(3) c c stiffness matrix for linear elements with node numbering c do i=1,ja(nvf+1)-1 a(i)=0.0e0 enddo ishift=0 do i=1,ntf call afmap(i,itnode,vx,vy,tx,ty,x,y,det) det=abs(det)/2.0e0 do k=1,3 ivk=itnode(k,i) a(ivk)=a(ivk)+det*(x(k)**2+y(k)**2) do j=k+1,3 call jamap(ivk,itnode(j,i),kj,jk,ja,ishift) a(jk)=a(jk)+det*(x(k)*x(j)+y(k)*y(j)) enddo enddo enddo anorm=0.0e0 do i=1,nvf anorm=amax1(anorm,abs(a(i))) enddo do i=1,nvf if(a(i).eq.0.0e0) a(i)=anorm enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2mtx(n,ntf,vx,vy,itnode,ja,a,iord,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),ja(*),idof(10) real + vx(*),vy(*),a(*),ea(10,10) c c do i=1,ja(n+1)-1 a(i)=0.0e0 enddo c c compute mass matrix c ishift=0 do i=1,ntf call l2gmap(i,idof,ndof,itdof) call elel2(i,itnode,vx,vy,ea,iord) do k=1,ndof ivk=idof(k) a(ivk)=a(ivk)+ea(k,k) do j=k+1,ndof call jacmap(ivk,idof(j),kj,jk,ja,ishift) a(jk)=a(jk)+ea(j,k) enddo enddo enddo anorm=0.0e0 do i=1,n anorm=amax1(anorm,abs(a(i))) enddo do i=1,n if(a(i).eq.0.0e0) a(i)=anorm enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine h1mtx(n,ntf,vx,vy,itnode,ja,a,iord,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),ja(*),idof(10) real + vx(*),vy(*),a(*),ea(10,10) c c do i=1,ja(n+1)-1 a(i)=0.0e0 enddo c c compute stiffness matrix for laplacian c ishift=0 do i=1,ntf call l2gmap(i,idof,ndof,itdof) call eleh1(i,itnode,vx,vy,ea,iord) do k=1,ndof ivk=idof(k) a(ivk)=a(ivk)+ea(k,k) do j=k+1,ndof call jacmap(ivk,idof(j),kj,jk,ja,ishift) a(jk)=a(jk)+ea(j,k) enddo enddo enddo anorm=0.0e0 do i=1,n anorm=amax1(anorm,abs(a(i))) enddo do i=1,n if(a(i).eq.0.0e0) a(i)=anorm enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sgscg(n,ja,a,dr,b,mxcg,eps,p,ap,z,hist,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*),hist(*),dr(*),b(*),p(*),ap(*),z(*) c c initialize c iflag=0 ispd=1 epsmin=0.5e0 relerr=0.0e0 c c compute initial residual c call mtxmlt(n,ja,a,dr,ap,ispd) do i=1,n b(i)=b(i)-ap(i) enddo c c compute initial norm of b c bnorm=rl2nrm(n,b) call hist1(hist,0,bnorm) if(bnorm.le.0.0e0) return rnorm=bnorm c c compute initial p and ap c call sgs(n,ja,a,p,b,ispd) call mtxmlt(n,ja,a,p,ap,ispd) bp=rl2ip(n,p,b) c c the main loop c do itnum=1,mxcg c c compute alpha and precondition c pap=rl2ip(n,p,ap) alpha=bp/pap do i=1,n dr(i)=dr(i)+alpha*p(i) b(i)=b(i)-alpha*ap(i) enddo call sgs(n,ja,a,z,b,ispd) c c compute coefficients c bz=rl2ip(n,z,b) beta=bz/bp bp=bz do i=1,n p(i)=z(i)+beta*p(i) enddo call mtxmlt(n,ja,a,p,ap,ispd) c c convergence test c rnorm=rl2nrm(n,b) call hist1(hist,itnum,rnorm) relerr=rnorm/bnorm if(relerr.le.eps) return call mtxmlt(n,ja,a,p,ap,ispd) enddo if(relerr.gt.epsmin) iflag=10 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sgs(n,ja,a,x,b,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),lmtx,umtx real + a(*),x(*),b(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose 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 c c solve sgs * x = b c do i=1,n x(i)=b(i) enddo c c the lower triangular system c do i=1,n s=x(i)/a(i) if(ja(i).lt.ja(i+1)) then do jj=ja(i),ja(i+1)-1 j=ja(jj) x(j)=x(j)-a(jj+lmtx)*s enddo endif enddo c c the upper triangular system c do i=n,1,-1 s=0.0e0 if(ja(i).lt.ja(i+1)) then do jj=ja(i),ja(i+1)-1 j=ja(jj) s=s+a(jj+umtx)*x(j) enddo endif x(i)=(x(i)-s)/a(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sgscg1(n,ja,a,x,r,mxcg,ap,p,z,eps) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*),ap(*),p(*),z(*),x(*),r(*) c c sgs-cg using just one matrix multiply per iteration c c initialize c zdz=0.0e0 relerr=1.0e0 do i=1,n p(i)=0.0e0 ap(i)=0.0e0 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.0e0 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.0e0) return beta=sum/zdz relerr=relerr*beta if(sqrt(relerr).lt.eps) return else beta=0.0e0 endif zdz=sum c c backward sweep c pap=0.0e0 do i=n,1,-1 ap(i)=z(i)+beta*ap(i) sum=0.0e0 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.0e0*ap(i)-p(i)*a(i)) enddo if(pap.eq.0.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine jcg(n,ja,a,x,r,mxcg,ap,p,z,eps) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*),x(*),r(*),p(*),ap(*),z(*) c c cg with identity preconditioner c c initialize c ispd=1 zdz=0.0e0 relerr=1.0e0 call mtxmlt(n,ja,a,x,ap,ispd) do i=1,n r(i)=r(i)-ap(i) p(i)=0.0e0 ap(i)=0.0e0 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.0e0) return beta=sum/zdz relerr=relerr*beta if(sqrt(relerr).lt.eps) return else beta=0.0e0 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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function dl2nrm(n,b,d,isw) c implicit real (a-h,o-z) implicit integer (i-n) real + b(*),d(*) c c compute norm of b and update history c bnorm=0.0e0 bmax=0.0e0 do i=1,n dd=0.0e0 if(isw.ge.0) then dd=d(i) else if(d(i).ne.0.0e0) dd=1.0e0/d(i) endif if(abs(b(i)).lt.bmax) then bnorm=bnorm+dd*(b(i)/bmax)**2 else if(b(i).ne.0.0e0) then bnorm=dd+bnorm*(bmax/b(i))**2 bmax=abs(b(i)) endif enddo dl2nrm=sqrt(bnorm)*bmax return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function dl2ip(n,x,y,d,isw) c implicit real (a-h,o-z) implicit integer (i-n) real + x(*),y(*),d(*) c c compute dot product c dl2ip=0.0e0 spmax=0.0e0 snmax=0.0e0 sp=0.0e0 sn=0.0e0 do i=1,n t=0.0e0 if(isw.ge.0) then t=x(i)*y(i)*d(i) else if(d(i).ne.0.0e0) t=x(i)*y(i)/d(i) endif if(t.ge.0.0e0) then if(t.lt.spmax) then sp=sp+t/spmax else if(t.ne.0.0e0) then sp=1.0e0+sp*(spmax/t) spmax=t endif else if(-t.lt.snmax) then sn=sn+t/snmax else sn=-(1.0e0+sn*(snmax/t)) snmax=-t endif endif enddo dl2ip=sp*spmax+sn*snmax return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkgm(ndf,ntf,vx,vy,gm,itnode,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),idof(10) real + vx(*),vy(*),gm(*),bw(10) save bw data bw/1.0e0,1.0e0,1.0e0,3.0e0,3.0e0,3.0e0,3.0e0,3.0e0, + 3.0e0,6.0e0/ c c compute diag of gram matrix c do i=1,ndf gm(i)=0.0e0 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=abs(x2*y3-x3*y2)/12.0e0 c call l2gmap(i,idof,ndof,itdof) do j=1,ndof gm(idof(j))=gm(idof(j))+det*bw(j) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine centre(x1,y1,x2,y2,x3,y3,xc,yc) c implicit real (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.0e0 if(det.ne.0.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine midpt(x1,y1,x2,y2,xc,yc,x,y) c implicit real (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.0e0 y=(y1+y2)/2.0e0 c=(x+x1-2.0e0*xc)*(x1-x)+(y+y1-2.0e0*yc)*(y1-y) if(c.le.0.0e0) return dy=y1-y2 dx=x1-x2 b=(x-xc)*dy-(y-yc)*dx a=dx*dx+dy*dy a=c/(abs(b)+sqrt(b*b+a*c)) if(b.lt.0.0e0) a=-a x=x+a*dy y=y-a*dx return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function ceps(ibit) c implicit real (a-h,o-z) implicit integer (i-n) integer + eptst save isw,sveps,jbit data isw,jbit,sveps/1,0,0.0e0/ c c compute machine epsilon c if(isw.eq.0) then ceps=sveps ibit=jbit return else ibit=-4 eps=1.0e0 3 eps1=1.0e0+eps if(eptst(eps1).eq.1) then ceps=2.0e0**(-ibit) sveps=ceps jbit=ibit isw=0 return else eps=eps/2.0e0 ibit=ibit+1 go to 3 endif endif end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function eptst(x) c implicit real (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.0e0) then eptst=1 else eptst=0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine gfptr(itype,itask,maxd,iuu,iu0,iudot,iu0dot, + ievr,ievl,ivx0,ivy0,ium,iuc,ngf,nef) c implicit real (a-h,o-z) implicit integer (i-n) c iprob=iabs(itype) c c set grid function pointers c iuu=1 c iu0=1 iudot=1 iu0dot=1 ievr=1 ievl=1 c ivx0=1 ivy0=1 c ium=1 iuc=1 c ngf=1 nef=1 c if(iprob.eq.1) then ium=iuu+maxd ngf=2 if(itask.eq.9) nef=2 else if(iprob.eq.3) then iu0=iuu+maxd iudot=iu0+maxd iu0dot=iudot+maxd ievr=iu0dot+maxd ievl=ievr+maxd ngf=6 c c ngf=6 in case the user changes ispd=1 to ispd=0 after init. c else if(iprob.eq.4) then ium=iuu+maxd iudot=ium+maxd ngf=3 nef=2 else if(iprob.eq.5) then ium=iuu+maxd iuc=ium+maxd ngf=3 nef=3 else if(iprob.eq.6) then iu0=iuu+maxd ivx0=iu0+maxd ivy0=ivx0+maxd ngf=4 nef=2 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lsptr(iprob,ispd,iord,ndf,ndd,nvdd,ibeg,iend, + ihh,isu,ism,ia0,ih0,ig0,isu0,ism0,ibb,idd, 1 ird,ipp,idl,ibdlwr,ibdupr,idu,idum,iduc) c implicit real (a-h,o-z) implicit integer (i-n) c c matrices c ihh=ibeg isu=ibeg ism=ibeg maxjas=ndf*4 if(iord.eq.2) maxjas=ndf*25/4 if(iord.eq.3) maxjas=ndf*81/9 maxjan=2*maxjas-ndf c c interface matrices c ia0=ibeg ih0=ibeg ig0=ibeg isu0=ibeg ism0=ibeg c c vectors c ibb=ibeg idd=ibeg ird=ibeg ipp=ibeg idl=ibeg ibdlwr=ibeg ibdupr=ibeg c c increments c idu=ibeg idum=ibeg iduc=ibeg c c c if(iabs(iprob).eq.1) then ibb=ibeg ipp=ibb+ndf idu=ipp+ndf idum=idu+ndf iend=idum+ndf else if(iabs(iprob).eq.2) then ibb=ibeg idu=ibb+ndf ibdlwr=idu+ndf ibdupr=ibdlwr+ndf iend=ibdupr+ndf else if(iabs(iprob).eq.3) then ibb=ibeg ipp=ibb+ndf if(iprob.eq.3) then idd=ipp+ndf idu=idd+ndf else idd=ipp+ndf+ndd idu=idd+ndf+ndd endif ird=idu+ndf idum=ird+ndf iend=idum+ndf else if(iabs(iprob).eq.4) then ibb=ibeg idd=ibb+ndf ird=idd+ndf if(iprob.eq.4) then idl=ird+ndf ipp=idl+ndf else idl=ird+ndf+ndd ipp=idl+ndf+ndd endif idu=ipp+ndf idum=idu+ndf ihh=idum+ndf iend=ihh+maxjas else if(iabs(iprob).eq.5) then ibb=ibeg ipp=ibb+ndf idl=ipp+ndf ibdlwr=idl+ndf ibdupr=ibdlwr+ndf idu=ibdupr+ndf idum=idu+ndf iduc=idum+ndf ihh=iduc+ndf isu=ihh+maxjas ism=isu+maxjan iend=ism+maxjan else if(iabs(iprob).eq.6) then ibb=ibeg idu=ibb+ndf iend=idu+ndf endif c if(iprob.gt.0) return c maxja0=9*iord*nvdd/2 maxa0s=maxja0 maxa0n=2*maxja0-nvdd ia0=iend if(ispd.eq.1) then iend=ia0+maxa0s else iend=ia0+maxa0n endif c if(iabs(iprob).eq.4) then ih0=iend iend=ih0+maxa0s else if(iabs(iprob).eq.5) then ih0=iend ig0=ih0+maxa0s isu0=ig0+maxa0s ism0=isu0+maxa0n iend=ism0+maxa0n endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine stor(ip) c implicit real (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(7)) itask=ip(9) lenw=ip(82) maxt=ip(83) maxv=ip(84) nproc=ip(49) ifirst=ip(6) iord=ifirst ip(26)=iord ndof=(iord+1)*(iord+2)/2 maxd=maxv*iord**2 ip(89)=maxd if(nproc.gt.1) then ss=sqrt(float(maxv)) maxpth=int(7.5e0*ss)*nproc else maxpth=0 endif ip(81)=maxpth c c determine grid functions c call gfptr(iprob,itask,maxd,iuu,iu0,iudot,iu0dot, + ievr,ievl,ivx0,ivy0,ium,iuc,ngf,nef) c c pointers c iuu=1 if(nproc.gt.1) ngf=ngf+1 c itdof=iuu+ngf*maxd jtime=itdof+maxt*ndof jhist=jtime+150 jpath=jhist+660 ka=jpath+606 jstat=ka+1000 iee=jstat+10*nproc ipath=iee+maxt iz=ipath+6*maxpth c ip(76)=nef ip(77)=ngf c ip(90)=iuu ip(91)=itdof 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)=82 else ip(25)=0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine memptr(newptr,length,type,ibegin,iend,iflag) c implicit real (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=82 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=82 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=82 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dtpick(ntf,ndf,itnode,vx,vy,u,u0,rp,z,iflag,isw, + gm,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*) real + vx(*),vy(*),u(*),u0(*),rp(100),z(*),gm(*) 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.0e0 fudge=0.9e0 iflag=3 c c the main loop c if(isw.eq.1) go to 30 call mkgm(ndf,ntf,vx,vy,gm,itnode,ndof,itdof) do i=1,ndf z(i)=u(i)-u0(i) enddo unorm=dl2nrm(ndf,u,gm,1) utnorm=dl2nrm(ndf,z,gm,1) if(unorm.gt.0.0e0) 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=amax1(dtmin,deltat/ratio, + deltat*tmtol*fudge/utnorm) iflag=-1 endif else if(utnorm.gt.0.0e0) then c c increase step (slight cutback if utnorm > tmtol*fudge) c deltat=amin1(dtmax,deltat*ratio, + deltat*tmtol*fudge/utnorm) deltat=amax1(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.0e0*deltat.ge.tend) then if(tend-tcur-deltat.le.2.0e0*deltat/ratio) + deltat=tend-tcur-2.0e0*deltat/ratio if(iflag.ne.-3) then iflag=1 else iflag=-5 endif endif rp(47)=deltat return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bisect(rp,isw,rqup0,rqlow0) c implicit real (a-h,o-z) implicit integer (i-n) real + rp(100) save tol,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 tol=amax1(1.0e-6,ceps(ibit)*1.0e2) sigup=rp(71) siglow=0.0e0 signew=sigup sigold=siglow rqup=rp(25) rqlow=rp(35) rqnew=rqup rqold=rqlow rqmx=amax1(abs(rqup),abs(rqlow)) isw=1 else sigold=signew signew=rp(71) rqold=rqnew rqnew=rp(25) if(rqnew*rqlow.lt.0.0e0) 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.0e0 ds=abs(sigup-siglow) c c convergence test c if(sigma.eq.signew.or.ds.lt.tol*abs(sigma).or. + abs(rqnew).lt.tol*rqmx) then isw=-1 return endif c if(rqnew-rqold.ne.0.0e0) then qq=signew-rqnew*(signew-sigold)/(rqnew-rqold) qlow=abs(qq-siglow) qup=abs(qq-sigup) if(amax1(qlow,qup).le.ds*(1.0e0-tol)) then sigma=qq else if(qlow.le.ds*tol) then sigma=siglow+(sigup-siglow)*tol else if(qup.le.ds*tol) then sigma=sigup+(siglow-sigup)*tol endif endif rp(71)=sigma return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tpick(ip,rp,vx,vy,itnode,ndof,itdof,u,um,uc, + usv,umsv,ucsv,ja,a,h,g,su,sm,b,d,p,dl,bdlwr,bdupr, 1 du,dum,duc,gm,adu,hdu,z,isw,itnum) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ja(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),u(*),um(*),uc(*),usv(*),umsv(*), 1 ucsv(*),a(*),h(*),g(*),su(*),sm(*),b(*),d(*),p(*), 2 dl(*),bdlwr(*),bdupr(*),du(*),dum(*),duc(*),gm(*), 3 adu(*),hdu(*),z(*) save rlsv,step0 c c this routine carries out a bisection c or secant iteration c c isw = 0 initialize c > 0 update c < 0 converged c ntf=ip(1) ndf=ip(5) iprob=ip(7) itask=ip(9) c c compute norms c call mkgm(ndf,ntf,vx,vy,gm,itnode,ndof,itdof) if(iprob.eq.1.and.itask.eq.9) then call norm1(ip,rp,isw,itnum,u,du,um,dum, + ja,a,b,p,adu,hdu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) enddo step0=1.0e0 endif else if(iprob.eq.2) then call norm2(ip,rp,isw,itnum,u,du,ja,a,b,adu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) enddo step0=stepmx(ndf,u,du,bdlwr,bdupr) endif else if(iprob.eq.3) then call norm3(ip,rp,isw,itnum,u,du,ja,a,b,p,d,adu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) enddo rlsv=rp(21) step0=1.0e0 endif else if(iprob.eq.4) then call norm4(ip,rp,isw,itnum,u,um,du,dum,ja,a,h,b,p, + d,dl,adu,hdu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) enddo rlsv=rp(21) rllwr=rp(4) rlupr=rp(5) delta=rp(72) if(delta.lt.0.0e0) then step0=amin1((rllwr-rlsv)/delta,1.0e0) else if(delta.gt.0.0e0) then step0=amin1((rlupr-rlsv)/delta,1.0e0) else step0=1.0e0 endif endif else if(iprob.eq.5) then call norm5(ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,a,h,g,su,sm,b,p,dl,adu,hdu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) ucsv(i)=uc(i) enddo step0=stepmx(ndf,uc,duc,bdlwr,bdupr) endif else call norm6(ip,rp,isw,itnum,u,du,ja,a,b,adu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) enddo step0=1.0e0 endif endif c c compute new step c call cstep(rp,0,isw,step0) if(isw.eq.-1) return c c update solution with current step c step=rp(52) delta=rp(72) if(iprob.eq.1.and.itask.eq.9) then do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob.eq.3) then rp(21)=rlsv+step*delta else if(iprob.eq.4) then rp(21)=rlsv+step*delta do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob.eq.5) then do i=1,ndf um(i)=umsv(i)+step*dum(i) uc(i)=ucsv(i)+step*duc(i) enddo endif do i=1,ndf u(i)=usv(i)+step*du(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cstep(rp,iexsw,isw,step0) c implicit real (a-h,o-z) implicit integer (i-n) real + rp(100) save ksw,ibit,tol,eps,snew,sold,sleft,sright, + dnew,dold,fnew,fold 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 initialization c if(isw.le.0) then eps=1.0e2*ceps(ibit) tol=1.e-2 snew=0.0e0 sleft=0.0e0 sright=0.0e0 dnew=rp(58) fnew=rp(56)**2/2.0e0 step=rp(52) ratio=rp(57) step=step/(step+(1.0e0-step)*ratio/100.0e0) if(step0.lt.1.0e0) then frac=amax1(0.75e0,0.98e0-rp(63)) step=amin1(step,frac*step0) endif if(iexsw.eq.1) call exstep(step) isw=1 ksw=0 rp(52)=step return endif c c the case isw > 0 c isw=isw+1 sold=snew snew=rp(52) dold=dnew dnew=rp(58) fold=fnew fnew=rp(56)**2/2.0e0 relres=rp(56) ratio=rp(57) relerr=rp(54) c if(sright.le.0.0e0.or.dnew.gt.0.0e0.or.ksw.eq.1) then sright=snew if(dnew.le.0.0e0) then ksw=1 else ksw=0 endif else sleft=snew endif c c sufficient decrease c ds=sright-sleft if(ds.le.tol.and.dnew.le.0.0e0) isw=-1 if(ratio.le.1.0e0-eps*snew.and.dnew.le.0.0e0) isw=-1 if(amin1(relerr,relres).le.eps) isw=-1 if(isw.eq.-1) return c c bisection step c rp(52)=(sleft+sright)/2.0e0 if(ksw.eq.0) then c c secant step c if(dold.eq.dnew) return step=snew-dnew*(snew-sold)/(dnew-dold) else c c cubic interpolation step c ff=-(fold-fnew)*6.0e0/(sold-snew) gg=(dold+dnew) a=ff+gg*3.0e0 b=-(ff+2.0e0*(gg+dnew)) c=dnew if(snew.gt.sold) then a=-a b=-b c=-c endif rr=amax1(abs(a),abs(b),abs(c))*eps c c quadratic case c if(abs(a).lt.rr) then c c b > 0 for min c if(b.le.rr) return step=snew-(c/b)*(sold-snew) else c c cubic case c b=b/(2.0e0*a) c=c/a discr=b**2-c if(discr.le.0.0e0) return d=sqrt(discr) if(b.lt.0.0e0) then c c the min occurs for 2*a r + b > 0 (not b/2a above) c if(a.gt.0.0e0) then r=-(b-d) else r=-c/(b-d) endif else if(a.lt.0.0e0) then r=-(b+d) else r=-c/(b+d) endif endif step=snew+r*(sold-snew) endif endif c c choose alternative c dl=abs(step-sleft) dr=abs(step-sright) if(amax1(dl,dr).le.ds*(1.0e0-tol)) then rp(52)=step else if(dl.le.ds*tol) then rp(52)=sleft+ds*tol else if(dr.le.ds*tol) then rp(52)=sright-ds*tol endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function stepmx(n,u,du,bdlwr,bdupr) c implicit real (a-h,o-z) implicit integer (i-n) real + u(*),du(*),bdlwr(*),bdupr(*) c c compute maximum step for interior point c stepmx=1.0e0 do i=1,n if(du(i).lt.0.0e0) then stepmx=amin1((bdlwr(i)-u(i))/du(i),stepmx) else if(du(i).gt.0.0e0) then stepmx=amin1((bdupr(i)-u(i))/du(i),stepmx) endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm1(ip,rp,isw,itnum,u,du,um,dum, + ja,a,b,p,adu,adum,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + u(*),du(*),a(*),b(*),adu(*),gm(*),z(*),um(*), 1 dum(*),p(*),rp(100),adum(*) save bnorm0,bmnrm0,blast,bmlast,ibit,eps data bnorm0,bmnrm0,blast,bmlast,ibit/ + 0.0e0,0.0e0,0.0e0,0.0e0,0/ c c compute norms -- iprob=1 c ndf=ip(5) ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 c call mtxml0(ndf,ja,a,du,adu,z,ispd) bnorm=dl2nrm(ndf,b,gm,-1) gamma=dl2ip(ndf,b,adu,gm,-1) c call mtxml0(ndf,ja,a,dum,adum,z,jspd) bmnorm=dl2nrm(ndf,p,gm,-1) gammam=dl2ip(ndf,p,adum,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c enorm=dl2nrm(ndf,du,gm,1) unorm=dl2nrm(ndf,u,gm,1) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 emnorm=dl2nrm(ndf,dum,gm,1) umnorm=dl2nrm(ndf,um,gm,1) relerm=1.0e0 if(umnorm.gt.emnorm) relerm=emnorm/umnorm if(umnorm+emnorm.le.0.0e0) relerm=0.0e0 rp(54)=relerr+relerm rp(54)=relerr c if(bnorm.le.0.0e0) bnorm=eps if(bmnorm.le.0.0e0) bmnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 bmnrm0=amax1(bmnorm,rp(60)) rp(60)=bmnrm0 endif else rp(56)=bnorm/bnorm0+bmnorm/bmnrm0 rp(57)=bnorm/blast+bmnorm/bmlast rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-gamma/bnorm0**2 dmdnew=-gammam/bmnrm0**2 rp(58)=ddnew+dmdnew rp(58)=ddnew blast=bnorm bmlast=bmnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm2(ip,rp,isw,itnum,u,du,ja,a,b,adu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + rp(100),u(*),du(*),a(*),b(*),adu(*),gm(*),z(*) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=2 c ndf=ip(5) ispd=ip(8) c call mtxml0(ndf,ja,a,du,adu,z,ispd) bnorm=dl2nrm(ndf,b,gm,-1) gamma=dl2ip(ndf,b,adu,gm,-1) c if(isw.eq.0) then eps=1.0e2*ceps(ibit) c enorm=dl2nrm(ndf,du,gm,1) unorm=dl2nrm(ndf,u,gm,1) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 rp(54)=relerr c if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-gamma/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm3(ip,rp,isw,itnum,u,du,ja,a,b,p,d,adu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + rp(100),u(*),du(*),a(*),b(*),p(*),d(*), 1 adu(*),gm(*),z(*) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=3 c ndf=ip(5) ispd=ip(8) rl=rp(21) scale=sqrt(rp(68)) scleqn=rp(67)*scale thetal=rp(69)*scale thetar=rp(70)*scale delta=rp(72) drdrl=rp(73) c c compute adu c call mtxml0(ndf,ja,a,du,adu,z,ispd) ss=thetar*(rl2ip(ndf,p,du)+drdrl*delta)+thetal*delta bnorm=sqrt(dl2nrm(ndf,b,gm,-1)**2+scleqn**2) gamma=dl2ip(ndf,b,adu,gm,-1) bd=dl2ip(ndf,b,d,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c c compute relerr c enorm=dl2nrm(ndf,du,gm,1) unorm=dl2nrm(ndf,u,gm,1) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 rlerr=1.0e0 if(abs(rl).gt.abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta).eq.0.0e0) rlerr=0.0e0 rp(54)=relerr+rlerr c if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=(-gamma+ss*scleqn+bd*delta)/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm4(ip,rp,isw,itnum,u,um,du,dum,ja,a,h,b,p, + d,dl,adu,hdu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + rp(100),u(*),um(*),du(*),dum(*),a(*),h(*),b(*),p(*), 1 d(*),dl(*),adu(*),hdu(*),gm(*),z(*) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=4 c ndf=ip(5) ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 scleqn=rp(67) seqdot=rp(74) delta=rp(72) rl=rp(21) c c matrix multiplies c call mtxml0(ndf,ja,h,du,hdu,z,1) call mtxml0(ndf,ja,a,dum,adu,z,jspd) do i=1,ndf hdu(i)=hdu(i)+adu(i)-delta*dl(i) enddo call mtxml0(ndf,ja,a,du,adu,z,ispd) do i=1,ndf adu(i)=adu(i)-delta*d(i) enddo bnorm=dl2nrm(ndf,b,gm,-1) gamma=dl2ip(ndf,b,adu,gm,-1) pnorm=dl2nrm(ndf,p,gm,-1) pgamma=dl2ip(ndf,p,hdu,gm,-1) bnorm=sqrt(scleqn**2+bnorm**2+pnorm**2) c=-rl2ip(ndf,du,dl)-rl2ip(ndf,dum,d)-seqdot*delta c if(isw.le.0) then eps=1.0e2*ceps(ibit) c uunorm=dl2nrm(ndf,u,gm,1) umnorm=dl2nrm(ndf,um,gm,1) eunorm=dl2nrm(ndf,du,gm,1) emnorm=dl2nrm(ndf,dum,gm,1) c c compute relerr c rulerr=1.0e0 if(uunorm.gt.eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm.le.0.0e0) rulerr=0.0e0 rmlerr=1.0e0 if(umnorm.gt.emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm.le.0.0e0) rmlerr=0.0e0 rlerr=1.0e0 if(abs(rl).gt.abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta).eq.0.0e0) rlerr=0.0e0 rp(54)=rulerr+rmlerr+rlerr c if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-gamma-pgamma-c*scleqn rp(58)=ddnew/bnorm0**2 blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm5(ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,a,h,g,su,sm,b,p,dl,adu,hdu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + u(*),um(*),uc(*),du(*),dum(*),duc(*),a(*),h(*),g(*), 1 su(*),sm(*),b(*),p(*),dl(*),adu(*),hdu(*),gm(*),z(*), 2 rp(100) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=5 c ndf=ip(5) ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 c c first equation c call mtxml0(ndf,ja,h,du,hdu,z,1) call mtxml0(ndf,ja,a,dum,adu,z,jspd) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo call mtxml0(ndf,ja,su,duc,adu,z,0) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo umip=dl2ip(ndf,p,hdu,gm,-1) bmnorm=dl2nrm(ndf,p,gm,-1) if(isw.le.0) then umnorm=dl2nrm(ndf,um,gm,1) emnorm=dl2nrm(ndf,dum,gm,1) endif c c second equation c call mtxml0(ndf,ja,sm,duc,hdu,z,0) call mtxml0(ndf,ja,a,du,adu,z,ispd) do i=1,ndf adu(i)=adu(i)+hdu(i) enddo uip=dl2ip(ndf,b,adu,gm,-1) bnorm=dl2nrm(ndf,b,gm,-1) if(isw.le.0) then uunorm=dl2nrm(ndf,u,gm,1) eunorm=dl2nrm(ndf,du,gm,1) endif c c third equation c call mtxml0(ndf,ja,g,duc,hdu,z,1) call mtxml0(ndf,ja,sm,dum,adu,z,-1) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo call mtxml0(ndf,ja,su,du,adu,z,-1) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo ucip=dl2ip(ndf,dl,hdu,gm,-1) bcnorm=dl2nrm(ndf,dl,gm,-1) bnorm=sqrt(bcnorm**2+bnorm**2+bmnorm**2) if(isw.le.0) then eps=1.0e2*ceps(ibit) c ucnorm=dl2nrm(ndf,uc,gm,1) ecnorm=dl2nrm(ndf,duc,gm,1) c c compute relerr c rulerr=1.0e0 if(uunorm.gt.eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm.le.0.0e0) rulerr=0.0e0 rmlerr=1.0e0 if(umnorm.gt.emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm.le.0.0e0) rmlerr=0.0e0 rclerr=1.0e0 if(ucnorm.gt.ecnorm) rclerr=ecnorm/ucnorm if(ucnorm+ecnorm.le.0.0e0) rclerr=0.0e0 rp(54)=rulerr+rmlerr+rclerr c if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-(uip+umip+ucip)/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm6(ip,rp,isw,itnum,u,du,ja,a,b,adu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + u(*),du(*),a(*),b(*),adu(*),gm(*),z(*),rp(100) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=6 c ndf=ip(5) ispd=ip(8) c c compute adu c call mtxml0(ndf,ja,a,du,adu,z,ispd) bnorm=dl2nrm(ndf,b,gm,-1) gamma=dl2ip(ndf,b,adu,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c enorm=dl2nrm(ndf,du,gm,1) unorm=dl2nrm(ndf,u,gm,1) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 rp(54)=relerr c if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-gamma/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tpickd(ip,rp,vx,vy,itnode,u,um,uc, + usv,umsv,ucsv,ja,a,h,g,su,sm,b,d,p,dl,bdlwr,bdupr, 1 du,dum,duc,ipath,jequv,ja0,a0,h0,g0,su0,sm0,nn,gf, 2 adu,adum,hdu,gduc,sudu,suduc,smdum,smduc, 3 gm,z,isw,itnum,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ja(*), 1 ipath(6,*),jequv(*),ja0(*),itdof(ndof,*) real + rp(100),vx(*),vy(*),u(*),um(*),uc(*),usv(*),umsv(*), 1 ucsv(*),a(*),h(*),g(*),su(*),sm(*),b(*),d(*),p(*), 2 dl(*),bdlwr(*),bdupr(*),du(*),dum(*),duc(*), 3 a0(*),h0(*),g0(*),su0(*),sm0(*),gf(nn,*),adu(*), 4 adum(*),hdu(*),gduc(*),sudu(*),suduc(*), 5 smdum(*),smduc(*),gm(*),z(*) save rlsv,step0 c c this routine carries out a bisection c or secant iteration c c isw = 0 initialize c > 0 update c < 0 converged c ndf=ip(5) newntf=ip(27) iprob=iabs(ip(7)) itask=ip(9) c c compute norms c call mkgm(ndf,newntf,vx,vy,gm,itnode,ndof,itdof) if(iprob.eq.1.and.itask.eq.9) then call norm1p(ip,rp,isw,itnum,u,du,um,dum,ja,a,b,p, + ipath,jequv,ja0,a0,nn,gf,adu,adum,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) enddo step0=1.0e0 endif else if(iprob.eq.2) then call norm2p(ip,rp,isw,itnum,u,du,ja,a,b, + ipath,jequv,ja0,a0,nn,gf,adu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) enddo step0=stepmx(ndf,u,du,bdlwr,bdupr) endif else if(iprob.eq.3) then call norm3p(ip,rp,isw,itnum,u,du,ja,a,b,p,d, + ipath,jequv,ja0,a0,nn,gf,adu,gm,z) c if(isw.le.0) then do i=1,ndf usv(i)=u(i) enddo rlsv=rp(21) step0=1.0e0 endif else if(iprob.eq.4) then call norm4p(ip,rp,isw,itnum,u,um,du,dum,ja,a,h,b,p,d,dl, + ipath,jequv,ja0,a0,h0,nn,gf,adu,adum,hdu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) enddo rlsv=rp(21) rllwr=rp(4) rlupr=rp(5) delta=rp(72) if(delta.lt.0.0e0) then step0=amin1((rllwr-rlsv)/delta,1.0e0) else if(delta.gt.0.0e0) then step0=amin1((rlupr-rlsv)/delta,1.0e0) else step0=1.0e0 endif endif else if(iprob.eq.5) then call norm5p(ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,a,h,g,su,sm,b,p,dl,ipath,jequv,ja0,a0,h0,g0,su0,sm0, 1 nn,gf,adu,adum,gduc,hdu,smdum,smduc,sudu,suduc,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) ucsv(i)=uc(i) enddo step0=stepmx(ndf,uc,duc,bdlwr,bdupr) endif else call norm6p(ip,rp,isw,itnum,u,du,ja,a,b, + ipath,jequv,ja0,a0,nn,gf,adu,gm,z) if(isw.le.0) then do i=1,ndf usv(i)=u(i) enddo step0=1.0e0 endif endif c c compute new step c call cstep(rp,1,isw,step0) if(isw.eq.-1) return c c update solution with current step c step=rp(52) delta=rp(72) if(iprob.eq.1.and.itask.eq.9) then do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob.eq.3) then rp(21)=rlsv+step*delta else if(iprob.eq.4) then rp(21)=rlsv+step*delta do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob.eq.5) then do i=1,ndf um(i)=umsv(i)+step*dum(i) uc(i)=ucsv(i)+step*duc(i) enddo endif do i=1,ndf u(i)=usv(i)+step*du(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm1p(ip,rp,isw,itnum,u,du,um,dum,ja,a,b,p, + ipath,jequv,ja0,a0,nn,gf,adu,adum,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(6,*),jequv(*),ja0(*) real + u(*),du(*),a(*),b(*),a0(*),gf(nn,*),um(*),dum(*), 1 p(*),adu(*),adum(*),gm(*),z(*),t(20),rp(100) save bnorm0,bmnrm0,blast,bmlast,ibit,eps data bnorm0,bmnrm0,blast,bmlast,ibit/ + 0.0e0,0.0e0,0.0e0,0.0e0,0/ c c compute norms -- iprob=-1 c ndf=ip(5) ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 newndf=ip(30) ndd=ip(33) ndi=ip(36) iord=ip(26) c nproc=ip(49) irgn=ip(50) num=4 iin=1 iout=iin+num*nn icnt=iout+num*nn ioff=icnt+nproc c c compute adu c call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + du,adu,z,ispd) call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + dum,adum,z,jspd) ii=ipath(3,irgn)-1 do i=1,ndd gf(ii+i,1)=adu(i) gf(ii+i,2)=-du(i) gf(ii+i,3)=adum(i) gf(ii+i,4)=-dum(i) enddo call exbdy(ipath,gf,nn,num,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adu,z,ispd,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),adum,z,jspd,iord,1) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1) t(2)=dl2ip(newndf,p,p,gm,-1) t(3)=dl2ip(newndf,adu,b,gm,-1) t(4)=dl2ip(newndf,adum,p,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c t(5)=dl2ip(newndf,du,du,gm,1) t(6)=dl2ip(newndf,dum,dum,gm,1) t(7)=dl2ip(newndf,u,u,gm,1) t(8)=dl2ip(newndf,um,um,gm,1) c call pl2ip(t,8) c enorm=sqrt(t(5)) emnorm=sqrt(t(6)) unorm=sqrt(t(7)) umnorm=sqrt(t(8)) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 relerm=1.0e0 if(umnorm.gt.emnorm) relerm=emnorm/umnorm if(umnorm+emnorm.le.0.0e0) relerm=0.0e0 rp(54)=relerr+relerm rp(54)=relerr c bnorm=sqrt(t(1)) if(bnorm.le.0.0e0) bnorm=eps bmnorm=sqrt(t(2)) if(bmnorm.le.0.0e0) bmnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 bmnrm0=amax1(bmnorm,rp(60)) rp(60)=bmnrm0 endif else call pl2ip(t,4) bnorm=sqrt(t(1)) bmnorm=sqrt(t(2)) rp(56)=bnorm/bnorm0+bmnorm/bmnrm0 rp(57)=bnorm/blast+bmnorm/bmlast rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-t(3)/bnorm0**2 dmdnew=-t(4)/bmnrm0**2 rp(58)=ddnew+dmdnew rp(58)=ddnew blast=bnorm bmlast=bmnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm2p(ip,rp,isw,itnum,u,du,ja,a,b, + ipath,jequv,ja0,a0,nn,gf,adu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(6,*),jequv(*),ja0(*) real + rp(100),u(*),du(*),a(*),b(*),a0(*), 1 gf(nn,*),adu(*),gm(*),z(*),t(10) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=-2 c ndf=ip(5) ispd=ip(8) newndf=ip(30) ndd=ip(33) ndi=ip(36) nproc=ip(49) irgn=ip(50) iord=ip(26) c c compute adu c iin=1 iout=iin+2*nn icnt=iout+2*nn ioff=icnt+nproc call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + du,adu,z,ispd) ii=ipath(3,irgn)-1 do i=1,ndd gf(ii+i,1)=adu(i) gf(ii+i,2)=-du(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adu,z,ispd,iord,1) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1) t(2)=dl2ip(newndf,adu,b,gm,-1) if(isw.le.0) then eps=1.0e2*ceps(ibit) c t(3)=dl2ip(newndf,du,du,gm,1) t(4)=dl2ip(newndf,u,u,gm,1) c call pl2ip(t,4) c c enorm=sqrt(t(3)) unorm=sqrt(t(4)) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 rp(54)=relerr c bnorm=sqrt(t(1)) if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,2) c bnorm=sqrt(t(1)) rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-t(2)/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm3p(ip,rp,isw,itnum,u,du,ja,a,b,p,d, + ipath,jequv,ja0,a0,nn,gf,adu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(6,*),jequv(*),ja0(*) real + rp(100),u(*),du(*),a(*),b(*),p(*),d(*), 1 a0(*),gf(nn,*),adu(*),gm(*),z(*),t(10) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=-3 c ndf=ip(5) ispd=ip(8) newndf=ip(30) ndd=ip(33) ndi=ip(36) nproc=ip(49) irgn=ip(50) iord=ip(26) c rl=rp(21) scale=sqrt(rp(68)) scleqn=rp(67)*scale thetal=rp(69)*scale thetar=rp(70)*scale delta=rp(72) drdrl=rp(73) c c compute adu c iin=1 iout=iin+2*nn icnt=iout+2*nn ioff=icnt+nproc c call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + du,adu,z,ispd) ii=ipath(3,irgn)-1 do i=1,ndd gf(ii+i,1)=adu(i) gf(ii+i,2)=-du(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adu,z,ispd,iord,1) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1) t(2)=dl2ip(newndf,adu,b,gm,-1) t(3)=dl2ip(newndf,b,d,gm,-1) t(4)=rl2ip(newndf,p,du) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c t(5)=dl2ip(newndf,du,du,gm,1) t(6)=dl2ip(newndf,u,u,gm,1) call pl2ip(t,6) c c compute relerr c enorm=sqrt(t(5)) unorm=sqrt(t(6)) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 rlerr=1.0e0 if(abs(rl).gt.abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta).eq.0.0e0) rlerr=0.0e0 rp(54)=relerr+rlerr c bnorm=sqrt(t(1)+scleqn**2) if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,4) bnorm=sqrt(t(1)+scleqn**2) rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ss=thetar*(t(4)+drdrl*delta)+thetal*delta ddnew=(-t(2)+ss*scleqn+t(3)*delta)/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm4p(ip,rp,isw,itnum,u,um,du,dum,ja,a,h,b,p,d,dl, + ipath,jequv,ja0,a0,h0,nn,gf,adu,adum,hdu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),ipath(6,*),jequv(*),ja0(*) real + rp(100),u(*),um(*),du(*),dum(*),a(*),h(*),b(*),p(*), 1 d(*),dl(*),a0(*),h0(*),gf(nn,*),adu(*),adum(*),hdu(*), 2 gm(*),z(*),t(20) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=-4 c ndf=ip(5) ispd=ip(8) newndf=ip(30) ndd=ip(33) ndi=ip(36) scleqn=rp(67) seqdot=rp(74) delta=rp(72) rl=rp(21) iord=ip(26) 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(3,irgn)-1 call blkmlt(irgn,nproc,newndf,ndf,ja,h,ipath,ja0,h0, + du,hdu,z,1) jspd=1 if(ispd.ne.1) jspd=-1 call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + dum,adum,z,jspd) call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + du,adu,z,ispd) c do i=1,ndd gf(ii+i,1)=hdu(i) gf(ii+i,2)=-du(i) gf(ii+i,3)=adum(i) gf(ii+i,4)=-dum(i) gf(ii+i,5)=adu(i) enddo call exbdy(ipath,gf,nn,num,z(iin),z(iout),z(icnt),z(ioff)) c call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,1),hdu,z,1,iord,-1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),adum,z,jspd,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,5),adu,z,ispd,iord,1) c do i=1,newndf hdu(i)=hdu(i)+adum(i)-delta*dl(i) adu(i)=adu(i)-delta*d(i) enddo c t(1)=dl2ip(newndf,b,b,gm,-1) t(2)=dl2ip(newndf,p,p,gm,-1) t(3)=rl2ip(newndf,du,dl) t(4)=rl2ip(newndf,dum,d) t(5)=dl2ip(newndf,b,adu,gm,-1) t(6)=dl2ip(newndf,p,hdu,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) t(7)=dl2ip(newndf,u,u,gm,1) t(8)=dl2ip(newndf,um,um,gm,1) t(9)=dl2ip(newndf,du,du,gm,1) t(10)=dl2ip(newndf,dum,dum,gm,1) c call pl2ip(t,10) c c c compute relerr c uunorm=sqrt(t(7)) umnorm=sqrt(t(8)) eunorm=sqrt(t(9)) emnorm=sqrt(t(10)) rulerr=1.0e0 if(uunorm.gt.eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm.le.0.0e0) rulerr=0.0e0 rmlerr=1.0e0 if(umnorm.gt.emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm.le.0.0e0) rmlerr=0.0e0 rlerr=1.0e0 if(abs(rl).gt.abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta).eq.0.0e0) rlerr=0.0e0 rp(54)=rulerr+rmlerr+rlerr c bnorm=sqrt(scleqn**2+t(1)+t(2)) if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,6) bnorm=sqrt(scleqn**2+t(1)+t(2)) rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c c=-t(3)-t(4)-seqdot*delta ddnew=-t(5)-t(6)-c*scleqn rp(58)=ddnew/bnorm0**2 blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm5p(ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,a,h,g,su,sm,b,p,dl,ipath,jequv,ja0,a0,h0,g0,su0,sm0, 1 nn,gf,adu,adum,gduc,hdu,smdum,smduc,sudu,suduc,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(6,*),jequv(*),ja0(*) real + u(*),um(*),uc(*),du(*),dum(*),duc(*),a(*),h(*),rp(100), 1 g(*),su(*),sm(*),b(*),p(*),dl(*),a0(*),h0(*),g0(*), 2 su0(*),sm0(*),gf(nn,*),adu(*),adum(*),gduc(*),hdu(*), 3 smdum(*),smduc(*),sudu(*),suduc(*),gm(*),z(*),t(15) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=-5 c ndf=ip(5) ispd=ip(8) newndf=ip(30) ndd=ip(33) ndi=ip(36) iord=ip(26) 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(3,irgn)-1 jspd=1 if(ispd.ne.1) jspd=-1 c call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + du,adu,z,ispd) call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + dum,adum,z,jspd) call blkmlt(irgn,nproc,newndf,ndf,ja,h,ipath,ja0,h0, + du,hdu,z,1) call blkmlt(irgn,nproc,newndf,ndf,ja,g,ipath,ja0,g0, + duc,gduc,z,1) call blkmlt(irgn,nproc,newndf,ndf,ja,sm,ipath,ja0,sm0, + duc,smduc,z,0) call blkmlt(irgn,nproc,newndf,ndf,ja,sm,ipath,ja0,sm0, + dum,smdum,z,-1) call blkmlt(irgn,nproc,newndf,ndf,ja,su,ipath,ja0,su0, + duc,suduc,z,0) call blkmlt(irgn,nproc,newndf,ndf,ja,su,ipath,ja0,su0, + dum,sudu,z,-1) c do i=1,ndd gf(ii+i,1)=hdu(i) gf(ii+i,2)=-du(i) gf(ii+i,3)=adum(i) gf(ii+i,4)=-dum(i) gf(ii+i,5)=adu(i) gf(ii+i,6)=gduc(i) gf(ii+i,7)=-duc(i) gf(ii+i,8)=smdum(i) gf(ii+i,9)=smduc(i) gf(ii+i,10)=sudu(i) gf(ii+i,11)=suduc(i) enddo call exbdy(ipath,gf,nn,num,z(iin),z(iout),z(icnt),z(ioff)) c call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,5),adu,z,ispd,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),adum,z,jspd,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,1),hdu,z,1,iord,-1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,g0,gf(1,7),gf(1,6),gduc,z,1,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,sm0,gf(1,7),gf(1,9),smduc,z,0,iord,-1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,sm0,gf(1,4),gf(1,8),smdum,z,-1,iord,-1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,su0,gf(1,7),gf(1,11),suduc,z,0,iord,-1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,su0,gf(1,2),gf(1,10),sudu,z,-1,iord,-1) c do i=1,ndf hdu(i)=hdu(i)+adum(i)+suduc(i) adu(i)=adu(i)+smduc(i) gduc(i)=gduc(i)+smdum(i)+sudu(i) enddo c t(1)=dl2ip(newndf,p,p,gm,-1) t(2)=dl2ip(newndf,b,b,gm,-1) t(3)=dl2ip(newndf,dl,dl,gm,-1) t(4)=dl2ip(newndf,p,hdu,gm,-1) t(5)=dl2ip(newndf,b,adu,gm,-1) t(6)=dl2ip(newndf,dl,gduc,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c t(7)=dl2ip(newndf,um,um,gm,1) t(8)=dl2ip(newndf,u,u,gm,1) t(9)=dl2ip(newndf,uc,uc,gm,1) t(10)=dl2ip(newndf,dum,dum,gm,1) t(11)=dl2ip(newndf,du,du,gm,1) t(12)=dl2ip(newndf,duc,duc,gm,1) c call pl2ip(t,12) c c c compute relerr c umnorm=sqrt(t(7)) uunorm=sqrt(t(8)) ucnorm=sqrt(t(9)) emnorm=sqrt(t(10)) eunorm=sqrt(t(11)) ecnorm=sqrt(t(12)) rulerr=1.0e0 if(uunorm.gt.eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm.le.0.0e0) rulerr=0.0e0 rmlerr=1.0e0 if(umnorm.gt.emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm.le.0.0e0) rmlerr=0.0e0 rclerr=1.0e0 if(ucnorm.gt.ecnorm) rclerr=ecnorm/ucnorm if(ucnorm+ecnorm.le.0.0e0) rclerr=0.0e0 rp(54)=rulerr+rmlerr+rclerr c bnorm=sqrt(t(1)+t(2)+t(3)) if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,6) bnorm=sqrt(t(1)+t(2)+t(3)) rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-(t(4)+t(5)+t(6))/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine norm6p(ip,rp,isw,itnum,u,du,ja,a,b, + ipath,jequv,ja0,a0,nn,gf,adu,gm,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*),ipath(6,*),jequv(*),ja0(*) real + u(*),du(*),a(*),b(*),a0(*),gf(nn,*), 1 adu(*),gm(*),z(*),t(10),rp(100) save bnorm0,blast,ibit,eps data bnorm0,blast,ibit/0.0e0,0.0e0,0/ c c compute norms -- iprob=-6 c ndf=ip(5) ispd=ip(8) newndf=ip(30) ndd=ip(33) ndi=ip(36) iord=ip(26) 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,newndf,ndf,ja,a,ipath,ja0,a0, + du,adu,z,ispd) ii=ipath(3,irgn)-1 do i=1,ndd gf(ii+i,1)=adu(i) gf(ii+i,2)=-du(i) enddo call exbdy(ipath,gf,nn,2,z(iin),z(iout),z(icnt),z(ioff)) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),adu,z,ispd,iord,1) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1) t(2)=dl2ip(newndf,adu,b,gm,-1) c if(isw.le.0) then eps=1.0e2*ceps(ibit) c t(3)=dl2ip(newndf,du,du,gm,1) t(4)=dl2ip(newndf,u,u,gm,1) c call pl2ip(t,4) c enorm=sqrt(t(3)) unorm=sqrt(t(4)) relerr=1.0e0 if(unorm.gt.enorm) relerr=enorm/unorm if(unorm+enorm.le.0.0e0) relerr=0.0e0 rp(54)=relerr c bnorm=sqrt(t(1)) if(bnorm.le.0.0e0) bnorm=eps if(itnum.eq.1) then bnorm0=amax1(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,2) bnorm=sqrt(t(1)) rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast endif c ddnew=-t(2)/bnorm0**2 rp(58)=ddnew blast=bnorm c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ctheta(ip,rp,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100) real + 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.0e0) iflag=1 theta=0.0e0 else if(rltrgt.eq.rlstrt) then if(r0dot.eq.0.0e0) iflag=1 theta=2.0e0 else iflag=1 theta=1.0e0 endif rl0=rp(31) r0=rp(32) thetal=(2.0e0-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.0e0) rp(68)=1.0e0 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.0e0 rp(21)=rltrgt rp(22)=rtrgt rp(23)=1.0e0 rp(24)=1.0e0 c rp(31)=rltrgt rp(32)=rtrgt rp(33)=1.0e0 rp(34)=1.0e0 endif rl0dot=rp(33) r0dot=rp(34) if(itask.eq.3.or.itask.eq.5) then if(rl0dot.eq.0.0e0) iflag=1 theta=0.0e0 else if(itask.eq.4.or.itask.eq.6) then if(r0dot.eq.0.0e0) iflag=1 theta=2.0e0 else if(itask.eq.7) then if(r0dot.eq.0.0e0.and.rl0dot.eq.0.0e0) iflag=1 theta=1.0e0 endif c thetal=(2.0e0-theta)*rl0dot thetar=theta*r0dot seqdot=thetar*r0dot+thetal*rl0dot rp(69)=thetal rp(70)=thetar rp(71)=0.0e0 rp(74)=seqdot if(scale.eq.0.0e0) rp(68)=1.0e0 else rp(69)=0.0e0 rp(70)=0.0e0 rp(71)=0.0e0 rp(74)=0.0e0 rp(68)=1.0e0 iflag=1 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine updpth(path,isw,itype,rp) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 enddo enddo else if(isw.eq.0) then num=int(path(101,1)) else num=int(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=int(path(num,6)) if(jtype.ne.7) path(num,6)=float(itype) else path(num,6)=float(itype) endif path(101,1)=float(num) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine updtm(path,isw,itype,rp) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=int(path(101,1)) else num=int(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.0e0 path(num,5)=0.0e0 path(num,6)=float(itype) path(101,1)=float(num) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine updip(path,isw,itype,rp,ip) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100) real + 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.0e0 enddo enddo else if(isw.eq.0) then num=int(path(101,1)) else num=int(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)=float(ip(38)) else path(num,3)=float(ip(2)) endif path(num,4)=0.0e0 path(num,5)=0.0e0 path(num,6)=float(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)=float(num) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine hist1(hist,itnum,bnorm) c implicit real (a-h,o-z) implicit integer (i-n) real + 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)=float(itnum) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine hist2(hist,rp,iadapt,ndf) c implicit real (a-h,o-z) implicit integer (i-n) real + rp(100),hist(22,*) c c hist(*, 1) = ndf 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) = mg convergence history -- dual function c hist(*,19) = ndg (mpi) c hist(*,20) = iadapt (mpi) c hist(*,21) = error in h1 norm (mpi) c hist(*,22) = error in l2 norm (mpi) 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(ndf.eq.0) then numhst=30 do j=1,numhst do i=1,mxhist+2 hist(i,j)=0.0e0 enddo enddo return endif c ishift=0 if(iadapt.eq.-2) ishift=18 num=int(hist(mxhist+2,ishift+1)) if(num.eq.mxhist) then do j=ishift+1,ishift+4 do i=1,mxhist-1 hist(i,j)=hist(i+1,j) enddo enddo num=mxhist-1 endif c num=num+1 hist(num,ishift+1)=float(ndf) hist(num,ishift+2)=float(iadapt) hist(num,ishift+3)=rp(37) hist(num,ishift+4)=rp(39) hist(mxhist+2,ishift+1)=float(num) hist(mxhist+2,ishift+3)=rp(38) hist(mxhist+2,ishift+4)=rp(40) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine hist3(hist,itnum,bnorm,enorm) c implicit real (a-h,o-z) implicit integer (i-n) real + 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)=float(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)=float(itnum) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pstat1(ntf,nproc,pstat,itnode,e,itype) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) real + 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.0e0 pstat(2,i)=0.0e0 enddo do i=1,ntf k=min0(itnode(4,i),nproc) k=max0(1,k) pstat(1,k)=pstat(1,k)+1.0e0 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.0e0 pstat(4,i)=0.0e0 enddo do i=1,ntf k=min0(itnode(4,i),nproc) k=max0(1,k) pstat(3,k)=pstat(3,k)+1.0e0 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.0e0 enddo enddo return endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cequv1(nvf,nbf,ibndry,iequv,isw) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c implicit real (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) real 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 call cedge5(nbf,itedge,ibedge,0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tstvty(i,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3),iv(3), 1 vtype(*),elist(*),tlist(*),vlist(*),corner(9) real + 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=abs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(abs(aa-1.0e0).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=abs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(abs(aa-1.0e0).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(abs(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=abs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(abs(aa-1.0e0).lt.angmin) vtype(i)=6 else tol=1.0e-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(amin1(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(abs(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=abs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(abs(aa-1.0e0).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(abs(theta2-theta1).le.arcmax) vtype(i)=8 endif 40 ii=vlist(len+2) vtype(ii)=vtype(i) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tstvt5(i,itnode,ibndry,itedge, + vtype,ibase,irgn,tlist,elist,len) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3),iv(3), 1 elist(*),tlist(*),jv(3),jb(3),ity(3),vtype(*) save index 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine updhp(i,len,p,q,qual,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setgr(ntf,nvf,nbf,itnode,ibndry,ja,lenja) c implicit real (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 kmin=min0(itnode(index(2,j),i),itnode(index(3,j),i)) ja(kmin+1)=ja(kmin+1)+1 enddo enddo do i=1,nbf if(ibndry(4,i).ne.0) then kmin=min0(ibndry(1,i),ibndry(2,i)) ja(kmin+1)=ja(kmin+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(kmin) jmax=ja(kmin+1)-1 do jj=jmin,jmax if(ja(jj).eq.0) then ja(jj)=kmax go to 70 else if(ja(jj).eq.kmax) then go to 70 endif enddo 70 continue enddo c c sort indices c do i=1,nvf len=ja(i+1)-ja(i) call ihp(ja(ja(i)),len) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setgr1(ntf,n,ndof,itdof,ja,link,maxja,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),link(*),itdof(ndof,*),idof(10) c c construct ja array c iflag=1 c do i=1,n ja(i)=0 link(i)=0 enddo next=n+2 do it=1,ntf call l2gmap(it,idof,ndof,itdof) do j=1,ndof do k=j+1,ndof irow=min0(idof(j),idof(k)) icol=max0(idof(j),idof(k)) 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 enddo c c now make new ja c jai=n+2 do i=1,n itemp=ja(i) ja(i)=jai jai=jai+itemp enddo ja(n+1)=jai c do i=1,n next=link(i) do m=ja(i),ja(i+1)-1 ii=next next=link(next) link(ii)=m enddo enddo do i=ja(1),ja(n+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,n len=ja(i+1)-ja(i) call ihp(ja(ja(i)),len) enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkmtx(n,ispd,ja,a,b,q,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),iblock(2),q(*) real + 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,i10)') i,iblock(i) enddo do i=1,n z(q(i))=b(i) enddo do i=1,n write(unit=iunit,fmt='(i10,e14.7)') i,z(i) enddo do i=1,n write(unit=iunit,fmt='(i10,i10,e14.7)') i,i,a(i) enddo do i=1,n do j=ja(i),ja(i+1)-1 write(unit=iunit,fmt='(i10,i10,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='(i10,i10,e14.7)') ja(j),i,a(j+ii) enddo enddo close(unit=iunit) return 10 stop 3421 end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100) real + 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(82) iz=max0(ip(99),ip(84),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) ip(5)=0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine trichk(ntf,nvf,nbf,ncf,itnode,ibndry, + vx,vy,xm,ym,lenz,z,area,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*) real + 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=82 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), + z(list),iflag) if(iflag.ne.0) return call ckgeom(ntf,itnode,ibndry,z(itedge),z(ibedge),vx,vy,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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ckgeom(ntf,itnode,ibndry,itedge,ibedge,vx,vy,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),index(3,3), 1 ibedge(2,*) real + vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c check geometry c do i=1,ntf do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 m=itedge(j,i)-4*k else if(itedge(j,i).lt.0) then iedge=-itedge(j,i) if(ibndry(4,iedge).ne.0) go to 10 if(ibedge(1,iedge)/4.eq.i) then k=ibedge(2,iedge)/4 m=ibedge(2,iedge)-4*k else k=ibedge(1,iedge)/4 m=ibedge(2,iedge)-4*k endif else stop 2221 endif if(k.lt.i) go to 10 iv2=itnode(index(2,j),i) iv3=itnode(index(3,j),i) ivi=itnode(j,i) ivk=itnode(m,k) qi=geom(ivi,iv2,iv3,vx,vy) qk=geom(ivk,iv2,iv3,vx,vy) if(qi*qk.ge.0.0e0) then iflag=-32 return endif 10 enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cnhnr(nvf,ntf,nbf,nh,nr,ibndry,list,mark,iflag) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine orient(nvf,ntf,nbf,itnode,ibndry,vx,vy,list,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),list(2,*),index(3,3) real + 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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bdychk(ibndry,nvf,nbf,ncf,vx,vy,xm,ym,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*) real + vx(*),vy(*),xm(*),ym(*) c c check ibndry array c iflag=0 eps=1.0e-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.0e0 yc=ym(ic)-(vy(i1)+vy(i2))/2.0e0 if(abs(xc*dx+yc*dy).gt.abs(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=abs(theta1-theta2) if(aa.gt.0.5e0+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=sqrt((vx(i1)-vx(i2))**2+(vy(i1)-vy(i2))**2) dj=sqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2) if(abs(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(abs(ri-rj).gt.eps*(abs(ri)+abs(rj))) then iflag=-46 return endif if(abs(ai-aj).gt.eps*(ai+aj)) then iflag=-46 return endif endif endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sklchk(ntr,nvr,nbr,ncr,itnode,ibndry, + vx,vy,xm,ym,diam,lenz,z,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*) real + 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=82 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 jb=1 list=jb+3*nbr ibdy=list+nvr+1+2*nbr inum=ibdy+nvr iornt=inum+nbr c call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,1, + z(jb),z(list),z(ibdy),z(inum),z(iornt),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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rgnchk(ntr,itnode,ibndry,vx,vy,xm,ym,jb,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*) real + vx(*),vy(*),xm(*),ym(*),x(20),y(20) c c check for counterclockwise orientientation of regions c iflag=0 pi=3.141592653589793e0 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=abs(thetav-thetab)*8.0e0 m1=max0(int(aa),1) dtheta=(thetav-thetab)/float(m1+1) ang=(thetab+float(m1)*dtheta)*pi x(2)=xm(km)+r*cos(ang) y(2)=ym(km)+r*sin(ang) endif x(3)=vx(kv) y(3)=vy(kv) last=1 bsum=2.0e0 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=abs(thetaa-thetav)*8.0e0 m1=max0(int(aa),1) dtheta=(thetaa-thetav)/float(m1+1) do m=1,m1 ang=(thetav+float(m)*dtheta)*pi x(m+2)=xm(km)+r*cos(ang) y(m+2)=ym(km)+r*sin(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.0e0 enddo kv=ka enddo c c bsum = 0 for counterclockwise, bsum = 4 for clockwise c if(abs(bsum).gt.0.01e0) then iflag=-54 return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine symtst(ntr,itnode,ibndry,vx,vy,xm,ym,jb,diam,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*) real + vx(*),vy(*),xm(*),ym(*) c c check symmetry specifications in itnode c iflag=0 eps=1.0e-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*float(inc))/dd a12=(dxi*dyj-dyi*dxj*float(inc))/dd a21=-a12*float(inc) a22=a11*float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sklutl(isw,vx,vy,xm,ym,itnode,ibndry,ip,w,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100) real + vx(*),vy(*),xm(*),ym(*),w(*) c c utility function for skeleton creation c ntf=ip(1) nvf=ip(2) nbf=ip(4) lenw=ip(82) maxv=ip(84) maxb=ip(86) c c create an itnode array from other skeleton data c if(isw.eq.0) then jb=1 list=jb+3*nbf ibdy=list+nvf+1+2*nbf inum=ibdy+nvf iornt=inum+nbf ii=iornt+nbf if(ii.gt.lenw) then iflag=82 return endif c call makjb(nvf,nbf,ntf,vx,vy,xm,ym,ibndry,itnode,0, + w(jb),w(list),w(ibdy),w(inum),w(iornt),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=82 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+3*nbf ii=list+4*nvf+2*nvf+1 if(ii.gt.lenw) then iflag=82 return endif call fndsym(ntf,nvf,nbf,vx,vy,xm,ym,ibndry,w(jb), + itnode,w(list),iflag) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dvedge(ntf,nvf,nbf,maxv,maxb,vx,vy,xm,ym, + ibndry,itnode,list,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),list(2,*) real + vx(*),vy(*),xm(*),ym(*) c iflag=0 pi=3.141592653589793e0 angmax=1.0e0/8.0e0+1.0e-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.0e0 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.0e0) 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.0e0 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=abs(theta2-theta1)/angmax np=int(d) c c add new points on circular arc c if(np.gt.0) then if(nvf+np.gt.maxv) then iflag=84 return endif if(nbf+np.gt.maxb) then iflag=85 return endif nvsave=nvf nbsave=nbf dt=(theta2-theta1)/float(np+1) do j=1,np arg=(theta1+dt*float(j))*pi nvf=nvf+1 vx(nvf)=xc+radius*cos(arg) vy(nvf)=yc+radius*sin(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fndsym(ntf,nvf,nbf,vx,vy,xm,ym,ibndry,jb, + itnode,list,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jb(*),itnode(5,*),list(*) real + vx(*),vy(*),xm(*),ym(*) data ibit/0/ c c find symmetry in skeleton c iflag=0 c ibdy=nvf+2*nbf+2 inum=ibdy+nvf iornt=inum+nbf c call makjb(nvf,nbf,ntf,vx,vy,xm,ym,ibndry,itnode,1, + jb,list,list(ibdy),list(inum),list(iornt),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.0e0 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*float(inc))/dd a12=(dxi*dyj-dyi*dxj*float(inc))/dd a21=-a12*float(inc) a22=a11*float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setval c implicit real (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,mim,mil 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 mim=7 mil=8 c c qxy c kf=1 kf1=2 kf2=3 ksk=4 kad=5 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mdinit(n,ispd,ja,ka,lenz,iz,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*),iz(*) c iflag=0 c call chkja(n,ja,iz,iflag) if(iflag.ne.0) return c do i=1,100 ka(i)=0 enddo lenja=ja(n+1)-1 if(ispd.eq.1) then lena=lenja else lena=2*lenja-(n+1) endif c japtr=1 iaptr=1 iqptr=japtr+lenja juptr=iqptr+n iuptr=iaptr+lena c i1=1 i2=i1+n i3=i2+n i4=i3+n i5=i4+n jc=i5+n maxjc=lenz-jc+1 if(maxjc.lt.2*(lenja-n-1)+n+1) then iflag=82 return endif c c min degree ordering c call ja2jc(n,ja(japtr),iz(jc)) call md(n,iz(jc),iz(i1),ja(iqptr),lenu0, + iz(i2),iz(i3),iz(i4),iz(i5)) c c reorder ja and a c call ja2ja0(n,ja(japtr),ja(iqptr),iz(jc)) c ka(1)=n ka(3)=iqptr ka(4)=japtr ka(5)=iaptr ka(6)=juptr ka(7)=iuptr ka(13)=lenu0 ka(14)=ispd c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ja2ja0(n,ja,q,ja0) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),q(*),ja0(*) c c compute ja0ed list of new column indices c do i=1,n+1 ja0(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 else irow=i endif ja0(irow+1)=ja0(irow+1)+1 enddo enddo c ja0(1)=n+2 do i=1,n ja0(i+1)=ja0(i)+ja0(i+1) enddo c 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 else irow=i icol=j endif ja0(ja0(irow))=icol ja0(irow)=ja0(irow)+1 enddo enddo c do i=n,1,-1 ja0(i+1)=ja0(i) enddo ja0(1)=n+2 c do i=1,ja0(n+1)-1 ja(i)=ja0(i) enddo do i=1,n len=ja(i+1)-ja(i) call ihp(ja(ja(i)),len) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mgilu0(maxja,ja,maxa,a,ncfact,maxlvl,ka,dtol,z,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*) real + a(*),z(*) c iflag=0 c n=ka(1) japtr=ka(4) iaptr=ka(5) juptr=ka(6) iuptr=ka(7) ispd=ka(14) c maxlvl=max0(1,maxlvl) maxlvl=min0(19,maxlvl) if(dtol.le.0.0e0) maxlvl=1 rdtol=abs(dtol) ncfact=max0(ncfact,4) c i1=1 i2=i1+n i3=i2+n i4=i3+n i5=i4+n c c ilu c lenju=maxja-juptr+1 lenu=maxa-iuptr+1 a(n+1)=canorm(n,ispd,ja,a) c call sfilu(n,ja(japtr),a(iaptr),lenju,ja(juptr), + lenu,a(iuptr),z(i1),z(i2),z(i3),z(i4),z(i5), 1 ispd,rdtol,maxlvl,ka,ncfact,iflag) c ka(17)=juptr+lenju ka(18)=iuptr+lenu c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mginit(n,ispd,maxja,ja,maxa,a,ncfact, + maxlvl,ka,dtol,lenz,z,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*) real + a(*),z(*) c c ka( 1) = n c ka( 2) = lvl c ka( 3) = iqptr c ka( 4) = japtr c ka( 5) = iaptr c ka( 6) = juptr c ka( 7) = iuptr c ka( 8) = nsum c ka( 9) = lenja c ka(10) = lenju c ka(11) = lenju1 c ka(12) = lenje c ka(13) = lenge c ka(14) = ispd c ka(17) = used ja c ka(18) = used a c ka(19) = jmtx c ka(20+*) = level ptrs c ka(40+*) = ja storage c ka(60+*) = ju storage c ka(80+*) = je storage c iflag=0 c call chkja(n,ja,z,iflag) if(iflag.ne.0) return c maxlvl=max0(1,maxlvl) maxlvl=min0(19,maxlvl) if(dtol.le.0.0e0) maxlvl=1 rdtol=abs(dtol) ncfact=max0(ncfact,4) c lenja=ja(n+1)-1 if(ispd.eq.1) then lena=lenja else lena=2*lenja-(n+1) endif c japtr=1 iaptr=1 iqptr=japtr+lenja juptr=iqptr+n iuptr=iaptr+lena c i1=1 i2=i1+n i3=i2+n i4=i3+n i5=i4+n jc=i5+n maxjc=lenz-jc+1 if(maxjc.lt.2*(lenja-n-1)+n+1) then iflag=82 return endif c c min degree ordering c call ja2jc(n,ja(japtr),z(jc)) call md(n,z(jc),z(i1),ja(iqptr),lenu0,z(i2),z(i3),z(i4),z(i5)) c c reorder ja and a c call ja2ja(n,ja(japtr),ja(iqptr),z(jc),ispd,a(iaptr)) c c ilu c lenju=maxja-juptr+1 lenu=maxa-iuptr+1 a(n+1)=canorm(n,ispd,ja,a) call sfilu(n,ja(japtr),a(iaptr),lenju,ja(juptr), + lenu,a(iuptr),z(i1),z(i2),z(i3),z(i4),z(i5), 1 ispd,rdtol,maxlvl,ka,ncfact,iflag) if(iflag.ne.0) return c ka(3)=iqptr ka(4)=japtr ka(5)=iaptr ka(6)=juptr ka(7)=iuptr ka(13)=lenu0 ka(14)=ispd ka(17)=juptr+lenju ka(18)=iuptr+lenu c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mgilu(ja,a,ka,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*) real + a(*),z(*) c c lenz=5*n c n=ka(1) japtr=ka(4) iaptr=ka(5) juptr=ka(6) iuptr=ka(7) ispd=ka(14) c i1=1 i2=i1+n i3=i2+n i4=i3+n i5=i4+n c a(n+1)=canorm(n,ispd,ja,a) c call snfilu(ka,ja(japtr),a(iaptr),ja(juptr),a(iuptr), + z(i1),z(i2),z(i3),z(i4),z(i5)) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mg(ispd,mxcg,eps1,ja,a,dr,br,ka,ising, + relerr,iflag,z,hist) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),ja(*) real + a(*),dr(*),br(*),z(*),hist(*) data ibit/0/ c c lenz=4*n+2*ns (ispd.eq.1) c lenz=9*n+2*ns (ispd.ne.1) c iflag=0 c n=ka(1) iqptr=ka(3) japtr=ka(4) iaptr=ka(5) juptr=ka(6) iuptr=ka(7) nsum=ka(8) c eps2=ceps(ibit)*8.0e0 eps=amax1(eps1,eps2) epsi=1.0e0/amin1(eps,eps2) 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 ie=iz+nsum c c c do i=1,n dr(ja(iqptr+i-1))=br(i) enddo if(ising.eq.1) then sum=0.0e0 do i=1,n sum=sum+dr(i) enddo sum=sum/float(n) do i=1,n dr(ja(iqptr+i-1))=dr(ja(iqptr+i-1))-sum enddo endif c c if(ispd.eq.1) then call cscg(n,ispd,mxcg,eps,epsi,ja(japtr),a(iaptr), + ja(juptr),a(iuptr),br,dr,z(i1),z(i2),z(i3),z(i4), 1 hist,ka,z(iz),z(ie),relerr,iflag) c else call csbcg(n,ispd,mxcg,eps,epsi,ja(japtr),a(iaptr), + ja(juptr),a(iuptr),br,dr,z(j5),z(i1),z(i2),z(i3), 1 z(i4),z(j1),z(j2),z(j3),z(j4), 2 hist,ka,z(iz),z(ie),relerr,iflag) c endif if(iflag.eq.0) then do i=1,n dr(i)=br(ja(iqptr+i-1)) enddo if(ising.eq.1) then sum=0.0e0 do i=1,n sum=sum+dr(i) enddo sum=sum/float(n) do i=1,n dr(i)=dr(i)-sum enddo endif else do i=1,n dr(i)=0.0e0 enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mg0(ispd,ja,a,dr,br,ka,ising,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),ja(*) real + a(*),dr(*),br(*),z(*) c n=ka(1) iqptr=ka(3) japtr=ka(4) iaptr=ka(5) juptr=ka(6) iuptr=ka(7) nsum=ka(8) c c lenz=nsum+n c iz=1 ie=iz+nsum c do i=1,n dr(ja(iqptr+i-1))=br(i) enddo if(ising.eq.1) then sum=0.0e0 do i=1,n sum=sum+dr(i) enddo sum=sum/float(n) do i=1,n dr(ja(iqptr+i-1))=dr(ja(iqptr+i-1))-sum enddo endif c call cycle(ispd,ka,ja(japtr),a(iaptr),ja(juptr),a(iuptr), + br,dr,z(iz),z(ie)) c do i=1,n dr(i)=br(ja(iqptr+i-1)) enddo if(ising.eq.1) then sum=0.0e0 do i=1,n sum=sum+dr(i) enddo sum=sum/float(n) do i=1,n dr(i)=dr(i)-sum enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sfilu(n,ja,a,maxju,ju,maxu,u,tu,tl,list,mark, + indx,ispd,dtol,maxlvl,ka,ncfact,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),list(*),mark(*),indx(*),amtx,umtx,ka(*) real + a(*),u(*),tu(*),tl(*) data ibit/0/ c c sparse numeric factorization c if(min0(maxju,maxu).lt.n+1) then iflag=82 return endif c c set up levels c rk=alog10(float(n))/alog10(float(ncfact)) lvl=min0(maxlvl,int(rk)) ka(21)=1 nsum=n do j=1,lvl-1 m=(n+1-ka(20+j))/ncfact ka(21+j)=n+1-m nsum=nsum+m enddo ka(21+lvl)=n+1 ka(1)=n ka(2)=lvl ka(8)=nsum c if(lvl.gt.1) then nn=n else nn=0 endif if(ispd.ne.1) then amtx=ja(n+1)-ja(1) umtx=(maxu-n-1)/2 lenju=min0(maxju,umtx+n+1+nn) else amtx=0 umtx=0 lenju=min0(maxju,maxu+nn) endif c itmax=3 itnum=0 fact=2.0e0 eps=ceps(ibit) bias=1.0e2 if(dtol.gt.0.0e0) then rtol=amax1(eps,dtol) u(n+1)=a(n+1) else rtol=0.0e0 u(n+1)=0.0e0 eps=0.0e0 endif 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 level=0 do i=1,n if(i.ge.ka(21+level)) then if(level.gt.0) then ka(40+level)=ija ka(60+level)=iju ka(80+level)=ije endif ija=0 iju=0 ije=0 level=level+1 endif stol=rtol*bias**(float(i-n)/float(n))+eps 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 ija=ija+ja(i+1)-ja(i) 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 su=u(j1)/u(k) sl=u(j1+umtx)/u(k) 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 make ju for this row c next=ju(i) do j=1,len if(next+nn.gt.lenju) then rtol=rtol*fact itnum=itnum+1 if(itnum.gt.1) then lvl=1 ka(2)=lvl ka(8)=n ka(21+lvl)=n+1 nn=0 endif write(6,*) 'sfilu',n,i,itnum,lvl,rtol if(itnum.lt.itmax) go to 5 iflag=82 return endif k=mark(i) tt=eltest(tu(i),tu(k),tl(k),a(k)) if(tt.ge.stol) then ju(next)=k next=next+1 iju=iju+1 else if(nn.gt.0.and.tt.gt.eps) then ju(next)=-k next=next+1 ije=ije+1 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 u(i)=tu(i) do jj=ju(i),ju(i+1)-1 j=iabs(ju(jj)) u(jj)=tu(j) u(jj+umtx)=tl(j) enddo c if(ju(i).lt.ju(i+1).and. + abs(u(i)).gt.abs(a(i))*eps) then j1=ju(i) j2=ju(i+1)-1 15 j=ju(j1) if(j.le.0) then j1=j1+1 if(j1.le.j2) go to 15 else list(i)=list(j) list(j)=i indx(i)=j1 endif endif enddo iflag=0 ka(40+lvl)=ija ka(60+lvl)=iju ka(80+lvl)=ije c c shift u for non symmetric case c maxju=ju(n+1)-1+nn jmtx=ju(n+1)-1 if(ispd.ne.1) then nnz=ju(n+1)-ju(1) imtx=umtx+ju(1)-1 kmtx=ju(n+1)-1 do i=1,nnz u(kmtx+i)=u(imtx+i) enddo maxu=ju(n+1)-1+nnz else maxu=ju(n+1)-1 endif c c set up error pointers c lenje=0 if(nn.gt.0) then do i=1,n ju(jmtx+i)=ju(i) do j=ju(i),ju(i+1)-1 if(ju(j).gt.0) go to 20 ju(j)=-ju(j) ju(jmtx+i)=j+1 enddo 20 lenje=lenje+ju(jmtx+i)-ju(i) enddo else jmtx=0 endif ka(9)=ja(n+1)-1 ka(10)=maxju ka(11)=ju(n+1)-1-lenje ka(12)=lenje ka(19)=jmtx return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function eltest(a11,a12,a21,a22) c implicit real (a-h,o-z) implicit integer (i-n) c bd=amin1(abs(a11),abs(a22)) if(bd.eq.0.0e0) then eltest=1.0e0 else eltest=amax1(abs(a21),abs(a12))/bd endif c c bd=a11*a22 c if(bd.eq.0.0e0) then c eltest=1.0e0 c else c eltest=amax1(abs(a21),abs(a12))/sqrt(abs(bd)) c endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine snfilu(ka,ja,a,ju,u,list,indx,mark,tl,tu) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),list(*),indx(*),mark(*),amtx,umtx,ka(*) real + a(*),u(*),tu(*),tl(*) c c sparse numeric factorization c n=ka(1) ispd=ka(14) jmtx=ka(19) if(ispd.ne.1) then amtx=ja(n+1)-ja(1) umtx=ju(n+1)-ju(1) else amtx=0 umtx=0 endif c u(n+1)=a(n+1) unorm=u(n+1) eps=ceps(ibit) 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.0e0 tl(j)=0.0e0 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 su=u(j1)/u(k) sl=u(j1+umtx)/u(k) c do jj=j1,j2 j=ju(jj) if(mark(j).eq.1) 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+jmtx).lt.ju(i+1).and. + abs(u(i)).gt.abs(a(i))*eps) then j=ju(ju(i+jmtx)) list(i)=list(j) list(j)=i indx(i)=ju(i+jmtx) endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cscg(n,ispd,mxcg,eps,epsi,ja,a,ju,u, + dr,br,pr,apr,zr,azr,hist,ka,z,e,relerr,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*),ju(*) real + a(*),hist(*),dr(*),br(*),pr(*),apr(*), 1 zr(*),azr(*),z(*),u(*),e(*) c c initialize c iflag=0 epsmin=0.5e0 relerr=0.0e0 c c compute initial norm of b c do i=1,n dr(i)=0.0e0 enddo brnorm=rl2nrm(n,br) call hist1(hist,0,brnorm) if(brnorm.le.0.0e0) return rrnorm=brnorm c c compute initial pr and apr c call cycle(ispd,ka,ja,a,ju,u,pr,br,z,e) call mtxmlt(n,ja,a,pr,apr,ispd) bp=rl2ip(n,pr,br) if(bp.eq.0.0e0) 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.0e0) then do i=1,n azr(i)=azr(i)/zscale enddo endif call cycle(ispd,ka,ja,a,ju,u,zr,azr,z,e) 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(abs(pap)*rrnorm.lt.zscale) then qscale=tstpiv(n,bp,bz,pap,zaz,br,apr,azr) if(qscale.lt.abs(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.0e0) 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,ka,ja,a,ju,u,apr,br,z,e) 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=10 c return 200 iflag=10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine csbcg(n,ispd,mxcg,eps,epsi,ja,a,ju,u,dr,br,bl, + pr,apr,zr,azr,pl,apl,zl,azl,hist,ka,z,e,relerr,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*),ju(*) real + a(*),hist(*),dr(*),br(*),pr(*),apr(*),zr(*),azr(*), 1 bl(*),pl(*),apl(*),zl(*),azl(*),z(*),u(*),e(*) c c initialize c iflag=0 epsmin=0.5e0 relerr=0.0e0 c c compute initial norm of b c do i=1,n dr(i)=0.0e0 bl(i)=br(i) enddo jspd=-(1+ispd) brnorm=rl2nrm(n,br) blnorm=rl2nrm(n,bl) call hist1(hist,0,brnorm) if(amin1(brnorm,blnorm).le.0.0e0) return rrnorm=brnorm c c compute initial pr and apr c call cycle(ispd,ka,ja,a,ju,u,pr,br,z,e) call cycle(jspd,ka,ja,a,ju,u,pl,bl,z,e) 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.0e0) 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.0e0) then do i=1,n azr(i)=azr(i)/zscale azl(i)=azl(i)/zscale enddo endif call cycle(ispd,ka,ja,a,ju,u,zr,azr,z,e) call cycle(jspd,ka,ja,a,ju,u,zl,azl,z,e) 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(abs(pap)*rrnorm.lt.zscale) then qscale=tstpiv(n,bp,bz,pap,zaz,br,apr,azr) if(qscale.lt.abs(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,ka,ja,a,ju,u,apr,br,z,e) call cycle(jspd,ka,ja,a,ju,u,apl,bl,z,e) 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=10 c return 200 iflag=10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function tstpiv(n,bp,bz,pap,zaz,br,apr,azr) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 qmax=0.0e0 do i=1,n dq=alpha*br(i)-(alphap*apr(i)+alphaz*azr(i)) if(abs(dq).lt.qmax) then qscale=qscale+(dq/qmax)**2 else if(dq.ne.0.0e0) then qscale=1.0e0+qscale*(qmax/dq)**2 qmax=abs(dq) endif enddo tstpiv=sqrt(qscale)*qmax return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cycle(ispd,ka,ja,a,ju,u,x,b,r,e) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),itnum(100),shift(100),lmtx,umtx, 1 kmtx,tmtx,ju(*),ja(*) real + x(*),b(*),r(*),e(*),u(*),a(*) c c multilevel iteration c ivwcy=1 n=ka(1) lvl=ka(2) c lmtx=0 umtx=0 kmtx=0 tmtx=0 if(ispd.eq.0) then lmtx=ju(n+1)-ju(1) kmtx=ja(n+1)-ja(1) elseif(ispd.eq.-1) then umtx=ju(n+1)-ju(1) tmtx=ja(n+1)-ja(1) endif c c shifts c shift(1)=0 do j=2,lvl+1 shift(j)=shift(j-1)+(n+1)-ka(20+j) enddo c do i=1,n r(i)=b(i) e(i)=0.0e0 enddo c level=1 itnum(level)=-1 c c smoothing iteration c 10 if(level.eq.lvl) then itnum(level)=ivwcy+1 else itnum(level)=itnum(level)+1 endif call smooth(level,lmtx,umtx,shift,ka,ju,u,x,r) c c return if we are done c if(level.eq.1.and.itnum(1).ge.1) then do i=1,n x(i)=x(i)+e(i) enddo return endif c c decide what to do next c if(itnum(level).le.ivwcy) then c c increase level, go to coarser level c call resid(level,lmtx,umtx,kmtx,tmtx,shift, + ka,ja,a,ju,u,x,r,e) call fn2cr(level,lmtx,shift,ka,ju,u,x,r,e) level=level+1 itnum(level)=0 else c c decrease level, go to finer grid c call cr2fn(level,umtx,shift,ka,ju,u,x,e) level=level-1 call resid(level,lmtx,umtx,kmtx,tmtx,shift, + ka,ja,a,ju,u,x,r,e) endif go to 10 end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine smooth(level,lmtx,umtx,shift,ka,ju,u,x,r) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),shift(*),lmtx,umtx,ju(*) real + x(*),r(*),u(*) c c smoothing interation c ishift=shift(level) n=ka(1) n1=ka(20+level) unorm=u(n+1) c do i=n1,n x(i)=r(i+ishift) enddo c c lower triangular system c do i=n1,n if(abs(u(i)).gt.unorm) then x(i)=x(i)/u(i) do jj=ju(i),ju(i+1)-1 j=ju(jj) x(j)=x(j)-u(jj+lmtx)*x(i) enddo else x(i)=0.0e0 endif enddo c c upper triangular system c do i=n,n1,-1 if(abs(u(i)).gt.unorm) then s=0.0e0 do jj=ju(i),ju(i+1)-1 j=ju(jj) s=s+u(jj+umtx)*x(j) enddo x(i)=x(i)-s/u(i) else x(i)=0.0e0 endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine resid(level,lmtx,umtx,kmtx,tmtx,shift, + ka,ja,a,ju,u,x,r,e) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),shift(100),lmtx,umtx,ju(*),ja(*),kmtx,tmtx real + x(*),r(*),e(*),u(*),a(*) c c compute residual c ishift=shift(level) n=ka(1) n1=ka(20+level) jmtx=ka(19) unorm=u(n+1) c if(level.eq.1) then do i=n1,n e(i+ishift)=e(i+ishift)+x(i) c c matrix multiply c r(i+ishift)=r(i+ishift)-a(i)*x(i) do jj=ja(i),ja(i+1)-1 j=ja(jj) r(i+ishift)=r(i+ishift)-a(jj+tmtx)*x(j) r(j+ishift)=r(j+ishift)-a(jj+kmtx)*x(i) enddo enddo else do i=n1,n e(i+ishift)=e(i+ishift)+x(i) c c ilu matrix multiply c if(abs(u(i)).gt.unorm) then s=0.0e0 do jj=ju(i+jmtx),ju(i+1)-1 j=ju(jj) s=s+u(jj+umtx)*x(j) enddo s=x(i)+s/u(i) r(i+ishift)=r(i+ishift)-u(i)*s do jj=ju(i+jmtx),ju(i+1)-1 j=ju(jj) r(j+ishift)=r(j+ishift)-u(jj+lmtx)*s enddo endif c c error matrix multiply c do jj=ju(i),ju(i+jmtx)-1 j=ju(jj) r(i+ishift)=r(i+ishift)-u(jj+umtx)*x(j) r(j+ishift)=r(j+ishift)-u(jj+lmtx)*x(i) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fn2cr(level,lmtx,shift,ka,ju,u,x,r,e) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),shift(*),lmtx,ju(*) real + x(*),r(*),u(*),e(*) c c fine to coarse transformation c ishift=shift(level) jshift=shift(level+1) n=ka(1) n1=ka(20+level) n2=ka(20+level+1) jmtx=ka(19) unorm=u(n+1) c c lower triangular system c do i=n1,n x(i)=r(i+ishift) enddo do i=n1,n2-1 if(abs(u(i)).gt.unorm) then x(i)=x(i)/u(i) do jj=ju(i+jmtx),ju(i+1)-1 j=ju(jj) x(j)=x(j)-u(jj+lmtx)*x(i) enddo else x(i)=0.0e0 endif enddo c c initialize rhs and solution on coarse level c do i=n2,n r(i+jshift)=x(i) e(i+jshift)=0.0e0 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cr2fn(level,umtx,shift,ka,ju,u,x,e) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*),shift(100),umtx,ju(*) real + x(*),e(*),u(*) c c coarse to fine transformation c ishift=shift(level) n=ka(1) n1=ka(20+level) n2=ka(20+level-1) jmtx=ka(19) unorm=u(n+1) c do i=n1,n x(i)=x(i)+e(i+ishift) enddo c c upper triangular system c do i=n1-1,n2,-1 if(abs(u(i)).gt.unorm) then s=0.0e0 do jj=ju(i+jmtx),ju(i+1)-1 j=ju(jj) s=s+u(jj+umtx)*x(j) enddo x(i)=x(i)-s/u(i) else x(i)=0.0e0 endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine snsilu(n,ju,u,x,b,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ju(*),lmtx,umtx real + 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(abs(u(i)).gt.unorm) then x(i)=x(i)/u(i) do jj=ju(i),ju(i+1)-1 j=ju(jj) x(j)=x(j)-u(jj+lmtx)*x(i) enddo else x(i)=0.0e0 endif enddo c c upper triangular system c do i=n,1,-1 if(abs(u(i)).gt.unorm) then s=0.0e0 do jj=ju(i),ju(i+1)-1 j=ju(jj) s=s+u(jj+umtx)*x(j) enddo x(i)=x(i)-s/u(i) else x(i)=0.0e0 endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mtxmlt(n,ja,a,x,b,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),umtx,lmtx real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mtxml0(n,ja,a,x,b,p,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),p(*),qi,umtx,lmtx real + 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 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 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function canorm(n,ispd,ja,a) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*) data ibit/0/ c c compute anorm c canorm=0.0e0 eps=ceps(ibit) c do i=1,n canorm=amax1(canorm,abs(a(i))) enddo canorm=canorm*eps if(canorm.gt.0.0e0) 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=amax1(canorm,abs(a(ja(1)+i-1))) enddo canorm=canorm*eps if(canorm.gt.0.0e0) return c c if the matrix is zero c canorm=eps return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ja2ja(n,ja,q,link,ispd,a) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),q(*),link(*),amtx real + 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 aa=a(i) a(i)=a(ii) a(ii)=aa go to 40 endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ihp(list,len) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ja2jc(n,ja,jc) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine jamap0(i,j,n,ispd,ij,ji,ja) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) c c find location in ja array of entry (i,j) in original ordering c iqptr=ja(n+1)-1 iq=ja(iqptr+i) if(i.eq.j) then ij=iq ji=iq else jq=ja(iqptr+j) if(ispd.ne.1) then amtx=ja(n+1)-ja(1) else amtx=0 endif call jamap(iq,jq,ij,ji,ja,amtx) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine jacmap(i,j,ij,ji,ja,amtx) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine chkja(n,ja,mark,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),mark(*) c c check consistency of ja data structure c iflag=0 do i=1,n mark(i)=0 enddo c c check pointers c if(ja(1).le.0) then iflag=-1 return endif do i=1,n if(ja(i+1).lt.ja(i)) then iflag=-1 return endif enddo c c check column indices c do i=1,n do jj=ja(i),ja(i+1)-1 j=ja(jj) c c j not in upper triangle c if(j.le.i) then iflag=-2 return else if(j.gt.n) then iflag=-3 return c c duplicate entry c else if(mark(j).eq.1) then iflag=-4 return else mark(j)=1 endif enddo c c do j=ja(i),ja(i+1)-1 mark(ja(j))=0 enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine perm(n,x,z,ja,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + x(*),z(*) c c reorder x c iqptr=ja(n+1) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine md(n,jc,p,mark,lenu,list,equiv,befor,after) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkcliq(imin,jc,mark,equiv,ilen,imndeg,iempty) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine jcupdt(imin,i,jc,mark,equiv,befor,after,nvert, + ncliq,ideg) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clqupd(imin,jc,mark,equiv,iempty) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine svcliq(imin,jc,mark,equiv,ilen,iempty) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blk3(ip,rp,vx,vy,ndof,itdof,itnode,du,dum,ka,ja,a, + b,rd,p,udot,u0dot,epsmg,r,z,hist,jflag,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itdof(ndof,*),itnode(5,*),ka(*),ja(*) real + rp(100),vx(*),vy(*),du(*),dum(*),a(*),b(*),rd(*), 1 p(*),udot(*),u0dot(*),r(*),z(*),hist(22,*),t(10) c ntf=ip(1) ndf=ip(5) newntf=ip(27) newndf=ip(30) ising=ip(12) ispd=ip(8) mxcg=ip(10) jflag=0 c c first solve c do i=1,ndf r(i)=b(i) enddo call mg(ispd,mxcg,epsmg,ja,a,du,r, + ka,ising,reler1,jflag0,z,hist(1,7)) c c block solve c do i=1,ndf r(i)=rd(i) enddo call mg(ispd,mxcg,epsmg,ja,a,dum,r, + ka,ising,reler2,jflag1,z,hist(1,8)) c c update udot c do i=1,ndf udot(i)=udot(i)+dum(i) enddo c c compute the change in lambda c rl0dot=rp(33) scleqn=rp(67) thetal=rp(69) thetar=rp(70) drdrl=rp(73) c if(isw.eq.1) then call mkgm(ndf,newntf,vx,vy,z,itnode,ndof,itdof) t(1)=rl2ip(newndf,p,du) t(2)=rl2ip(newndf,p,udot) t(3)=dl2ip(newndf,udot,udot,z,1) t(4)=dl2ip(newndf,u0dot,udot,z,1) c call pl2ip(t,4) c pdu=t(1) pudot=t(2) udnorm=sqrt(t(3)) u0dud=t(4) else call mkgm(ndf,ntf,vx,vy,z,itnode,ndof,itdof) pdu=rl2ip(ndf,p,du) pudot=rl2ip(ndf,p,udot) udnorm=dl2nrm(ndf,udot,z,1) u0dud=dl2ip(ndf,u0dot,udot,z,1) endif c c compute change in scalar c hh=thetal+thetar*(drdrl+pudot) if(hh.ne.0.0e0) hh=1.0e0/hh delta=-(scleqn+thetar*pdu)*hh c c compute proposed lamda-dot, rho-dot c rldot=1.0e0/sqrt(udnorm**2+1.0e0) ang=(u0dud+1.0e0)*rl0dot*rldot if(ang.lt.0.0e0) rldot=-rldot if(abs(ang).lt.0.95e0.and.isw.ne.1) then sval=rp(25) sval0=rp(35) s1=sval*sval0 s2=rl0dot*rldot if(s1*s2.lt.0.0e0) rldot=-rldot endif c rdot=(drdrl+pudot)*rldot rp(72)=delta rp(23)=rldot rp(24)=rdot c do i=1,ndf du(i)=du(i)+delta*udot(i) enddo jflag=max0(iabs(jflag0),iabs(jflag1)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blk4(ip,rp,du,dum,ka,ja,a,h,b,p,dl, + rd,udot,epsmg,r,z,hist,jflag,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ka(*),ja(*) real + rp(100),du(*),dum(*),a(*),h(*),b(*),p(*),dl(*), 1 rd(*),udot(*),r(*),z(*),hist(22,*),t(5) c ndf=ip(5) newndf=ip(30) ndd=ip(33) ising=ip(12) ispd=ip(8) mxcg=ip(10) jflag=0 c m1=1 m2=m1+ndf m3=m2+ndf ihdl=m1 ihdu=m2 c c first solve c do i=1,ndf r(i)=b(i) enddo call mg(ispd,mxcg,epsmg,ja,a,du,r, + ka,ising,reler1,jflag0,z,hist(1,7)) c c second solve c do i=1,ndf r(i)=rd(i) enddo call mg(ispd,mxcg,epsmg,ja,a,dum,r, + ka,ising,reler2,jflag1,z,hist(1,8)) c c update udot c do i=1,ndf udot(i)=udot(i)+dum(i) enddo c call mtxml0(ndf,ja,h,du,z(ihdu),z(m3),1) call mtxml0(ndf,ja,h,udot,z(ihdl),z(m3),1) do i=1,ndf z(ihdu+i-1)=p(i)-z(ihdu+i-1) enddo if(isw.eq.1) then do i=1,ndd z(ihdl+i-1)=dl(i)+dl(i+ndf)-z(ihdl+i-1) enddo do i=ndd+1,ndf z(ihdl+i-1)=dl(i)-z(ihdl+i-1) enddo else do i=1,ndf z(ihdl+i-1)=dl(i)-z(ihdl+i-1) enddo endif c c compute the change in lamda c if(isw.eq.1) then t(1)=rl2ip(newndf,dl,du) t(2)=rl2ip(newndf,udot,z(ihdu)) t(3)=rl2ip(newndf,dl,udot) t(4)=rl2ip(newndf,udot,z(ihdl)) c if(isw.eq.1) call pl2ip(t,4) c dldu=t(1) dmhdu=t(2) dldm=t(3) dmhdl=t(4) else dldu=rl2ip(ndf,dl,du) dmhdu=rl2ip(ndf,udot,z(ihdu)) dldm=rl2ip(ndf,dl,udot) dmhdl=rl2ip(ndf,udot,z(ihdl)) endif c scleqn=rp(67) seqdot=rp(74) c1=scleqn+dldu+dmhdu c2=seqdot+dldm+dmhdl if(c2.ne.0.0e0) then delta=-c1/c2 else delta=0.0e0 endif rp(72)=delta c c right hand sides c do i=1,ndf du(i)=du(i)+delta*udot(i) r(i)=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,mxcg,epsmg,ja,a,dum,r, + ka,ising,reler3,jflag2,z,hist(1,9)) jflag=max0(iabs(jflag0),iabs(jflag1),iabs(jflag2)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blk5x(ip,du,dum,duc,ka,ja,a,h,g,su,sm, + b,p,dl,epsmg,r,z,hist,jflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ka(*),ja(*) real + du(*),dum(*),duc(*),a(*),h(*),g(*),su(*),sm(*), 1 p(*),b(*),dl(*),r(*),z(*),hist(22,*) c ndf=ip(5) ising=ip(12) ispd=ip(8) mxcg=ip(10) jflag=0 c m1=1 m2=m1+ndf c jspd=1 if(ispd.ne.1) jspd=-1 c c first solve for du c do j=1,ndf r(j)=b(j) enddo call mg(ispd,mxcg,epsmg,ja,a,du,r, + ka,ising,reler1,jflag0,z,hist(1,7)) c c first computation for lagrange multiplier c call mtxml0(ndf,ja,h,du,r,z,1) do i=1,ndf r(i)=p(i)-r(i) enddo call mg(jspd,mxcg,epsmg,ja,a,dum,r, + ka,ising,reler2,jflag1,z,hist(1,8)) c c compute update for control variables c call mtxml0(ndf,ja,sm,dum,r,z,-1) call mtxml0(ndf,ja,su,du,z,z(m2),-1) do i=1,ndf r(i)=dl(i)-r(i)-z(i) enddo c call mg(1,mxcg,epsmg,ja,g,duc,r, + ka(101),0,reler5,jflag,z,hist(1,27)) c c final computation for solution variables c call mtxml0(ndf,ja,sm,duc,r,z,0) c do i=1,ndf r(i)=b(i)-r(i) enddo call mg(ispd,mxcg,epsmg,ja,a,du,r, + ka,ising,reler3,jflag2,z,hist(1,9)) c c final computation for lagrange multiplier c call mtxml0(ndf,ja,h,du,r,z,1) call mtxml0(ndf,ja,su,duc,z,z(m2),0) do i=1,ndf r(i)=p(i)-r(i)-z(i) enddo call mg(jspd,mxcg,epsmg,ja,a,dum,r, + ka,ising,reler4,jflag3,z,hist(1,10)) jflag=max0(jflag,iabs(jflag0),iabs(jflag1)) jflag=max0(jflag,iabs(jflag2),iabs(jflag3)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blk5(ip,eps1,ka,ja,a,h,g,su,sm, + du,dum,duc,bu,bum,buc,b,p,ap,z,az,hist,e,relerr,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ka(*),ip(100) real + a(*),h(*),g(*),su(*),sm(*),hist(*),du(*),dum(*),duc(*), 1 bu(*),bum(*),buc(*),p(*),ap(*),z(*),az(*),e(*),b(*) save ibit data ibit/0/ c c initialize c iflag=0 eps2=ceps(ibit)*8.0e0 eps=amax1(eps1,eps2) epsi=1.0e0/amin1(eps,eps2) epsmin=0.5e0 relerr=0.0e0 n=ip(5) mxcg=ip(10) m1=1 m2=m1+n m3=m2+n n3=3*n c c compute initial norm of b c do i=1,n b(m1+i-1)=bu(i) b(m2+i-1)=bum(i) b(m3+i-1)=buc(i) du(i)=0.0e0 dum(i)=0.0e0 duc(i)=0.0e0 enddo bnorm=rl2nrm(n3,b) call hist1(hist,0,bnorm) if(bnorm.le.0.0e0) return rnorm=bnorm c c compute initial p and ap c call solve5(ip,ka,ja,a,h,g,su,sm, + p(m1),p(m2),p(m3),b(m1),b(m2),b(m3),e) call mtxml5(ip,ja,a,h,g,su,sm, + p(m1),p(m2),p(m3),ap(m1),ap(m2),ap(m3),e) bp=rl2ip(n3,p,b) if(bp.eq.0.0e0) 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(n3,p,ap) do i=1,n3 az(i)=pap*b(i)-bp*ap(i) enddo zscale=rl2nrm(n3,az) if(zscale.gt.0.0e0) then do i=1,n3 az(i)=az(i)/zscale enddo endif call solve5(ip,ka,ja,a,h,g,su,sm, + z(m1),z(m2),z(m3),az(m1),az(m2),az(m3),e) c c compute alphas c bz=rl2ip(n3,z,az)*(zscale/pap) zap=-bz/bp do i=1,n3 z(i)=z(i)-zap*p(i) enddo call mtxml5(ip,ja,a,h,g,su,sm, + z(m1),z(m2),z(m3),az(m1),az(m2),az(m3),e) zaz=rl2ip(n3,z,az) c c decide on pivoting strategy c if(abs(pap)*rnorm.lt.zscale) then qscale=tstpiv(n3,bp,bz,pap,zaz,b,ap,az) if(qscale.lt.abs(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 du(i)=du(i)+alpha*p(m1+i-1) dum(i)=dum(i)+alpha*p(m2+i-1) duc(i)=duc(i)+alpha*p(m3+i-1) enddo do i=1,n3 b(i)=b(i)-alpha*ap(i) p(i)=z(i) ap(i)=az(i) enddo c c convergence test c rnorm=rl2nrm(n3,b) call hist1(hist,itnum,rnorm) relerr=rnorm/bnorm cc write(6,*) itnum,relerr if(relerr.le.eps.or.bp.eq.0.0e0) 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 du(i)=du(i)+(alphap*p(m1+i-1)+alphaz*z(m1+i-1)) dum(i)=dum(i)+(alphap*p(m2+i-1)+alphaz*z(m2+i-1)) duc(i)=duc(i)+(alphap*p(m3+i-1)+alphaz*z(m3+i-1)) enddo do i=1,n3 b(i)=b(i)-(alphap*ap(i)+alphaz*az(i)) enddo c c convergence test c rnorm=rl2nrm(n3,b) call hist1(hist,itnum,-rnorm) relerr=rnorm/bnorm cc write(6,*) -itnum,relerr if(relerr.le.eps) return if(relerr.gt.epsi) go to 200 c c compute next direction c call solve5(ip,ka,ja,a,h,g,su,sm, + ap(m1),ap(m2),ap(m3),b(m1),b(m2),b(m3),e) bp=rl2ip(n3,ap,b) betaz=bp/bz do i=1,n3 p(i)=ap(i)+betaz*z(i) enddo call mtxml5(ip,ja,a,h,g,su,sm, + p(m1),p(m2),p(m3),ap(m1),ap(m2),ap(m3),e) 100 continue if(relerr.gt.epsmin) iflag=10 c return 200 iflag=10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mtxml5(ip,ja,a,h,g,su,sm,u,um,uc,au,aum,auc,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + u(*),um(*),uc(*),au(*),aum(*),auc(*),a(*),h(*),g(*), 1 su(*),sm(*),z(*) c c compute norms -- iprob=5 c ndf=ip(5) ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 c c lenz= 2*ndf c m1=1 m2=m1+ndf c c first equation c call mtxml0(ndf,ja,h,u,au,z(m2),1) call mtxml0(ndf,ja,a,um,z,z(m2),jspd) call mtxml0(ndf,ja,su,uc,aum,z(m2),0) do i=1,ndf au(i)=au(i)+z(i)+aum(i) enddo c c third equation c call mtxml0(ndf,ja,su,u,auc,z(m2),-1) call mtxml0(ndf,ja,sm,um,z,z(m2),-1) call mtxml0(ndf,ja,g,uc,aum,z(m2),1) do i=1,ndf auc(i)=auc(i)+z(i)+aum(i) enddo c c second equation c call mtxml0(ndf,ja,a,u,aum,z(m2),ispd) call mtxml0(ndf,ja,sm,uc,z,z(m2),0) do i=1,ndf aum(i)=aum(i)+z(i) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine solve5(ip,ka,ja,a,h,g,su,sm,du,dum,duc,bu,bum,buc,r) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ka(*),ja(*) real + du(*),dum(*),duc(*),a(*),h(*),g(*),su(*),sm(*), 1 bu(*),bum(*),buc(*),r(*) c ndf=ip(5) ising=ip(12) ispd=ip(8) c c lenr=nsum+3*ndf c m1=1 m2=m1+ndf m3=m2+ndf m4=m3+ndf c jspd=1 if(ispd.ne.1) jspd=-1 c c first solve for du c do i=1,ndf r(i)=bum(i) enddo call mg0(ispd,ja,a,du,r,ka,ising,r(m3)) c c first computation for lagrange multiplier c call mtxml0(ndf,ja,h,du,r,r(m3),1) do i=1,ndf r(i)=bu(i)-r(i) enddo call mg0(jspd,ja,a,dum,r,ka,ising,r(m3)) c c compute update for control variables c call mtxml0(ndf,ja,sm,dum,r,r(m3),-1) call mtxml0(ndf,ja,su,du,r(m2),r(m3),-1) do i=1,ndf r(i)=buc(i)-r(i)-r(m2+i-1) enddo c call mg0(1,ja,g,duc,r,ka(101),ising,r(m3)) c c final computation for solution variables c call mtxml0(ndf,ja,sm,duc,r,r(m3),0) call mtxml0(ndf,ja,a,du,r(m2),r(m3),ispd) c do i=1,ndf r(i)=bum(i)-r(i)-r(m2+i-1) enddo call mg0(ispd,ja,a,r(m2),r,ka,ising,r(m3)) do i=1,ndf du(i)=du(i)+r(m2+i-1) enddo c c final computation for lagrange multiplier c call mtxml0(ndf,ja,h,du,r,r(m3),1) call mtxml0(ndf,ja,su,duc,r(m2),r(m3),0) call mtxml0(ndf,ja,a,dum,r(m4),r(m3),jspd) do i=1,ndf r(i)=bu(i)-r(i)-r(m2+i-1)-r(m4+i-1) enddo c call mg0(jspd,ja,a,r(m2),r,ka,ising,r(m3)) do i=1,ndf dum(i)=dum(i)+r(m2+i-1) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mtxml4(ip,rp,ja,a,h,dl,d,u,um,rl,au,aum,al,z,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ja(*) real + rp(100),u(*),um(*),a(*),h(*),d(*),dl(*), 1 au(*),aum(*),z(*) c c matrix multiplya -- iprob=4 c ndf=ip(5) ispd=ip(8) jspd=1 if(ispd.ne.1) jspd=-1 seqdot=rp(74) c c lenz = ndf c if(isw.eq.1) go to 10 c c first equation c call mtxml0(ndf,ja,h,u,au,z,1) call mtxml0(ndf,ja,a,um,aum,z,jspd) do i=1,ndf au(i)=au(i)+aum(i)-rl*dl(i) enddo c c second equation c call mtxml0(ndf,ja,a,u,aum,z,ispd) do i=1,ndf aum(i)=aum(i)-rl*d(i) enddo c c third equation c al=-rl2ip(ndf,dl,u)-rl2ip(ndf,d,um)-seqdot*rl c return c c if um=0 c first equation c 10 call mtxml0(ndf,ja,h,u,au,z,1) do i=1,ndf au(i)=au(i)-rl*dl(i) enddo c c second equation c call mtxml0(ndf,ja,a,u,aum,z,ispd) do i=1,ndf aum(i)=aum(i)-rl*d(i) enddo c c third equation c al=-rl2ip(ndf,dl,u)-seqdot*rl c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath, + ja0,a0,x,b,p,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ja0(*),p(*),qi,umtx,lmtx,ipath(6,*) real + 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(ndf+1)-1 do i=1,ndf b(i)=0.0e0 qi=ja(iqptr+i) p(qi)=i enddo c c multiply by a0 c ndd=ipath(4,irgn)-ipath(3,irgn)+1 nn=ipath(4,nproc+2) do i=1,ndd i0=i+ipath(3,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,ndd i0=i+ipath(3,irgn)-1 do jj=ja0(i0),ja0(i0+1)-1 if(ja0(jj).gt.0) then j=ja0(jj)-ipath(3,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=ndd+1,newndf 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(ndf+1)-ja(1) if(ispd.eq.-1) umtx=ja(ndf+1)-ja(1) do i=1,newndf qi=ja(iqptr+i) do jj=ja(qi),ja(qi+1)-1 j=p(ja(jj)) mx=max0(i,j) if(mx.gt.ndd.and.mx.le.newndf) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,ui,bi,b,ujmp,ispd,iord,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja0(*),umtx,lmtx,ipath(6,*),jequv(*),iss(10) real + a0(*),ui(*),bi(*),b(*),ujmp(*) c c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c c isw = 1 interface residuals and jumps c = 0 interface jumps only c =-1 interface residuals only c n=ipath(4,nproc+2) ndd=ipath(4,irgn)-ipath(3,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.0) go to 50 c c upadate vertex parents as needed c do jrgn=1,nproc if(jrgn.eq.irgn) go to 20 do iseg=ipath(2,jrgn),ipath(1,jrgn),-1 ison=ipath(2,iseg) if(ison.le.0) go to 10 ivf1=ipath(3,iseg) ivf2=ipath(3+iord,iseg) if(iord.eq.1) then is=ipath(4,ison) if(is.ne.ipath(3,ison+1)) stop 3434 if(jequv(is).lt.0) then bb=bi(is)/2.0e0 bi(ivf1)=bi(ivf1)+bb bi(ivf2)=bi(ivf2)+bb endif else if(iord.eq.2) then mvf0=ipath(4,iseg) is1=ipath(4,ison) is2=ipath(4,ison+1) if(ivf1.ne.ipath(3,ison)) stop 3435 if(ivf2.ne.ipath(5,ison+1)) stop 4435 if(mvf0.ne.ipath(5,ison)) stop 5435 if(mvf0.ne.ipath(3,ison+1)) stop 6435 if(jequv(is1).lt.0) then bb=bi(is1)/8.0e0 bi(ivf1)=bi(ivf1)+bb*3.0e0 bi(mvf0)=bi(mvf0)+bb*6.0e0 bi(ivf2)=bi(ivf2)-bb endif if(jequv(is2).lt.0) then bb=bi(is2)/8.0e0 bi(ivf1)=bi(ivf1)-bb bi(mvf0)=bi(mvf0)+bb*6.0e0 bi(ivf2)=bi(ivf2)+bb*3.0e0 endif else if(iord.eq.3) then mvf1=ipath(4,iseg) mvf2=ipath(5,iseg) is1=ipath(4,ison) ism=ipath(6,ison) is2=ipath(5,ison+1) if(ivf1.ne.ipath(3,ison)) stop 3436 if(ivf2.ne.ipath(6,ison+1)) stop 4436 if(mvf1.ne.ipath(5,ison)) stop 5436 if(mvf2.ne.ipath(4,ison+1)) stop 6436 if(ism.ne.ipath(3,ison+1)) stop 7436 if(jequv(is1).lt.0) then bb=bi(is1)/16.0e0 bi(ivf1)=bi(ivf1)+bb*5.0e0 bi(mvf1)=bi(mvf1)+bb*15.0e0 bi(mvf2)=bi(mvf2)-bb*5.0e0 bi(ivf2)=bi(ivf2)+bb endif if(jequv(ism).lt.0) then bb=bi(ism)/16.0e0 bi(ivf1)=bi(ivf1)-bb bi(mvf1)=bi(mvf1)+bb*9.0e0 bi(mvf2)=bi(mvf2)+bb*9.0e0 bi(ivf2)=bi(ivf2)-bb endif if(jequv(is2).lt.0) then bb=bi(is2)/16.0e0 bi(ivf1)=bi(ivf1)+bb bi(mvf1)=bi(mvf1)-bb*5.0e0 bi(mvf2)=bi(mvf2)+bb*15.0e0 bi(ivf2)=bi(ivf2)+bb*5.0e0 endif endif 10 enddo 20 enddo c c fine part of interface c do ii=1,ndd i=ii+ipath(3,irgn)-1 sum=0.0e0 it=i 30 it=jequv(it) sum=sum+bi(it) if(it.ne.i) go to 30 b(ii)=sum enddo c c coarse part of interface c do ii=newndf+1,ndi i=ii-newndf+ipath(3,nproc+1)-1 sum=0.0e0 it=i 40 it=jequv(it) if(it.le.n) sum=sum+bi(it) if(it.ne.i) go to 40 b(ii)=sum enddo do i=ndi+1,ndf b(i)=0.0e0 enddo c c form jumps c 50 if(isw.eq.-1) return do i=1,n ujmp(i)=0.0e0 enddo c c fine part of interface c do ii=1,ndd i=ii+ipath(3,irgn)-1 uii=ui(i) it=i 60 it=jequv(it) if(it.ne.i) then ujmp(it)=ui(it)-uii go to 60 endif enddo c c jump contribution to residual c do ii=1,ndd i=ii+ipath(3,irgn)-1 it=i 70 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)+newndf if(jj.le.0) stop 9898 endif b(ii)=b(ii)+a0(kk+umtx)*ujmp(j) b(jj)=b(jj)+a0(kk+lmtx)*ujmp(it) else b(-j)=b(-j)+a0(kk+lmtx)*ujmp(it) endif enddo go to 70 endif enddo c c****************** c c this sets coarse interface jumps to zero (but saves code) c if(isw.ne.-1) return c****************** c c coarse part of interface c do ii=newndf+1,ndi i=ii-newndf+ipath(3,nproc+1)-1 uii=0.0e0 num=0 it=i 80 it=jequv(it) if(it.le.n) then uii=uii+ui(it) num=num+1 endif if(it.ne.i) go to 80 if(num.gt.0) uii=uii/float(num) it=i 90 it=jequv(it) if(it.le.n) ujmp(it)=ui(it)-uii if(it.ne.i) go to 90 enddo c c nodes not on coarse interface c do jrgn=1,nproc if(jrgn.eq.irgn) go to 110 do iseg=ipath(1,jrgn),ipath(2,jrgn) ison=ipath(2,iseg) if(ison.le.0) go to 100 iss(1)=ipath(4,ison) if(iord.eq.2) then iss(2)=ipath(4,ison+1) else if(iord.eq.3) then iss(2)=ipath(6,ison) iss(3)=ipath(5,ison+1) endif c c these dof's cannot be cross points c do kk=1,iord is=iss(kk) if(jequv(is).lt.0) then it=-jequv(is) ujmp(is)=(ui(is)-ui(it))/2.0e0 endif enddo 100 enddo 110 enddo c c vertex parents on coarse interface c do jrgn=1,nproc if(jrgn.eq.irgn) go to 130 do iseg=ipath(2,jrgn),ipath(1,jrgn),-1 ison=ipath(2,iseg) if(ison.le.0) go to 120 ivf1=ipath(3,iseg) ivf2=ipath(3+iord,iseg) if(iord.eq.1) then is=ipath(4,ison) if(jequv(is).lt.0) then bb=ujmp(is)/2.0e0 ujmp(ivf1)=ujmp(ivf1)+bb ujmp(ivf2)=ujmp(ivf2)+bb endif else if(iord.eq.2) then mvf0=ipath(4,iseg) is1=ipath(4,ison) is2=ipath(4,ison+1) if(jequv(is1).lt.0) then bb=ujmp(is1)/8.0e0 ujmp(ivf1)=ujmp(ivf1)+bb*3.0e0 ujmp(mvf0)=ujmp(mvf0)+bb*6.0e0 ujmp(ivf2)=ujmp(ivf2)-bb endif if(jequv(is2).lt.0) then bb=ujmp(is2)/8.0e0 ujmp(ivf1)=ujmp(ivf1)-bb ujmp(mvf0)=ujmp(mvf0)+bb*6.0e0 ujmp(ivf2)=ujmp(ivf2)+bb*3.0e0 endif else if(iord.eq.3) then mvf1=ipath(4,iseg) mvf2=ipath(5,iseg) is1=ipath(4,ison) ism=ipath(6,ison) is2=ipath(5,ison+1) if(jequv(is1).lt.0) then bb=ujmp(is1)/16.0e0 ujmp(ivf1)=ujmp(ivf1)+bb*5.0e0 ujmp(mvf1)=ujmp(mvf1)+bb*15.0e0 ujmp(mvf2)=ujmp(mvf2)-bb*5.0e0 ujmp(ivf2)=ujmp(ivf2)+bb endif if(jequv(ism).lt.0) then bb=ujmp(ism)/16.0e0 ujmp(ivf1)=ujmp(ivf1)-bb ujmp(mvf1)=ujmp(mvf1)+bb*9.0e0 ujmp(mvf2)=ujmp(mvf2)+bb*9.0e0 ujmp(ivf2)=ujmp(ivf2)-bb endif if(jequv(is2).lt.0) then bb=ujmp(is2)/16.0e0 ujmp(ivf1)=ujmp(ivf1)+bb ujmp(mvf1)=ujmp(mvf1)-bb*5.0e0 ujmp(mvf2)=ujmp(mvf2)+bb*15.0e0 ujmp(ivf2)=ujmp(ivf2)+bb*5.0e0 endif endif 120 enddo 130 enddo c c matrix multiply c do ii=newndf+1,ndi i=ii-newndf+ipath(3,nproc+1)-1 it=i 140 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)+newndf b(ii)=b(ii)+a0(kk+umtx)*ujmp(j) b(jj)=b(jj)+a0(kk+lmtx)*ujmp(it) else b(-j)=b(-j)+a0(kk+lmtx)*ujmp(it) endif enddo endif if(it.ne.i) go to 140 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine predct(ip,itnode,ibndry,vx,vy,xm,ym,b,u, + gm,u0,u0dot,rp,ibedge,idsp,mxfail,ndof,itdof,mark,icurv,iq, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 itdof(ndof,*),ib(10),icurv(3,*),mark(*),iq(*) real + vx(*),vy(*),u(*),u0(*),u0dot(*),rp(100),xm(*),ym(*), 1 b(*),gm(*) real + fa(10,10),fh(10,10),fg(10,10),fsm(10,10),fsu(10,10), 1 fb(25),fd(25),fp(25),fdl(25),um(25),d1u(25),d2u(25), 2 uc(25),vx0(2),vy0(2) 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) nbf=ip(4) ndf=ip(5) iprob=ip(7) ispd=ip(8) iord=ip(26) c bias=100.0e0 ratmax=25.0e0 step=0.25e0 sh=rp(45) rl0dot=rp(33) rl0=rp(31) r0=rp(32) eps=100.0e0*ceps(ibit) ratio=2.0e0*ratmax scale=1.0e0 c c compute theta c call mkgm(ndf,ntf,vx,vy,gm,itnode,ndof,itdof) call ccurv(ntf,nbf,ibndry,ibedge,icurv) 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.0e0.or.idsp.gt.mxfail) then idsp=mxfail+1 return endif c isw=0 iter=-1 c c initialize c 10 iter=iter+1 if(sigma*seqdot.le.0.0e0) then q=rl0dot*sigma/(seqdot-sigma/bias) else q=rl0dot*sigma/(seqdot+sigma/bias) endif if(ratio.le.ratmax) q=step*q rl=rl0+q do i=1,ndf u(i)=u0(i)+q*u0dot(i) b(i)=0.0e0 enddo rr=0.0e0 anorm=0.0e0 c c compute integrals on elements c do i=1,ntf call l2gmap(i,ib,ndof,itdof) call eleasm(i,itnode,ib,vx,vy,xm,ym,u,um,uc,d1u,d2u, + vx0,vy0,u0,u0,u0,rl,sh,sh,fa,fh,fg,fsm,fsu,fb, 1 fd,fp,fdl,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) rr=rr+fp(12) do k=1,ndof ivk=ib(k) anorm=amax1(anorm,abs(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 it=ibedge(j,i)/4 call l2gmap(it,ib,ndof,itdof) call elebdi(i,j,itnode,ibndry,ibedge,ib, + vx,vy,xm,ym,u,uc,rl,fh,fg, 1 fsu,fp,fdl,iprob,iord,p2xy) rr=rr+fp(12) endif enddo endif if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 call l2gmap(it,ib,ndof,itdof) call elenbc(i,itnode,ibndry,ibedge,ib,vx,vy,xm,ym, + u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 iprob,iord,gnxy) do k=1,ndof ivk=ib(k) 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,ndf iq(i)=i enddo call cdbc(ndf,nbf,iord,ndof,itdof,ibndry,ibedge,mark,iq) do i=1,ndf if(mark(i).ne.0) b(i)=0.0e0 enddo bnorm=dl2nrm(ndf,b,gm,-1) c c compute scaling c if(ratio.gt.ratmax) then unorm=dl2nrm(ndf,u,gm,1) scale=bias d1=bnorm+anorm*unorm*10.0e0 d2=abs(sigma)+abs(r0)*abs(thetar)+abs(rl0)*abs(thetal) if(amin1(d1,d2).gt.0.0e0.and.bnorm.gt.anorm*0.001e0) + scale=bias*d1/d2 endif q=scleqn*scale bmax=amax1(abs(q),bnorm) if(bmax.gt.0.0e0) then bnorm=bmax*sqrt((bnorm/bmax)**2+(q/bmax)**2) endif ratio=0.0e0 if(sigma.ne.0.0e0) ratio=bnorm/abs(scale*sigma) c c test for sufficient decrease c if(1.0e0-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.0e0 endif go to 10 endif c end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine swbrch(ndf,ntf,nbf,itnode,ibndry,ndof,itdof,vx,vy, + xm,ym,evl,evr,udot,u,u0dot,p,zr,zp,phi,gm,icurv,rp,ibedge, 1 ispd,iord,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),itdof(ndof,*), 1 icurv(3,*),idof(10) real + vx(*),vy(*),u(*),udot(*),evr(*),evl(*),p(*),zr(*), 1 rp(100),phi(*),zp(*),xm(*),ym(*),u0dot(*),gm(*) real + a(10,10),azr(10,10),atm(10,10),azp(10,10),f(25), 1 fzr(25),frl(25),fzp(25),ptm(25),pzr(25),pzp(25), 2 btm(25),htm(10,10),utm(25),dtm(25),gtm(10,10),ucm(25) external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy c c initialize c rl=rp(21) rldot=rp(23) rl0dot=rp(33) delta=1.0e-4 sh=rp(45) iprob=3 call mkgm(ndf,ntf,vx,vy,gm,itnode,ndof,itdof) call ccurv(ntf,nbf,ibndry,ibedge,icurv) c c compute phi to be orthogonal to evl c evlr=dl2ip(ndf,evl,evr,gm,1) evld=dl2ip(ndf,evl,udot,gm,1) a1=evld/evlr c c zr = u + delta * evr c zp = u + delta * phi c do i=1,ndf phi(i)=udot(i)-a1*evr(i) p(i)=0.0e0 zr(i)=u(i)+delta*evr(i) zp(i)=u(i)+delta*phi(i) enddo c c compute coefficients of quadratic c a111=0.0e0 b11=0.0e0 c1=0.0e0 drdrl=0.0e0 rrl=rl+delta do i=1,ntf c c compute element stiffness matrix c call l2gmap(i,idof,ndof,itdof) call eleasm(i,itnode,idof,vx,vy,xm,ym,u,utm,utm,utm,utm, + vx,vy,u,u,u,rl,sh,sh,a,htm,gtm,gtm,gtm,btm,f, 1 ptm,dtm,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) call eleasm(i,itnode,idof,vx,vy,xm,ym,zr,utm,utm,utm,utm, + vx,vy,zr,u,u,rl,sh,sh,azr,htm,gtm,gtm,gtm,btm,fzr, 1 pzr,dtm,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) call eleasm(i,itnode,idof,vx,vy,xm,ym,zp,utm,utm,utm,utm, + vx,vy,zp,u,u,rl,sh,sh,azp,htm,gtm,gtm,gtm,btm,fzp, 1 pzp,dtm,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) call eleasm(i,itnode,idof,vx,vy,xm,ym,u,utm,utm,utm,utm, + vx,vy,u,u,u,rrl,sh,sh,atm,htm,gtm,gtm,gtm,btm,frl, 1 ptm,dtm,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) c c form element inner products c drdrl=drdrl+pzp(11)+pzr(11) do j=1,ndof ivj=idof(j) p(ivj)=p(ivj)+pzp(j)+pzr(j) s=0.0e0 ss=0.0e0 do k=1,ndof ivk=idof(k) 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.0e0*(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 it=ibedge(j,i)/4 call l2gmap(it,idof,ndof,itdof) call elebdi(i,j,itnode,ibndry,ibedge,idof, + vx,vy,xm,ym,zr,ucm,rl,htm,gtm, 1 gtm,pzr,dtm,iprob,iord,p2xy) call elebdi(i,j,itnode,ibndry,ibedge,idof, + vx,vy,xm,ym,zp,ucm,rl,htm,gtm, 1 gtm,pzp,dtm,iprob,iord,p2xy) drdrl=drdrl+pzp(11)+pzr(11) do k=1,ndof ivk=idof(k) 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 l2gmap(it,idof,ndof,itdof) call elenbc(i,itnode,ibndry,ibedge,idof,vx,vy, + xm,ym,u,utm,ucm,rl,a,htm,gtm,gtm,gtm,btm, 1 f,ptm,dtm,iprob,iord,gnxy) call elenbc(i,itnode,ibndry,ibedge,idof,vx,vy, + xm,ym,zr,utm,ucm,rl,azr,htm,gtm,gtm,gtm,btm, 1 fzr,ptm,dtm,iprob,iord,gnxy) call elenbc(i,itnode,ibndry,ibedge,idof,vx,vy, + xm,ym,zp,utm,ucm,rl,azp,htm,gtm,gtm,gtm,btm, 1 fzp,ptm,dtm,iprob,iord,gnxy) call elenbc(i,itnode,ibndry,ibedge,idof,vx,vy, + xm,ym,u,utm,ucm,rrl,atm,htm,gtm,gtm,gtm,btm, 1 frl,ptm,dtm,iprob,iord,gnxy) do j=1,ndof ivj=idof(j) s=0.0e0 ss=0.0e0 do k=1,ndof ivk=idof(k) 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.0e0*(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.0e0) then if(b11.gt.0.0e0) then ss=b11+sqrt(abs(discr)) q1=-c1/ss q2=-ss/a111 else ss=b11-sqrt(abs(discr)) q1=-ss/a111 q2=-c1/ss endif do i=1,ndf zp(i)=q1*evr(i)+phi(i) zr(i)=q2*evr(i)+phi(i) enddo else do i=1,ndf zp(i)=phi(i) zr(i)=evr(i)*100.0e0 enddo endif zrnorm=dl2nrm(ndf,zr,gm,1) zpnorm=dl2nrm(ndf,zp,gm,1) ibrch=0 c c here we are trying to stay on current branch c if(isw.eq.1) then udnorm=dl2nrm(ndf,u0dot,gm,1)*abs(rl0dot) if(udnorm.gt.1.0e-2) then zrd=dl2ip(ndf,zr,u0dot,gm,1) zpd=dl2ip(ndf,zp,u0dot,gm,1) if(abs(zpd)*zrnorm.gt.abs(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(ndf,udot,gm,1)*abs(rldot) if(udnorm.gt.1.0e-2) then zrd=dl2ip(ndf,zr,udot,gm,1) zpd=dl2ip(ndf,zp,udot,gm,1) if(abs(zpd)*zrnorm.lt.abs(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.0e0/sqrt(zpnorm**2+1.0e0) do i=1,ndf udot(i)=zp(i) enddo else rldot=1.0e0/sqrt(zrnorm**2+1.0e0) do i=1,ndf udot(i)=zr(i) enddo endif rdot=(drdrl+rl2ip(ndf,p,udot))*rldot/2.0e0 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.0e0) im=1 endif if(im.eq.1) then rldot=-rldot rdot=-rdot endif rp(23)=rldot rp(24)=rdot return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine evinit(ip,evl,evr,ndof,itdof,ibndry,ibedge,q,mark) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),ibndry(6,*),itdof(ndof,*),ibedge(2,*), 1 mark(*),q(*) real + evl(*),evr(*) c c initialize left and right singular vectors c ndf=ip(5) nbf=ip(4) iord=ip(26) c c check for null vectors c evrn=rl2nrm(ndf,evr) evln=rl2nrm(ndf,evl) if(evrn.eq.0.0e0.or.evln.eq.0.0e0) then call cdbc(ndf,nbf,iord,ndof,itdof,ibndry,ibedge,mark,q) do i=1,ndf evr(i)=1.0e0 evl(i)=1.0e0 if(mark(q(i)).eq.1) then evr(i)=0.0e0 evl(i)=0.0e0 endif enddo evrn=rl2nrm(ndf,evr) evln=rl2nrm(ndf,evl) endif c if(evrn.eq.0.0e0.or.evln.eq.0.0e0) return c c normalize initial vectors c dp=rl2ip(ndf,evl,evr) if(dp.lt.0.0e0) evln=-evln do i=1,ndf ee=evr(i)/evrn evl(i)=evl(i)/evln evr(i)=ee enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bdinit(ip,rp,u,vx,vy,xm,ym,ndof,itdof,itnode,ibndry, + ibedge,bdlwr,bdupr,gm,icurv,gdxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 itdof(ndof,*),icurv(3,*),idof(10) real + u(*),g(15),bdlwr(*),bdupr(*),rp(100),vx(*),vy(*),gm(*), 1 c(3,15),xp(10),yp(10),xm(*),ym(*) external gdxy data ibit/0/ c c compute bdupr, bdlwr c ntf=ip(1) nbf=ip(4) ndf=ip(5) iord=ip(26) rl=rp(21) rmu=rp(63) eps=100.0e0*ceps(ibit) tol=amax1(1.0e-2*rmu,eps) c do i=1,ndf bdupr(i)=0.0e0 bdlwr(i)=0.0e0 gm(i)=0.0e0 enddo c call ccurv(ntf,nbf,ibndry,ibedge,icurv) call cnodes(c,iord) c do i=1,ntf call l2gmap(i,idof,ndof,itdof) call cnodec(i,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) area=abs((vx(iv2)-vx(iv1))*(vy(iv3)-vy(iv1))- + (vx(iv3)-vx(iv1))*(vy(iv2)-vy(iv1))) itag=itnode(5,i) do j=1,ndof if(isw.eq.0) then xx=c(1,j)*vx(iv1)+c(2,j)*vx(iv2)+c(3,j)*vx(iv3) yy=c(1,j)*vy(iv1)+c(2,j)*vy(iv2)+c(3,j)*vy(iv3) else xx=xp(j) yy=yp(j) endif do m=1,8 g(m)=0.0e0 enddo call gdxy(xx,yy,rl,itag,g) ivj=idof(j) gm(ivj)=gm(ivj)+area bdlwr(ivj)=bdlwr(ivj)+area*g(4) bdupr(ivj)=bdupr(ivj)+area*g(5) enddo enddo c bup=0.0e0 blw=0.0e0 do i=1,ndf bdupr(i)=bdupr(i)/gm(i) bdlwr(i)=bdlwr(i)/gm(i) bup=amax1(abs(bdupr(i)),bup) blw=amax1(abs(bdlwr(i)),blw) enddo if(bup.gt.0.0e0) then bup=bup*tol else bup=tol endif if(blw.gt.0.0e0) then blw=blw*tol else blw=tol endif do i=1,ndf if(bdlwr(i)+blw.le.bdupr(i)-bup) then u(i)=amax1(u(i),bdlwr(i)+blw) u(i)=amin1(u(i),bdupr(i)-bup) else rr=tol*(bdupr(i)-bdlwr(i)) u(i)=amax1(u(i),bdlwr(i)+rr) u(i)=amin1(u(i),bdupr(i)-rr) endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setrd(ndf,ndd,ispd,ja,a,udot,d,rd,z,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*),udot(*),d(*),rd(*),z(*) c c residual form of d-vector c call mtxml0(ndf,ja,a,udot,rd,z,ispd) if(isw.eq.1) then do i=1,ndd rd(i)=d(i)+d(i+ndf)-rd(i) enddo do i=ndd+1,ndf rd(i)=d(i)-rd(i) enddo else do i=1,ndf rd(i)=d(i)-rd(i) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setrdp(irgn,nproc,ndf,newndf,ispd,ja,a,ja0,a0, + udot,d,rd,ipath,p) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ja0(*),ipath(6,*),p(*) real + a(*),a0(*),udot(*),d(*),rd(*) c c residual form of d-vector c call blkmlt(irgn,nproc,newndf,ndf,ja,a,ipath,ja0,a0, + udot,rd,p,ispd) do i=1,newndf rd(i)=d(i)-rd(i) enddo do i=newndf+1,ndf rd(i)=0.0e0 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setbdl(rp,isw) c implicit real (a-h,o-z) implicit integer (i-n) real + rp(100) c c compute new diagonal and rhs for schur complement system c rmu=rp(63) scleqn=rp(67) seqdot=rp(74) area=rp(80) rllwr=rp(4) rlupr=rp(5) rl=rp(21) rsh=rp(64)*rmu c ru=0.0e0 uu=0.0e0 if(rl.gt.rllwr) then ru=ru+rmu/(rl-rllwr) uu=uu+rmu/(rl-rllwr)**2 endif if(rl.lt.rlupr) then ru=ru+rmu/(rl-rlupr) uu=uu+rmu/(rl-rlupr)**2 endif rp(67)=scleqn+(ru+rsh*rl)*area rp(74)=seqdot-(uu+rsh)*area return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine gfinit(ip,maxd,gf,e) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100) real + gf(maxd,*),e(*) c c initialize grid functions c ntf=ip(1) ndf=ip(5) ngf=ip(77) do j=1,ngf do i=1,ndf gf(i,j)=0.0e0 enddo enddo do i=1,ntf e(i)=0.0e0 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine uinit(ip,rp,itnode,ibndry,ibedge,vx,vy,xm,ym, + u,um,uc,gm,ndof,itdof,icurv,gdxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ip(100),idof(10),icurv(3,*), 1 itdof(ndof,*),ibndry(6,*),ibedge(2,*) real + vx(*),vy(*),u(*),um(*),uc(*),gm(*),rp(100),g(15), 1 c(3,10),xp(10),yp(10),xm(*),ym(*) external gdxy c c initialize u c ntf=ip(1) nbf=ip(4) iprob=iabs(ip(7)) itask=ip(9) iord=ip(26) ndf=ip(5) c c check status of u initialization c umax=0.0e0 do i=1,ndf umax=amax1(umax,abs(u(i))) enddo if(umax.gt.0.0e0) return c call cnodes(c,iord) call ccurv(ntf,nbf,ibndry,ibedge,icurv) rl=rp(21) if(iprob.eq.6) then rl=rp(46) if(itask.eq.10) rl=rl+amax1(rp(47),rp(48)) endif c do i=1,ndf u(i)=0.0e0 gm(i)=0.0e0 enddo if(iprob.eq.4) then do i=1,ndf um(i)=0.0e0 enddo else if(iprob.eq.5) then do i=1,ndf um(i)=0.0e0 uc(i)=0.0e0 enddo endif do i=1,ntf call l2gmap(i,idof,ndof,itdof) call cnodes(c,iord) call cnodec(i,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) iv1=itnode(1,i) iv2=itnode(2,i) iv3=itnode(3,i) area=abs((vx(iv2)-vx(iv1))*(vy(iv3)-vy(iv1))- + (vx(iv3)-vx(iv1))*(vy(iv2)-vy(iv1))) itag=itnode(5,i) do j=1,ndof if(isw.eq.0) then xx=c(1,j)*vx(iv1)+c(2,j)*vx(iv2)+c(3,j)*vx(iv3) yy=c(1,j)*vy(iv1)+c(2,j)*vy(iv2)+c(3,j)*vy(iv3) else xx=xp(j) yy=yp(j) endif do m=1,8 g(m)=0.0e0 enddo call gdxy(xx,yy,rl,itag,g) ivj=idof(j) gm(ivj)=gm(ivj)+area u(ivj)=u(ivj)+area*g(6) if(iprob.eq.4) then um(ivj)=um(ivj)+area*g(7) else if(iprob.eq.5) then um(ivj)=um(ivj)+area*g(7) uc(ivj)=uc(ivj)+area*g(8) endif enddo enddo do i=1,ndf u(i)=u(i)/gm(i) enddo if(iprob.eq.4) then do i=1,ndf um(i)=um(i)/gm(i) enddo else if(iprob.eq.5) then do i=1,ndf um(i)=um(i)/gm(i) uc(i)=uc(i)/gm(i) enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rgnsys(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,um,uc,d1u,d2u,vx0,vy0,ndof,itdof, 1 ja,q,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,mark,icurv, 2 jequv,ipath,ja0,a0,h0,g0,su0,sm0,nn0,gf, 3 z,zp,isw,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ja(*),q(*),mark(*),ja0(*),jequv(*),ipath(6,*),amtx, 2 amtx0,smtx,smtx0,ib(10),ib0(10),ia(10,10),ia0(10,10), 3 itdof(ndof,*),icurv(3,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 um(*),uc(*),d1u(*),d2u(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),d(*),rd(*),p(*), 3 dl(*),bdlwr(*),bdupr(*),a0(*),h0(*),g0(*),su0(*), 4 sm0(*),gf(nn0,*),z(*),zp(*) real + fa(10,10),fh(10,10),fg(10,10),fsm(10,10),fsu(10,10), 1 fb(25),fd(25),fp(25),fdl(25),fz(100),t(25) 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) nbf=ip(4) nproc=ip(49) irgn=ip(50) iord=ip(26) ndf=ip(5) newndf=ip(30) ndd=ip(33) ndi=ip(36) iprob=iabs(ip(7)) ispd=ip(8) itask=ip(9) nn=ipath(4,nproc+2) c do i=1,100 fz(i)=0.0e0 enddo smtx=ja(ndf+1)-ja(1) smtx0=ja0(nn+1)-ja0(1) if(ispd.eq.1) then amtx=0 amtx0=0 else amtx=ja(ndf+1)-ja(1) amtx0=ja0(nn+1)-ja0(1) endif c c initialize c do i=1,ja(ndf+1)-1+amtx a(i)=0.0e0 enddo do i=1,ja0(nn+1)-1+amtx0 a0(i)=0.0e0 enddo c rl=rp(21) if(iabs(iprob).eq.6) then rl=rp(46) if(itask.eq.10) rl=rl+amax1(rp(47),rp(48)) endif sh=rp(45) rmu=rp(63) do i=1,ndf b(i)=0.0e0 enddo if(iprob.eq.1) then do i=1,ndf p(i)=0.0e0 enddo else if(iprob.eq.4) then sh=rp(64) do i=1,ndf+ndd d(i)=0.0e0 dl(i)=0.0e0 enddo do i=1,ndf p(i)=0.0e0 d1u(i)=0.0e0 d2u(i)=0.0e0 enddo do i=1,ja(ndf+1)-1 h(i)=0.0e0 enddo do i=1,ja0(nn+1)-1 h0(i)=0.0e0 enddo else if(iprob.eq.5) then sh=rp(64) do i=1,ndf dl(i)=0.0e0 p(i)=0.0e0 d1u(i)=0.0e0 d2u(i)=0.0e0 enddo do i=1,ja(ndf+1)-1 g(i)=0.0e0 h(i)=0.0e0 enddo do i=1,ja(ndf+1)-1+smtx su(i)=0.0e0 sm(i)=0.0e0 enddo do i=1,ja0(nn+1)-1 g0(i)=0.0e0 h0(i)=0.0e0 enddo do i=1,ja0(nn+1)-1+smtx0 su0(i)=0.0e0 sm0(i)=0.0e0 enddo else if(iprob.eq.3) then do i=1,ndf+ndd p(i)=0.0e0 d(i)=0.0e0 enddo endif c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then call l2gmpe(i,ibedge,iord,ib,ndof,itdof) call eledbc(i,itnode,ibndry,ibedge,ib,vx,vy,xm,ym, + u,um,uc,rl,d1u,d2u,udot,iprob,iord,gdxy) endif enddo c r=0.0e0 drdrl=0.0e0 scleqn=0.0e0 seqdot=0.0e0 c c assemble and update elements c call ccurv(ntf,nbf,ibndry,ibedge,icurv) do i=1,ntf jrgn=itnode(4,i) call l2gmpd(i,irgn,jrgn,ndof,itdof,jequv,q,ja,ja0, + ndf,ndd,newndf,ndi,nproc,ipath,ib,ib0,ia,ia0) call eleasm(i,itnode,ib,vx,vy,xm,ym,u,um,uc,d1u,d2u, + vx0,vy0,u0,bdlwr,bdupr,rl,sh,rmu,fa,fh,fg,fsm,fsu, 1 fb,fd,fp,fdl,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) call l2gd(iprob,irgn,jrgn,ispd,iord,a,h,g, + su,sm,a0,h0,g0,su0,sm0,b,d,p,dl,ib0,ia,ia0,fa,fh,fg, 1 fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn,seqdot,ndf) 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 l2gmpd(it,irgn,jrgn,ndof,itdof, + jequv,q,ja,ja0,ndf,ndd,newndf,ndi, 1 nproc,ipath,ib,ib0,ia,ia0) call elebdi(i,j,itnode,ibndry,ibedge,ib, + vx,vy,xm,ym,u,uc,rl,fh,fg,fsu, 1 fp,fdl,iprob,iord,p2xy) call l2gd(iprob,irgn,jrgn,ispd,iord,a,h,g, + su,sm,a0,h0,g0,su0,sm0,b,d,p,dl,ib0,ia, 1 ia0,fz,fh,fg,fz,fsu,fz,fz,fp,fdl, 2 r,drdrl,scleqn,seqdot,ndf) endif endif enddo endif c c neumann edge c if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 jrgn=itnode(4,it) call l2gmpd(it,irgn,jrgn,ndof,itdof,jequv,q,ja,ja0, + ndf,ndd,newndf,ndi,nproc,ipath,ib,ib0,ia,ia0) call elenbc(i,itnode,ibndry,ibedge,ib,vx,vy,xm,ym, + u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 iprob,iord,gnxy) call l2gd(iprob,irgn,jrgn,ispd,iord,a,h,g, + su,sm,a0,h0,g0,su0,sm0,b,d,p,dl,ib0,ia,ia0,fa,fh, 1 fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn,seqdot,ndf) endif enddo c c modifications for bordered systems c if(iprob.eq.3.or.iprob.eq.4) call setrdp(irgn,nproc, + ndf,newndf,ispd,ja,a,ja0,a0,udot,d,rd,ipath,z) cc if(iprob.eq.3.or.iprob.eq.4) call setrd(ndf,ndd,ispd, cc + ja,a,udot,d,rd,z,1) c c set dirichlet boundary conditions c call cdbc(ndf,nbf,iord,ndof,itdof,ibndry,ibedge,mark,q) anorm=0.0e0 do i=1,ndf if(mark(q(i)).eq.1) b(i)=0.0e0 anorm=amax1(abs(a(i)),anorm) enddo if(anorm.le.0.0e0) anorm=1.0e0 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(ndf,ja,a,amtx,anorm,mark,1) call mt0dbc(ja0,a0,0,0.0e0,mark,zp,nproc,irgn, + ndd,newndf,ndi,ipath,jequv,q,1) c c scalar function c if(iprob.eq.1.and.itask.eq.9) then do i=1,ndf if(mark(q(i)).eq.1) p(i)=0.0e0 enddo else if(iprob.eq.4) then do i=1,ndf if(mark(q(i)).eq.1) then d(i)=0.0e0 rd(i)=0.0e0 dl(i)=0.0e0 p(i)=0.0e0 if(i.le.ndd) then d(i+ndf)=0.0e0 dl(i+ndf)=0.0e0 endif endif enddo rp(67)=scleqn rp(74)=seqdot call setbdl(rp,isw) call mtxdbc(ndf,ja,h,0,0.0e0,mark,1) call mt0dbc(ja0,h0,0,0.0e0,mark,zp,nproc,irgn, + ndd,newndf,ndi,ipath,jequv,q,1) else if(iprob.eq.5) then do i=1,ndf if(mark(q(i)).eq.1) p(i)=0.0e0 enddo call mtxdbc(ndf,ja,h,0,0.0e0,mark,1) call mtxdbc(ndf,ja,sm,smtx,0.0e0,mark,0) call mtxdbc(ndf,ja,su,smtx,0.0e0,mark,0) call mt0dbc(ja0,h0,0,0.0e0,mark,zp,nproc,irgn, + ndd,newndf,ndi,ipath,jequv,q,1) call mt0dbc(ja0,sm0,0,0.0e0,mark,zp,nproc,irgn, + ndd,newndf,ndi,ipath,jequv,q,0) call mt0dbc(ja0,su0,0,0.0e0,mark,zp,nproc,irgn, + ndd,newndf,ndi,ipath,jequv,q,0) else if(iprob.eq.3) then do i=1,ndf if(mark(q(i)).eq.1) then d(i)=0.0e0 rd(i)=0.0e0 p(i)=0.0e0 if(i.le.ndd) then d(i+ndf)=0.0e0 p(i+ndf)=0.0e0 endif 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(3,irgn)-1 if(iprob.eq.1.and.itask.eq.9) then do i=1,ndd 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.3) then do i=1,ndd gf(ii+i,1)=b(i) gf(ii+i,2)=u(i) gf(ii+i,3)=rd(i) gf(ii+i,4)=udot(i) enddo num=4 else if(iprob.eq.4) then do i=1,ndd 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)=rd(i) gf(ii+i,6)=udot(i) enddo num=6 else if(iprob.eq.5) then do i=1,ndd 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,ndd 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,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,2),gf(1,1),b,z,ispd,iord,1) jspd=1 if(ispd.ne.1) jspd=-1 if(iprob.eq.1.and.itask.eq.9) then call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),p,z,jspd,iord,1) else if(iprob.eq.3) then call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),rd,z,ispd,iord,1) else if(iprob.eq.4) then call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,3),p,z,1,iord,0) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),p,z,jspd,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,6),gf(1,5),rd,z,ispd,iord,1) else if(iprob.eq.5) then call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,sm0,gf(1,6),gf(1,1),b,z,0,iord,0) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,g0,gf(1,6),gf(1,5),dl,z,1,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,sm0,gf(1,4),gf(1,5),dl,z,-1,iord,0) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,su0,gf(1,2),gf(1,5),dl,z,-1,iord,0) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,a0,gf(1,4),gf(1,3),p,z,jspd,iord,1) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,h0,gf(1,2),gf(1,3),p,z,1,iord,0) call jmpmlt(irgn,nproc,newndf,ndi,ndf,ipath,jequv, + ja0,su0,gf(1,6),gf(1,3),p,z,0,iord,0) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2gd(iprob,irgn,jrgn,ispd,iord,a,h,g, + su,sm,a0,h0,g0,su0,sm0,b,d,p,dl,ib,ia,ia0,fa,fh,fg, 1 fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn,seqdot,ndf) c implicit real (a-h,o-z) implicit integer (i-n) integer + ib(10),ia(10,10),ia0(10,10) real 1 a(*),h(*),b(*),d(*),p(*),dl(*),fa(10,10),fb(25),fd(25), 2 fp(25),fh(10,10),fdl(25),a0(*),h0(*),g(*),fg(10,10), 3 g0(*),su(*),su0(*),sm(*),sm0(*),fsm(10,10),fsu(10,10) c c update global matrices/vectors from element matrices/vectors c ndof=(iord+1)*(iord+2)/2 c if(irgn.eq.jrgn) r=r+fp(12) if(iprob.eq.2) then do k=1,ndof kk=ib(k) if(kk.gt.0) then b(kk)=b(kk)-fp(k) else if (-kk.le.ndf) then b(-kk)=b(-kk)-fp(12+k) endif if(ispd.eq.1) then do j=k,ndof jk=min0(ia(k,j),ia(j,k)) a(jk)=a(jk)+fh(j,k) jk=min0(ia0(k,j),ia0(j,k)) if(jk.gt.0) a0(jk)=a0(jk)+fh(j,k) enddo else do j=1,ndof a(ia(j,k))=a(ia(j,k))+fh(j,k) jk=ia0(j,k) if(jk.gt.0) a0(jk)=a0(jk)+fh(j,k) enddo endif enddo else do k=1,ndof if(ib(k).gt.0) b(ib(k))=b(ib(k))-fb(k) if(ispd.eq.1) then do j=k,ndof jk=min0(ia(k,j),ia(j,k)) a(jk)=a(jk)+fa(j,k) jk=min0(ia0(k,j),ia0(j,k)) if(jk.gt.0) a0(jk)=a0(jk)+fa(j,k) enddo else do j=1,ndof a(ia(j,k))=a(ia(j,k))+fa(j,k) jk=ia0(j,k) if(jk.gt.0) a0(jk)=a0(jk)+fa(j,k) enddo endif enddo endif if(iprob.eq.1) then do k=1,ndof if(ib(k).gt.0) p(ib(k))=p(ib(k))+fp(k) enddo else if(iprob.eq.4) then if(irgn.eq.jrgn) then scleqn=scleqn-fp(11) seqdot=seqdot-fdl(11) endif do k=1,ndof kk=ib(k) if(kk.gt.0) then dl(kk)=dl(kk)-fdl(k) d(kk)=d(kk)-fd(k) p(kk)=p(kk)-fp(k) else dl(-kk)=dl(-kk)-fdl(k) d(-kk)=d(-kk)-fd(k) endif do j=k,ndof jk=min0(ia(k,j),ia(j,k)) h(jk)=h(jk)+fh(j,k) jk=min0(ia0(k,j),ia0(j,k)) if(jk.gt.0) h0(jk)=h0(jk)+fh(j,k) enddo enddo else if(iprob.eq.5) then do k=1,ndof kk=ib(k) if(kk.gt.0) then p(kk)=p(kk)-fp(k) dl(kk)=dl(kk)-fdl(k) else if (-kk.le.ndf) then dl(-kk)=dl(-kk)-fdl(12+k) endif do j=1,ndof sm(ia(j,k))=sm(ia(j,k))+fsm(j,k) su(ia(j,k))=su(ia(j,k))+fsu(j,k) jk=ia0(j,k) if(jk.gt.0) then sm0(jk)=sm0(jk)+fsm(j,k) su0(jk)=su0(jk)+fsu(j,k) endif enddo do j=k,ndof jk=min0(ia(k,j),ia(j,k)) h(jk)=h(jk)+fh(j,k) g(jk)=g(jk)+fg(j,k) jk=min0(ia0(k,j),ia0(j,k)) if(jk.gt.0) then h0(jk)=h0(jk)+fh(j,k) g0(jk)=g0(jk)+fg(j,k) endif enddo enddo else if(iprob.eq.3) then if(irgn.eq.jrgn) drdrl=drdrl+fp(11) do k=1,ndof kk=ib(k) if(kk.gt.0) then d(kk)=d(kk)-fd(k) p(kk)=p(kk)+fp(k) else d(-kk)=d(-kk)-fd(k) p(-kk)=p(-kk)+fp(k) endif enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine linsys(ip,rp,vx,vy,xm,ym,itnode,ibndry,ibedge, + u,u0,udot,um,uc,d1u,d2u,vx0,vy0,ndof,itdof, 1 ja,q,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,mark,icurv,isw, 2 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ibedge(2,*), 1 ja(*),q(*),mark(*),amtx,smtx,ib(10),ia(10,10), 2 itdof(ndof,*),icurv(3,*) real + rp(100),vx(*),vy(*),xm(*),ym(*),u(*),u0(*),udot(*), 1 um(*),uc(*),d1u(*),d2u(*),vx0(*),vy0(*), 2 a(*),h(*),g(*),su(*),sm(*),b(*),d(*),rd(*),p(*), 3 dl(*),bdlwr(*),bdupr(*) real + fa(10,10),fh(10,10),fg(10,10),fsm(10,10),fsu(10,10), 1 fb(25),fd(25),fp(25),fdl(25),fz(100) 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) nbf=ip(4) ndf=ip(5) iprob=ip(7) ispd=ip(8) itask=ip(9) iord=ip(26) c do i=1,100 fz(i)=0.0e0 enddo smtx=ja(ndf+1)-ja(1) if(ispd.eq.1) then amtx=0 else amtx=ja(ndf+1)-ja(1) endif c c initialize c do i=1,ja(ndf+1)-1+amtx a(i)=0.0e0 enddo c rl=rp(21) if(iabs(iprob).eq.6) then rl=rp(46) if(itask.eq.10) rl=rl+amax1(rp(47),rp(48)) endif sh=rp(45) rmu=rp(63) do i=1,ndf b(i)=0.0e0 enddo if(iprob.eq.1) then do i=1,ndf p(i)=0.0e0 enddo else if(iprob.eq.4) then sh=rp(64) do i=1,ndf p(i)=0.0e0 d(i)=0.0e0 dl(i)=0.0e0 d1u(i)=0.0e0 d2u(i)=0.0e0 enddo do i=1,ja(ndf+1)-1 h(i)=0.0e0 enddo else if(iprob.eq.5) then sh=rp(64) do i=1,ndf dl(i)=0.0e0 p(i)=0.0e0 d1u(i)=0.0e0 d2u(i)=0.0e0 enddo do i=1,ja(ndf+1)-1 h(i)=0.0e0 g(i)=0.0e0 enddo do i=1,ja(ndf+1)-1+smtx su(i)=0.0e0 sm(i)=0.0e0 enddo elseif(iprob.eq.3) then do i=1,ndf p(i)=0.0e0 d(i)=0.0e0 enddo endif c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i).eq.2) then call l2gmpe(i,ibedge,iord,ib,ndof,itdof) call eledbc(i,itnode,ibndry,ibedge,ib,vx,vy,xm,ym, + u,um,uc,rl,d1u,d2u,udot,iprob,iord,gdxy) endif enddo c r=0.0e0 drdrl=0.0e0 scleqn=0.0e0 seqdot=0.0e0 c c assemble and update elements c call ccurv(ntf,nbf,ibndry,ibedge,icurv) do i=1,ntf call l2gmpm(i,ndof,itdof,q,ndf,ja,ib,ia) call eleasm(i,itnode,ib,vx,vy,xm,ym,u,um,uc,d1u,d2u, + vx0,vy0,u0,bdlwr,bdupr,rl,sh,rmu,fa,fh,fg,fsm,fsu, 1 fb,fd,fp,fdl,iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) call l2g(iprob,ispd,iord,a,h,g,su,sm,b,d,p,dl, + ib,ia,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl, 1 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 it=ibedge(j,i)/4 call l2gmpm(it,ndof,itdof,q,ndf,ja,ib,ia) call elebdi(i,j,itnode,ibndry,ibedge,ib, + vx,vy,xm,ym,u,uc,rl,fh,fg,fsu, 1 fp,fdl,iprob,iord,p2xy) call l2g(iprob,ispd,iord,a,h,g,su,sm,b,d,p,dl, + ib,ia,fz,fh,fg,fz,fsu,fz,fz,fp,fdl,r,drdrl, 1 scleqn,seqdot) endif enddo endif c c neumann edge c if(ibndry(4,i).eq.1) then it=ibedge(1,i)/4 call l2gmpm(it,ndof,itdof,q,ndf,ja,ib,ia) call elenbc(i,itnode,ibndry,ibedge,ib,vx,vy,xm,ym, + u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 iprob,iord,gnxy) call l2g(iprob,ispd,iord,a,h,g,su,sm,b,d,p,dl, + ib,ia,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl, 1 scleqn,seqdot) c endif enddo c c modifications for bordered systems c if(iprob.eq.3.or.iprob.eq.4) call setrd(ndf,0,ispd, + ja,a,udot,d,rd,d1u,0) c c set dirichlet boundary conditions c call cdbc(ndf,nbf,iord,ndof,itdof,ibndry,ibedge,mark,q) anorm=0.0e0 do i=1,ndf if(mark(q(i)).eq.1) b(i)=0.0e0 anorm=amax1(abs(a(i)),anorm) enddo if(anorm.le.0.0e0) anorm=1.0e0 rp(22)=r rp(55)=anorm c call mtxdbc(ndf,ja,a,amtx,anorm,mark,1) c c scalar function c if(iprob.eq.1.and.itask.eq.9) then do i=1,ndf if(mark(q(i)).eq.1) p(i)=0.0e0 enddo else if(iprob.eq.4) then do i=1,ndf if(mark(q(i)).eq.1) then d(i)=0.0e0 rd(i)=0.0e0 dl(i)=0.0e0 p(i)=0.0e0 endif enddo call mtxdbc(ndf,ja,h,0,0.0e0,mark,1) rp(67)=scleqn rp(74)=seqdot call setbdl(rp,isw) elseif(iprob.eq.5) then do i=1,ndf if(mark(q(i)).eq.1) then p(i)=0.0e0 endif enddo call mtxdbc(ndf,ja,h,0,0.0e0,mark,1) call mtxdbc(ndf,ja,sm,smtx,0.0e0,mark,0) call mtxdbc(ndf,ja,su,smtx,0.0e0,mark,0) elseif(iprob.eq.3) then do i=1,ndf if(mark(q(i)).eq.1) then d(i)=0.0e0 rd(i)=0.0e0 p(i)=0.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine reord(n,ja,a,ja0,a0,q,ispd) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ja0(*),q(*),amtx real + 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 jacmap(ii,jj,ij,ji,ja,amtx) a(ij)=a0(j) a(ji)=a0(j+amtx) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cdbc(ndf,nbf,iord,ndof,itdof,ibndry,ibedge,mark,q) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itdof(ndof,*),ibedge(2,*),idof(10), 1 q(*),mark(*) c c this routine marks dirichlet boundary points c do i=1,ndf mark(i)=0 enddo c do i=1,nbf if(ibndry(4,i).eq.2) then call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 mark(q(idof(j)))=1 enddo endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mtxdbc(n,ja,a,amtx,anorm,mark,isym) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx,mark(*) real + 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.0e0 a(jj+amtx)=0.0e0 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.0e0 do jj=ja(i),ja(i+1)-1 a(jj)=0.0e0 if(mark(ja(jj)).eq.1) a(jj+amtx)=0.0e0 enddo else do jj=ja(i),ja(i+1)-1 if(mark(ja(jj)).eq.1) a(jj+amtx)=0.0e0 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.0e0 do jj=ja(i),ja(i+1)-1 a(jj+amtx)=0.0e0 if(mark(ja(jj)).eq.1) a(jj)=0.0e0 enddo else do jj=ja(i),ja(i+1)-1 if(mark(ja(jj)).eq.1) a(jj)=0.0e0 enddo endif enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mt0dbc(ja,a,amtx,anorm,mark,imark,nproc, + irgn,ndd,newndf,ndi,ipath,jequv,q,isym) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),amtx,mark(*),jequv(*),q(*),ipath(6,*),imark(*) real + a(*) c c set matrix dirichlet boundary conditions for interface matrix c n=ipath(4,nproc+2) do i=1,n imark(i)=0 enddo do ii=1,ndd if(mark(q(ii)).eq.1) then i=ii+ipath(3,irgn)-1 it=i 20 imark(it)=1 it=jequv(it) if(it.ne.i) go to 20 endif enddo do ii=newndf+1,ndi if(mark(q(ii)).eq.1) then i=ii-newndf+ipath(3,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.0e0 a(jj+amtx)=0.0e0 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.0e0 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.0e0 if(mj.eq.1) a(jj+amtx)=0.0e0 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.0e0 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.0e0 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.0e0 if(mj.eq.1) a(jj)=0.0e0 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.0e0 enddo endif enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2g(iprob,ispd,iord,a,h,g,su,sm,b,d,p,dl, + ib,ia,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn,seqdot) c implicit real (a-h,o-z) implicit integer (i-n) integer + ib(10),ia(10,10) real 1 a(*),h(*),b(*),d(*),p(*),dl(*),fa(10,10),fb(25),fd(25), 2 fp(25),fh(10,10),fdl(25),g(*),fg(10,10),su(*),sm(*), 3 fsm(10,10),fsu(10,10) c c update global matrices/vectors from element matrices/vectors c ndof=(iord+1)*(iord+2)/2 c r=r+fp(12) if(iprob.eq.2) then do k=1,ndof b(ib(k))=b(ib(k))-fp(k) if(ispd.eq.1) then do j=k,ndof jk=min0(ia(k,j),ia(j,k)) a(jk)=a(jk)+fh(j,k) enddo else do j=1,ndof a(ia(j,k))=a(ia(j,k))+fh(j,k) enddo endif enddo else do k=1,ndof b(ib(k))=b(ib(k))-fb(k) if(ispd.eq.1) then do j=k,ndof jk=min0(ia(k,j),ia(j,k)) a(jk)=a(jk)+fa(j,k) enddo else do j=1,ndof a(ia(j,k))=a(ia(j,k))+fa(j,k) enddo endif enddo endif c if(iprob.eq.1) then do k=1,ndof p(ib(k))=p(ib(k))+fp(k) enddo else if(iprob.eq.4) then scleqn=scleqn-fp(11) seqdot=seqdot-fdl(11) do k=1,ndof dl(ib(k))=dl(ib(k))-fdl(k) d(ib(k))=d(ib(k))-fd(k) p(ib(k))=p(ib(k))-fp(k) do j=k,ndof jk=min0(ia(k,j),ia(j,k)) h(jk)=h(jk)+fh(j,k) enddo enddo else if(iprob.eq.5) then do k=1,ndof dl(ib(k))=dl(ib(k))-fdl(k) p(ib(k))=p(ib(k))-fp(k) do j=1,ndof sm(ia(j,k))=sm(ia(j,k))+fsm(j,k) su(ia(j,k))=su(ia(j,k))+fsu(j,k) enddo do j=k,ndof jk=min0(ia(k,j),ia(j,k)) 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(11) do k=1,ndof d(ib(k))=d(ib(k))-fd(k) p(ib(k))=p(ib(k))+fp(k) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkdof(ip,itnode,ibndry,itedge,ibedge,iequv,mark, + ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),itedge(3,*),mark(*), 1 ibedge(2,*),itdof(ndof,*),index(3,3),idof(10),iequv(*), 2 kdof(10) save index data index/1,2,3,2,3,1,3,1,2/ c ntf=ip(1) nvf=ip(2) nbf=ip(4) iord=ip(26) c c label vertices c ndf=0 call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,mark,iflag) call cequv1(nvf,nbf,ibndry,iequv,1) do i=1,nvf if(iequv(i).eq.i) then ndf=ndf+1 mark(i)=ndf else mark(i)=mark(iequv(i)) endif enddo c do i=1,ntf do j=1,ndof idof(j)=0 enddo do j=1,3 idof(j)=mark(itnode(j,i)) enddo if(iord.eq.1) go to 20 c c check edges c do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 if(k.gt.i) go to 10 ks=itedge(j,i)-4*k else if(itedge(j,i).lt.0) then iedge=-itedge(j,i) if(ibndry(4,iedge).ge.1) go to 10 js=1 if(ibndry(4,iedge).eq.0) then if(ibedge(js,iedge)/4.eq.i) js=2 else iedge=-ibndry(4,iedge) endif k=ibedge(js,iedge)/4 if(k.gt.i) go to 10 ks=ibedge(js,iedge)-4*k else stop 6432 endif call l2gmap(k,kdof,ndof,itdof) if(iord.eq.2) then idof(j+3)=kdof(ks+3) else j2=index(2,j) j3=index(3,j) k2=index(2,ks) k3=index(3,ks) if(kdof(k2).eq.idof(j2)) then if(kdof(k3).ne.idof(j3)) stop 6433 idof(2*j+2)=kdof(2*ks+2) idof(2*j+3)=kdof(2*ks+3) else if(kdof(k3).ne.idof(j2)) stop 6434 if(kdof(k2).ne.idof(j3)) stop 6435 idof(2*j+2)=kdof(2*ks+3) idof(2*j+3)=kdof(2*ks+2) endif endif 10 enddo 20 do j=1,ndof if(idof(j).eq.0) then ndf=ndf+1 idof(j)=ndf endif itdof(j,i)=idof(j) enddo enddo c ip(5)=ndf return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2gmap(itri,idof,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + idof(*),itdof(ndof,*) c c compute degree of freedom for element itri c do j=1,ndof idof(j)=itdof(j,itri) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2gmpe(iedge,ibedge,iord,idof,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibedge(2,*),itdof(ndof,*),idof(10),index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c c edge degrees of freedom c it=ibedge(1,iedge)/4 ied=ibedge(1,iedge)-4*it i2=index(2,ied) i3=index(3,ied) c idof(1)=itdof(i2,it) idof(iord+1)=itdof(i3,it) if(iord.eq.2) then idof(2)=itdof(ied+3,it) else if(iord.eq.3) then idof(2)=itdof(2*ied+2,it) idof(3)=itdof(2*ied+3,it) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2gmpm(itri,ndof,itdof,q,ndf,ja,ib,ia) c implicit real (a-h,o-z) implicit integer (i-n) integer + itdof(ndof,*),ja(*),q(*),amtx,ib(10),ia(10,10) c do j=1,ndof ib(j)=itdof(j,itri) enddo c amtx=ja(ndf+1)-ja(1) do k=1,ndof ia(k,k)=q(ib(k)) do j=k+1,ndof call jacmap(q(ib(k)),q(ib(j)),kj,jk,ja,amtx) ia(k,j)=kj ia(j,k)=jk enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine l2gmpd(itri,irgn,jrgn,ndof,itdof,jequv,q,ja,ja0, + ndf,ndd,newndf,ndi,nproc,ipath,ib,ib0,ia,ia0) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),q(*),amtx,amtx0,ja0(*),itdof(ndof,*),ipath(6,*), 1 jequv(*),ib(10),ia(10,10),ia0(10,10),ib0(10) c c update global matrices/vectors from element matrices/vectors c nn=ipath(4,nproc+2) amtx0=ja0(nn+1)-ja0(1) c do j=1,ndof ib(j)=itdof(j,itri) enddo amtx=ja(ndf+1)-ja(1) if(irgn.eq.jrgn) then do k=1,ndof ib0(k)=ib(k) enddo else do k=1,ndof ivk=ib(k) if(ivk.le.ndd) then ib0(k)=-(ivk+ndf) else ib0(k)=-ivk endif enddo endif do k=1,ndof ia(k,k)=q(ib(k)) do j=k+1,ndof call jacmap(q(ib(k)),q(ib(j)),kj,jk,ja,amtx) ia(k,j)=kj ia(j,k)=jk enddo c c interface matrices c ivk=ib(k) if(ivk.le.ndd) then ivkb=i2j(ivk,irgn,jrgn,1,0,ipath,jequv) else if(ivk.le.newndf) then ivkb=-ivk else if(ivk.le.ndi) then ii=ivk-newndf ivkb=i2j(ii,nproc+1,jrgn,1,0,ipath,jequv) else ivkb=-ivk endif if(ivkb.gt.0) then ia0(k,k)=ivkb else ia0(k,k)=0 endif do j=k+1,ndof ivj=ib(j) if(ivj.le.ndd) then ivjb=i2j(ivj,irgn,jrgn,1,0,ipath,jequv) else if(ivj.le.newndf) then ivjb=-ivj else if(ivj.le.ndi) then ii=ivj-newndf 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) ia0(k,j)=kj ia0(j,k)=jk else ia0(k,j)=0 ia0(j,k)=0 endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eleasm(itri,itnode,idof,vx,vy,xm,ym,u,um,uc,d1u,d2u, + vx0,vy0,u0,bdlwr,bdupr,rl,sh,rmu,a,h,g,sm,su,b,d,p,dl, 1 iord,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),map(5,5),idof(*),icurv(3,*) real + vx(*),vy(*),xm(*),ym(*),u(*),um(*),uc(*),d1u(*),d2u(*), 1 vx0(*),vy0(*),u0(*),bdlwr(*),bdupr(*),a(10,10),h(10,10), 2 g(10,10),sm(10,10),su(10,10),b(25),d(25),p(25),dl(25) real + c(3,25),wt(25),gv(10),gx(10),gy(10),gxx(10),gxy(10), 1 gyy(10),ca1(15),ca2(15),cf(15),cp1(15),tx(3),ty(3), 2 x(3),y(3),bx1(5),by1(5),bx2(5),by2(5),d11(5),d12(5), 3 d21(5),d22(5),a10(5),s(5),a11(5),a12(5),a20(5),a21(5), 4 a22(5),b1(5),b2(5),r(5),xp(10),yp(10),xn(3),yn(3),bw(10) external a1xy,a2xy,fxy,p1xy save npts,wt,c,map,bw 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 bw/1.0e0,1.0e0,1.0e0,3.0e0,3.0e0,3.0e0,3.0e0,3.0e0, + 3.0e0,6.0e0/ c c this routine computes the element stiffness matrix and c right hand side c c iord = 1 - piecewise linear basis functions c 2 - piecewise quadratic basis functions c 3 - piecewise cubic basis 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_11| | drl | | p_11| c c | h a^t su | | du | | p | c | a 0 sm | | dum | = - | b | c | su^t sm^t g | | duc | | dl | c c 3 3 3 c |\ |\ |\ c | \ | \ 6 | \ 5 c | \ | \ | \ c | \ 5| \ 4 | \ c | \ | \ | \ c | \ | \ 7 | 10 \ 4 c |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 c c c c if(iord.eq.1) then npts=3 else if(iord.eq.2) then npts=6 else npts=12 endif call cquad2(npts,wt,c) c ndof=((iord+1)*(iord+2))/2 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 and normal vectors c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) c call cnodec(itri,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) c do i=1,ndof b(i)=0.0e0 d(i)=0.0e0 p(i)=0.0e0 dl(i)=0.0e0 do j=1,ndof a(i,j)=0.0e0 h(i,j)=0.0e0 g(i,j)=0.0e0 sm(i,j)=0.0e0 su(i,j)=0.0e0 enddo enddo p(11)=0.0e0 p(12)=0.0e0 dl(11)=0.0e0 dl(12)=0.0e0 c det=abs(det)/2.0e0 c do i=1,npts c c evaluate basis functions c call beval(c(1,i),x,y,gv,gx,gy,iord) if(isw.eq.0) then we=wt(i)*det xx=c(1,i)*xp(1)+c(2,i)*xp(2)+c(3,i)*xp(3) yy=c(1,i)*yp(1)+c(2,i)*yp(2)+c(3,i)*yp(3) else c c isoparamtric map for elements with curved edges c p11=0.0e0 p12=0.0e0 p21=0.0e0 p22=0.0e0 xx=0.0e0 yy=0.0e0 do j=1,ndof xx=xx+xp(j)*gv(j) yy=yy+yp(j)*gv(j) p11=p11+xp(j)*gx(j) p12=p12+xp(j)*gy(j) p21=p21+yp(j)*gx(j) p22=p22+yp(j)*gy(j) enddo detn=p11*p22-p12*p21 do j=1,3 xn(j)=(p22*x(j)-p21*y(j))/detn yn(j)=(p11*y(j)-p12*x(j))/detn enddo call beval(c(1,i),xn,yn,gv,gx,gy,iord) we=wt(i)*det*abs(detn) endif c c function evaluations c uu=0.0e0 ux=0.0e0 uy=0.0e0 do j=1,ndof uu=uu+gv(j)*u(idof(j)) ux=ux+gx(j)*u(idof(j)) uy=uy+gy(j)*u(idof(j)) enddo if(iprob.eq.4.or.iprob.eq.5) then umu=0.0e0 umx=0.0e0 umy=0.0e0 d1=0.0e0 d1x=0.0e0 d1y=0.0e0 d2=0.0e0 d2x=0.0e0 d2y=0.0e0 do j=1,ndof umu=umu+gv(j)*um(idof(j)) umx=umx+gx(j)*um(idof(j)) umy=umy+gy(j)*um(idof(j)) d1 =d1 +gv(j)*d1u(idof(j)) d1x=d1x+gx(j)*d1u(idof(j)) d1y=d1y+gy(j)*d1u(idof(j)) d2 =d2 +gv(j)*d2u(idof(j)) d2x=d2x+gx(j)*d2u(idof(j)) d2y=d2y+gy(j)*d2u(idof(j)) enddo endif if(iprob.eq.5) then ucu=0.0e0 ucx=0.0e0 ucy=0.0e0 do j=1,ndof ucu=ucu+gv(j)*uc(idof(j)) ucx=ucx+gx(j)*uc(idof(j)) ucy=ucy+gy(j)*uc(idof(j)) enddo rr=ucu we5=we*det*rmu*sh else rr=rl endif do k=1,15 ca1(k)=0.0e0 ca2(k)=0.0e0 cp1(k)=0.0e0 cf(k)=0.0e0 enddo 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=0.0e0 do j=1,ndof uu0=uu0+gv(j)*u0(idof(j)) enddo 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 sharfetter gummel upwinding c qq=0.0e0 if(ispd.eq.0) then do k=1,5 bx1(k)=ca1(map(2,k)) by1(k)=ca2(map(2,k)) c* bx2(k)=cf(map(3,k)) c* by2(k)=cf(map(4,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.0e0 a11(k)=0.0e0 a12(k)=0.0e0 a20(k)=0.0e0 a21(k)=0.0e0 a22(k)=0.0e0 b1(k)=0.0e0 b2(k)=0.0e0 enddo call upwind(bx1,by1,d11,d12,d21,d22, 1 tx,ty,x,y,a10,a11,a12,a20,a21,a22) call upwind(bx2,by2,d11,d12,d21,d22, 1 tx,ty,x,y,a10,a11,a12,a20,a21,a22) c* call upwind(bx2,by2,d11,d21,d12,d22, c* 1 tx,ty,x,y,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 qq=det*(ca1(2)**2+ca2(2)**2+cf(3)**2+cf(4)**2) qq=qq*det qq=qq/(1.0e0+qq) 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 basis functions for quadratic stabilization terms c if(iprob.eq.5.or.qq.gt.0.0e0) then if(isw.eq.0) then call beval2(c(1,i),x,y,gxx,gxy,gyy,iord) else call beval2(c(1,i),xn,yn,gxx,gxy,gyy,iord) endif endif c c update rho c p(12)=p(12)+cp1(1)*we c c adjust derivatives c if(iprob.eq.4.or.iprob.eq.5) then 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(12)=dl(12)+cp1(1)*we p(11)=p(11)+cp1(5)*we dl(11)=dl(11)+cp1(15)*we do k=1,ndof qx=we*gx(k) qy=we*gy(k) qv=we*gv(k) c 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=1,ndof a(k,j)=a(k,j)+s(2)*gv(j)+s(3)*gx(j)+s(4)*gy(j) enddo c if(qq.gt.0.0e0.and.iord.gt.1) then uxx=0.0e0 uxy=0.0e0 uyy=0.0e0 do j=1,ndof uxx=uxx+gxx(j)*u(idof(j)) uxy=uxy+gxy(j)*u(idof(j)) uyy=uyy+gyy(j)*u(idof(j)) enddo c qxx=we*gxx(k)*qq qxy=we*gxy(k)*qq qyy=we*gyy(k)*qq b(k)=b(k)+uxx*qxx+uxy*qxy+uyy*qyy c do j=1,ndof a(k,j)=a(k,j)+qxx*gxx(j)+qxy*gxy(j)+qyy*gyy(j) enddo endif if(iprob.eq.5) then dl(k)=dl(k)+cp1(5)*qv rr=cp1(15)*qv do j=1,ndof 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 c if(iord.gt.1) then ucxx=0.0e0 ucxy=0.0e0 ucyy=0.0e0 do j=1,ndof ucxx=ucxx+gxx(j)*uc(idof(j)) ucxy=ucxy+gxy(j)*uc(idof(j)) ucyy=ucyy+gyy(j)*uc(idof(j)) enddo c qxx=we5*gxx(k) qxy=we5*gxy(k) qyy=we5*gyy(k) dl(k)=dl(k)+ucxx*qxx+ucxy*qxy+ucyy*qyy c do j=1,ndof g(k,j)=g(k,j) + +qxx*gxx(j)+qxy*gxy(j)+qyy*gyy(j) enddo endif else if(iprob.eq.2.or.iprob.eq.4) then dl(k)=dl(k)+r(5) do j=1,ndof h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j) enddo endif enddo enddo c c modifications for interior point method c if(iprob.eq.1) then do k=1,ndof ss=0.0e0 do j=1,ndof ss=ss+a(j,k)*um(idof(j)) enddo p(k)=p(k)-ss enddo else if(iprob.eq.2) then det=det/6.0e0 do k=1,ndof ru=0.0e0 uu=0.0e0 j=idof(k) if(u(j).gt.bdlwr(j)) then ru=ru+rmu/(u(j)-bdlwr(j)) uu=uu+rmu/(u(j)-bdlwr(j))**2 endif if(u(j).lt.bdupr(j)) then ru=ru+rmu/(u(j)-bdupr(j)) uu=uu+rmu/(u(j)-bdupr(j))**2 endif p(k)=p(k)-ru*det*bw(k) p(12+k)=-ru*det*bw(k) h(k,k)=h(k,k)+uu*det*bw(k) enddo else if(iprob.eq.5) then det=det/6.0e0 do k=1,ndof ru=0.0e0 uu=0.0e0 j=idof(k) if(uc(j).gt.bdlwr(j)) then ru=ru+rmu/(uc(j)-bdlwr(j)) uu=uu+rmu/(uc(j)-bdlwr(j))**2 endif if(uc(j).lt.bdupr(j)) then ru=ru+rmu/(uc(j)-bdupr(j)) uu=uu+rmu/(uc(j)-bdupr(j))**2 endif dl(k)=dl(k)-ru*det*bw(k) dl(12+k)=-ru*det*bw(k) g(k,k)=g(k,k)+uu*det*bw(k) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ccurv(ntf,nbf,ibndry,ibedge,icurv) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibedge(2,*),ibndry(6,*),icurv(3,*) c c mark curved edges (pointer is icen) c do i=1,ntf do j=1,3 icurv(j,i)=0 enddo enddo c do i=1,nbf if(ibndry(3,i).gt.0) then do j=1,2 itri=ibedge(j,i)/4 if(itri.gt.0) then iside=ibedge(j,i)-4*itri icurv(iside,itri)=ibndry(3,i) endif enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cnodec(itri,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),icurv(3,*) real + vx(*),vy(*),xm(*),ym(*),xp(10),yp(10) save index data index/1,2,3,2,3,1,3,1,2/ c c compute nodes for isoparametric mapping c pi=3.141592653589793e0 isw=0 do j=1,3 xp(j)=vx(itnode(j,itri)) yp(j)=vy(itnode(j,itri)) if(icurv(j,itri).gt.0) isw=isw+1 enddo c if(isw.eq.0) return c if(iord.eq.1) then isw=0 else if(iord.eq.2) then do j=1,3 j2=index(2,j) j3=index(3,j) if(icurv(j,itri).le.0) then xp(j+3)=(xp(j2)+xp(j3))/2.0e0 yp(j+3)=(yp(j2)+yp(j3))/2.0e0 else icen=icurv(j,itri) call arc(xp(j2),yp(j2),xp(j3),yp(j3), + xm(icen),ym(icen),theta2,theta3,rad,hh) tt=(theta2+theta3)*pi/2.0e0 xp(j+3)=xm(icen)+rad*cos(tt) yp(j+3)=ym(icen)+rad*sin(tt) endif enddo else if(iord.eq.3) then xx=0.0e0 yy=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) j4=2*j+2 j5=2*j+3 if(icurv(j,itri).le.0) then xp(j4)=(2.0e0*xp(j2)+xp(j3))/3.0e0 yp(j4)=(2.0e0*yp(j2)+yp(j3))/3.0e0 xp(j5)=(2.0e0*xp(j3)+xp(j2))/3.0e0 yp(j5)=(2.0e0*yp(j3)+yp(j2))/3.0e0 else icen=icurv(j,itri) call arc(xp(j2),yp(j2),xp(j3),yp(j3), + xm(icen),ym(icen),theta2,theta3,rad,hh) tt=(2.0e0*theta2+theta3)*pi/3.0e0 xp(j4)=xm(icen)+rad*cos(tt) yp(j4)=ym(icen)+rad*sin(tt) tt=(2.0e0*theta3+theta2)*pi/3.0e0 xp(j5)=xm(icen)+rad*cos(tt) yp(j5)=ym(icen)+rad*sin(tt) endif xx=xx+xp(j)+xp(j4)+xp(j5) yy=yy+yp(j)+yp(j4)+yp(j5) enddo xp(10)=xx/9.0e0 yp(10)=yy/9.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine upwind(bx,by,d11,d12,d21,d22,tx,ty,x,y, + a10,a11,a12,a20,a21,a22) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + tx(3),ty(3),x(3),y(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(abs(bx(1))+abs(by(1)).eq.0.0e0) return dd=(d12(1)+d21(1))/2.0e0 det=d11(1)*d22(1)-dd**2 if(abs(det).eq.0.0e0) 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 cc if(g(kmin).lt.0.0e0) then cc k2=index(2,kmin) cc k3=index(3,kmin) cc bmax=amax1(bp(k2),bp(k3),bm(k2),bm(k3)) cc do j=1,3 cc rm(j)=bm(j)/bmax cc rp(j)=bp(j)/bmax cc enddo cc do j=1,3 cc j2=index(2,j) cc j3=index(3,j) cc rr=rm(j2)*rm(j3)+rp(j2)*rp(j3) cc r(j)=rp(j2)*rm(j3)+rr cc s(j)=rm(j2)*rp(j3)+rr cc enddo cc ratio=amin1(1.0e0,-r(kmin)/(r(k2)+r(k3)), cc + -s(kmin)/(s(k2)+s(k3))) cc bp(kmin)=bp(kmin)*ratio cc bm(kmin)=bm(kmin)*ratio cc endif c c compute upwind diffusion matrix c c2=(bm(3)-bp(3)+bp(1)-bm(1))/3.0e0 c3=(bm(1)-bp(1)+bp(2)-bm(2))/3.0e0 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 cc if(g(kmin).lt.0.0e0) then cc e2=3.0e0*c2-(bx(1)*x(2)+by(1)*y(2)) cc e3=3.0e0*c3-(bx(1)*x(3)+by(1)*y(3)) cc a10(1)=a10(1)+tx(3)*e2-tx(2)*e3 cc a20(1)=a20(1)+ty(3)*e2-ty(2)*e3 cc endif c c now do derivatives c do 10 k=2,5 aa=abs(bx(k))+abs(by(k))+abs(d11(k)) + +abs(d12(k))+abs(d21(k))+abs(d22(k)) if(aa.le.0.0e0) go to 10 ddp=(d12(k)+d21(k))/2.0e0 detp=d11(k)*d22(1)+d11(1)*d22(k)-2.0e0*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 cc if(g(kmin).lt.0.0e0) then cc bp(kmin)=bp(kmin)*ratio cc bm(kmin)=bm(kmin)*ratio cc endif c c compute upwind diffusion matrix c c2=(bm(3)-bp(3)+bp(1)-bm(1))/3.0e0 c3=(bm(1)-bp(1)+bp(2)-bm(2))/3.0e0 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 cc if(g(kmin).lt.0.0e0) then cc e2=3.0e0*c2-(bx(k)*x(2)+by(k)*y(2)) cc e3=3.0e0*c3-(bx(k)*x(3)+by(k)*y(3)) cc a10(k)=a10(k)+tx(3)*e2-tx(2)*e3 cc a20(k)=a20(k)+ty(3)*e2-ty(2)*e3 cc endif 10 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bexp(beta,dbeta,bp,bm,dbp,dbm) c implicit real (a-h,o-z) implicit integer (i-n) c c careful bernoulli evaluation c if(beta.gt.10.0e0) then ez=exp(-beta) ezp=-ez*dbeta bm=beta/(1.0e0-ez) dbm=(dbeta+bm*ezp)/(1.0e0-ez) bp=ez*bm dbp=ezp*bm+ez*dbm else if(beta.lt.-10.0e0) then ez=exp(beta) ezp=ez*dbeta bp=beta/(ez-1.0e0) dbp=(dbeta-bp*ezp)/(ez-1.0e0) bm=ez*bp dbm=ezp*bp+ez*dbp else z=beta/2.0e0 zp=dbeta/2.0e0 ezp=exp(z) ezpp=ezp*zp ezm=1.0e0/ezp ezmp=-ezm*zp if(abs(z).le.1.0e-4) then zz=z**2 zzp=2.0e0*z*zp sz=1.0e0+zz/6.0e0*(1.0e0+zz/20.0e0) szp=zzp/6.0e0*(1.0e0+zz/10.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine elenbc(iedge,itnode,ibndry,ibedge,idof,vx,vy,xm,ym, + u,um,uc,rl,a,h,g,sm,su,b,d,p,dl,iprob,iord,gnxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),index(3,3),ibedge(2,*),idof(*) real + vx(*),vy(*),xm(*),ym(*),u(*),um(*),uc(*), 1 a(10,10),h(10,10),g(10,10),sm(10,10),su(10,10),b(25), 2 d(25),p(25),dl(25) real 1 c(2,6),wt(6),gv(10),gg(6),cc(3),r(6) external gnxy c save npts,wt,c,index data index/1,2,3,2,3,1,3,1,2/ c c c this routine computes the contribution to the element c from the natural boundary conditions. c c iord = 1 - piecewise linear basis functions c 2 - piecewise quadratic bump functions c 3 - 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(iord.eq.1) then npts=2 else if(iord.eq.2) then npts=3 else npts=4 endif call cquad1(npts,wt,c) pi=3.141592653589793e0 c c do basis function and gnxy evaluations c ndof=((iord+1)*(iord+2))/2 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) icen=ibndry(3,iedge) itag=ibndry(6,iedge) c do i=1,ndof b(i)=0.0e0 d(i)=0.0e0 p(i)=0.0e0 dl(i)=0.0e0 do j=1,ndof a(i,j)=0.0e0 h(i,j)=0.0e0 g(i,j)=0.0e0 sm(i,j)=0.0e0 su(i,j)=0.0e0 enddo enddo p(11)=0.0e0 p(12)=0.0e0 dl(11)=0.0e0 dl(12)=0.0e0 c if(icen.le.0) then hh=sqrt((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 xx=c(1,i)*vx(iv1)+c(2,i)*vx(iv2) yy=c(1,i)*vy(iv1)+c(2,i)*vy(iv2) cc(k1)=c(1,i) cc(k2)=c(2,i) cc(kside)=0.0e0 else tt=(c(1,i)*theta1+c(2,i)*theta2)*pi xx=xm(icen)+rad*cos(tt) yy=ym(icen)+rad*sin(tt) call bari(xx,yy,vx,vy,itnode(1,ktri),cc) endif call beval1(cc,gv,iord) uu=0.0e0 do j=1,ndof uu=uu+gv(j)*u(idof(j)) enddo do k=1,6 gg(k)=0.0e0 r(k)=0.0e0 enddo if(iprob.eq.5) then rr=0.0e0 do j=1,ndof rr=rr+gv(j)*uc(idof(j)) enddo else rr=rl endif call gnxy(xx,yy,uu,rr,itag,gg) we=wt(i)*hh if(iprob.eq.4.or.iprob.eq.5) then umu=0.0e0 do j=1,ndof umu=umu+gv(j)*um(idof(j)) enddo do j=1,6 r(j)=umu*gg(j) enddo endif p(11)=p(11)+r(3)*we dl(11)=dl(11)+r(6)*we dl(12)=dl(12)+r(1)*we do k=1,ndof 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=1,ndof 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=1,ndof 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) then dl(k)=dl(k)-r(5)*q do j=1,ndof h(k,j)=h(k,j)-r(4)*q*gv(j) enddo endif enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine elebdi(iedge,iside,itnode,ibndry,ibedge,idof, + vx,vy,xm,ym,u,uc,rl,h,g,su,p,dl,iprob,iord,p2xy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),index(3,3), 1 map(5,5),idof(*) real + vx(*),vy(*),xm(*),ym(*),u(*),uc(*),h(10,10),g(10,10), 1 su(10,10),p(25),dl(25) real + gv(10),gx(10),gy(10),c(2,6),wt(6),cp(15),r(5),cc(3), 1 tx(3),ty(3),x(3),y(3) external p2xy 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 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(iord.eq.1) then npts=2 else if(iord.eq.2) then npts=3 else npts=4 endif call cquad1(npts,wt,c) pi=3.141592653589793e0 c ndof=((iord+1)*(iord+2))/2 do i=1,ndof p(i)=0.0e0 dl(i)=0.0e0 do j=1,ndof h(i,j)=0.0e0 g(i,j)=0.0e0 su(i,j)=0.0e0 enddo enddo p(11)=0.0e0 p(12)=0.0e0 dl(11)=0.0e0 dl(12)=0.0e0 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) c c compute tangent and normal vectors c call afmap(ktri,itnode,vx,vy,tx,ty,x,y,det) c hh=sqrt(tx(kside)**2+ty(kside)**2) dx0=ty(kside)/hh dy0=-tx(kside)/hh 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=cos(tt) dy=sin(tt) xx=xm(icen)+rad*dx yy=ym(icen)+rad*dy call bari(xx,yy,vx,vy,itnode(1,ktri),cc) if(dx*dx0+dy*dy0.lt.0.0e0) then dx=-dx dy=-dy endif else xx=c(1,i)*vx(iv1)+c(2,i)*vx(iv2) yy=c(1,i)*vy(iv1)+c(2,i)*vy(iv2) cc(k1)=c(1,i) cc(k2)=c(2,i) cc(kside)=0.0e0 dx=dx0 dy=dy0 endif call beval(cc,x,y,gv,gx,gy,iord) c uu=0.0e0 ux=0.0e0 uy=0.0e0 do j=1,ndof uu=uu+gv(j)*u(idof(j)) ux=ux+gx(j)*u(idof(j)) uy=uy+gy(j)*u(idof(j)) enddo c c function evaluations c we=wt(i)*hh do k=1,15 cp(k)=0.0e0 enddo if(iprob.eq.5) then rr=0.0e0 do j=1,ndof rr=rr+gv(j)*uc(idof(j)) enddo else rr=rl endif call p2xy(xx,yy,dx,dy,uu,ux,uy,rr,itag,ktag,cp) c p(11)=p(11)+cp(5)*we dl(11)=dl(11)+cp(15)*we p(12)=p(12)+cp(1)*we dl(12)=dl(12)+cp(1)*we c do k=1,ndof 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=1,ndof 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=1,ndof 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eledbc(iedge,itnode,ibndry,ibedge,idof,vx,vy,xm,ym, + u,um,uc,rl,d1u,d2u,udot,iprob,iord,gdxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),index(3,3),ibedge(2,*), 1 idof(*) real + vx(*),vy(*),xm(*),ym(*),u(*),um(*),uc(*),udot(*), 1 d1u(*),d2u(*) real 1 g(10) external gdxy c save index data index/1,2,3,2,3,1,3,1,2/ c c this routine computes the contribution to the element c from the dirichlet boundary conditions. c c iord = 1 - piecewise linear basis functions c 2 - piecewise quadratic bump functions c 3 - piecewise quadratic functions c c gg( 1) = g c gg( 2) = dg/drl c gg( 3) = d2g/drl drl c ktri=ibedge(1,iedge)/4 kside=ibedge(1,iedge)-4*ktri k1=index(2,kside) k2=index(3,kside) c c do basis function and gnxy evaluations c iv1=itnode(k1,ktri) iv2=itnode(k2,ktri) icen=ibndry(3,iedge) itag=ibndry(6,iedge) isw=0 c if(icen.gt.0.and.iord.ge.2) then pi=3.141592653589793e0 isw=1 call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(icen),ym(icen),theta1,theta2,rad,hh) endif c do i=1,iord+1 frac=float(i-1)/float(iord) if(isw.eq.0) then xx=vx(iv1)+frac*(vx(iv2)-vx(iv1)) yy=vy(iv1)+frac*(vy(iv2)-vy(iv1)) else tt=(theta1+frac*(theta2-theta1))*pi xx=xm(icen)+rad*cos(tt) yy=ym(icen)+rad*sin(tt) endif do k=1,8 g(k)=0.0e0 enddo ivk=idof(i) if(iprob.eq.5) then rr=uc(ivk) else rr=rl endif call gdxy(xx,yy,rr,itag,g) u(ivk)=g(1) if(iabs(iprob).eq.1) um(ivk)=0.0e0 if(iabs(iprob).eq.3.or.iabs(iprob).eq.4) then udot(ivk)=g(2) endif if(iabs(iprob).eq.4.or.iabs(iprob).eq.5) then um(ivk)=0.0e0 d1u(ivk)=g(2) d2u(ivk)=g(3) endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cquad2(npts,wt,c) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + c(3,25),wt(25) save index data index/1,2,3,2,3,1,3,1,2/ c if(npts.eq.3) then ww=1.0e0/3.0e0 cc=2.0e0/3.0e0 ss=0.5e0-cc/2.0e0 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.0e0/3.0e0 wt(1)=1.0e0 c(1,1)=cc c(2,1)=cc c(3,1)=cc else if(npts.eq.6) then ww=0.109951743655322e0 cc=0.816847572980459e0 ss=0.5e0-cc/2.0e0 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.0e0/3.0e0-ww cc=0.108103018168070e0 ss=0.5e0-cc/2.0e0 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.050844906370207e0 cc=0.873821971016996e0 ss=0.5e0-cc/2.0e0 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.116786275726379e0 cc=0.501426509658179e0 ss=0.5e0-cc/2.0e0 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.082851075618374e0 cc=0.636502499121399e0 ss=0.310352451033785e0 tt=0.053145049844816e0 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 else if(npts.eq.25) then wt(1)=0.835233998051964e-1 do j=1,3 c(j,1)=1.0e0/3.0e0 enddo ww=0.722985059205674e-2 cc=0.426913409105056e-2 ss=0.5e0-cc/2.0e0 do j=1,3 wt(j+1)=ww c(index(1,j),j+1)=ss c(index(2,j),j+1)=ss c(index(3,j),j+1)=cc enddo ww=0.744921779209805e-1 cc=0.143975100541888e0 ss=0.5e0-cc/2.0e0 do j=1,3 wt(j+4)=ww c(index(1,j),j+4)=ss c(index(2,j),j+4)=ss c(index(3,j),j+4)=cc enddo ww=0.786464734031085e-1 cc=0.630487174513551e0 ss=0.5e0-cc/2.0e0 do j=1,3 wt(j+7)=ww c(index(1,j),j+7)=ss c(index(2,j),j+7)=ss c(index(3,j),j+7)=cc enddo ww=0.692832308710750e-2 cc=0.959037562856645e0 ss=0.5e0-cc/2.0e0 do j=1,3 wt(j+10)=ww c(index(1,j),j+10)=ss c(index(2,j),j+10)=ss c(index(3,j),j+10)=cc enddo ww=0.295183203347794e-1 cc=0.350029898972720e-1 ss=0.136573576256033e0 tt=0.828423433846695e0 do j=1,3 wt(j+13)=ww c(index(1,j),j+13)=ss c(index(2,j),j+13)=tt c(index(3,j),j+13)=cc wt(j+16)=ww c(index(1,j),j+16)=ss c(index(2,j),j+16)=cc c(index(3,j),j+16)=tt enddo ww=0.395793671960612e-1 cc=0.375490702584427e-1 ss=0.332743600588639e0 tt=0.629707329152919e0 do j=1,3 wt(j+19)=ww c(index(1,j),j+19)=ss c(index(2,j),j+19)=tt c(index(3,j),j+19)=cc wt(j+22)=ww c(index(1,j),j+22)=ss c(index(2,j),j+22)=cc c(index(3,j),j+22)=tt enddo c endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eleufn(itri,itnode,vx,vy,maxd,ngf,u,rl, + npts,qv,c,idof,iord,qxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),idof(10) real + vx(*),vy(*),u(maxd,*),qv(5,*),c(3,*),tx(3),ty(3),x(3), 1 y(3),gv(10),gx(10),gy(10),uu(100),uux(100),uuy(100) external qxy c c iord = 1 - linear c 2 - quadratic c 3 - cubic c c compute tangent and normal vectors c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) c ndof=((iord+1)*(iord+2))/2 iv1=itnode(1,itri) iv2=itnode(2,itri) iv3=itnode(3,itri) itag=itnode(5,itri) do i=1,ndof do j=1,5 qv(j,i)=0.0e0 enddo enddo do i=1,npts call beval(c(1,i),x,y,gv,gx,gy,iord) 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) do k=1,ngf su=0.0e0 sx=0.0e0 sy=0.0e0 do j=1,ndof su=su+gv(j)*u(idof(j),k) sx=sx+gx(j)*u(idof(j),k) sy=sy+gy(j)*u(idof(j),k) enddo uu(k)=su uux(k)=sx uuy(k)=sy enddo do m=1,5 qv(m,i)=0.0e0 enddo call qxy(xx,yy,uu,uux,uuy,rl,itag,qv(1,i)) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine elel2(itri,itnode,vx,vy,a,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) real + vx(*),vy(*),tx(3),ty(3),a(10,10),x(3),y(3) save index data index/1,2,3,2,3,1,3,1,2/ c c compute tangent and normal vectors c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) det=abs(det) c if(iord.eq.1) then d0=det/24.0e0 dd=det/12.0e0 do i=1,3 do j=1,3 a(i,j)=d0 enddo a(i,i)=dd enddo else if(iord.eq.2) then d0=det/360.0e0 d1=det/60.0e0 c1=det/90.0e0 f0=det*2.0e0/45.0e0 f1=det*4.0e0/45.0e0 do i=1,3 do j=1,3 a(i,j)=-d0 a(i+3,j)=0.0e0 a(i,j+3)=0.0e0 a(i+3,j+3)=f0 enddo a(i,i)=d1 a(i+3,i)=-c1 a(i,i+3)=-c1 a(i+3,i+3)=f1 enddo else if(iord.eq.3) then d0=det*11.0e0/13440.0e0 d1=det*76.0e0/13440.0e0 b0=det*27.0e0/13440.0e0 b1=det*18.0e0/13440.0e0 f1=det*36.0e0/13440.0e0 f2=det*162.0e0/13440.0e0 f3=det*1944.0e0/13440.0e0 g1=det*540.0e0/13440.0e0 g2=det*189.0e0/13440.0e0 g3=det*135.0e0/13440.0e0 g4=det*54.0e0/13440.0e0 g5=det*270.0e0/13440.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) a(j,j)=d1 a(j,j2)=d0 a(j,j3)=d0 a(j,2*j+2)=b0 a(j,2*j+3)=b0 a(j,2*j2+2)=0.0e0 a(j,2*j2+3)=b1 a(j,2*j3+2)=b1 a(j,2*j3+3)=0.0e0 a(j,10)=f1 c k=2*j+2 a(k,j)=b0 a(k,j2)=b1 a(k,j3)=0.0e0 a(k,2*j+2)=g1 a(k,2*j+3)=-g2 a(k,2*j2+2)=-g3 a(k,2*j2+3)=-g4 a(k,2*j3+2)=-g3 a(k,2*j3+3)=g5 a(k,10)=f2 c k=2*j+3 a(k,j)=b0 a(k,j2)=0.0e0 a(k,j3)=b1 a(k,2*j+2)=-g2 a(k,2*j+3)=g1 a(k,2*j2+2)=g5 a(k,2*j2+3)=-g3 a(k,2*j3+2)=-g4 a(k,2*j3+3)=-g3 a(k,10)=f2 c a(10,j)=f1 a(10,2*j+2)=f2 a(10,2*j+3)=f2 enddo a(10,10)=f3 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eleh1(itri,itnode,vx,vy,a,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) real + vx(*),vy(*),tx(3),ty(3),a(10,10),x(3),y(3),dd(3),dp(3) save index data index/1,2,3,2,3,1,3,1,2/ c c compute tangent and normal vectors c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) det=abs(det) do j=1,3 j2=index(2,j) j3=index(3,j) dd(j)=x(j)**2+y(j)**2 dp(j)=x(j2)*x(j3)+y(j2)*y(j3) enddo c if(iord.eq.1) then d0=det/2.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) a(j,j)=d0*dd(j) a(j2,j3)=d0*dp(j) a(j3,j2)=d0*dp(j) enddo else if(iord.eq.2) then do i=1,6 do j=1,6 a(i,j)=0.0e0 enddo enddo d1=det*3.0e0/6.0e0 d0=det*1.0e0/6.0e0 f1=det*8.0e0/6.0e0 f0=det*4.0e0/6.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) j4=j+3 j5=j2+3 j6=j3+3 c a(j,j)=a(j,j)+d1*dd(j) a(j5,j5)=a(j5,j5)+f1*dd(j) a(j6,j6)=a(j6,j6)+f1*dd(j) a(j5,j6)=a(j5,j6)+f0*dd(j) a(j6,j5)=a(j5,j6) c a(j2,j3)=a(j2,j3)-d0*dp(j) a(j3,j2)=a(j2,j3) a(j2,j4)=a(j2,j4)+f0*dp(j) a(j4,j2)=a(j2,j4) a(j3,j4)=a(j3,j4)+f0*dp(j) a(j4,j3)=a(j3,j4) a(j4,j4)=a(j4,j4)+f1*dp(j) a(j4,j5)=a(j4,j5)+f0*dp(j) a(j5,j4)=a(j4,j5) a(j4,j6)=a(j4,j6)+f0*dp(j) a(j6,j4)=a(j4,j6) a(j5,j6)=a(j5,j6)+f1*dp(j) a(j6,j5)=a(j5,j6) enddo else if(iord.eq.3) then do i=1,10 do j=1,10 a(i,j)=0.0e0 enddo enddo c d1=det*476.0e0/1120.0e0 d2=det*98.0e0/1120.0e0 b0=det*42.0e0/1120.0e0 b1=det*798.0e0/1120.0e0 b2=det*336.0e0/1120.0e0 f1=det*1890.0e0/1120.0e0 f2=det*378.0e0/1120.0e0 f3=det*189.0e0/1120.0e0 f4=det*945.0e0/1120.0e0 f5=det*756.0e0/1120.0e0 g1=det*4536.0e0/1120.0e0 g2=det*126.0e0/1120.0e0 g3=det*1134.0e0/1120.0e0 g4=det*2268.0e0/1120.0e0 c do j=1,3 j2=index(2,j) j3=index(3,j) j4=2*j+2 j5=2*j+3 j6=2*j2+2 j7=2*j2+3 j8=2*j3+2 j9=2*j3+3 c a(j,j)=a(j,j)+d1*dd(j) a(j,j6)=a(j,j6)+b0*dd(j) a(j6,j)=a(j,j6) a(j,j7)=a(j,j7)+b0*dd(j) a(j7,j)=a(j,j7) a(j,j8)=a(j,j8)+b0*dd(j) a(j8,j)=a(j,j8) a(j,j9)=a(j,j9)+b0*dd(j) a(j9,j)=a(j,j9) a(j,10)=a(j,10)+g2*dd(j) a(10,j)=a(j,10) c a(j6,j6)=a(j6,j6)+f1*dd(j) a(j7,j7)=a(j7,j7)+f1*dd(j) a(j8,j8)=a(j8,j8)+f1*dd(j) a(j9,j9)=a(j9,j9)+f1*dd(j) a(10,10)=a(10,10)+g1*dd(j) c a(j6,j7)=a(j6,j7)-f2*dd(j) a(j7,j6)=a(j6,j7) a(j6,j8)=a(j6,j8)-f3*dd(j) a(j8,j6)=a(j6,j8) a(j6,j9)=a(j6,j9)-f3*dd(j) a(j9,j6)=a(j6,j9) a(j6,10)=a(j6,10)+g3*dd(j) a(10,j6)=a(j6,10) a(j7,j8)=a(j7,j8)+f4*dd(j) a(j8,j7)=a(j7,j8) a(j7,j9)=a(j7,j9)-f3*dd(j) a(j9,j7)=a(j7,j9) a(j8,j9)=a(j8,j9)-f2*dd(j) a(j9,j8)=a(j8,j9) a(j9,10)=a(j9,10)+g3*dd(j) a(10,j9)=a(j9,10) c a(j2,j3)=a(j2,j3)+d2*dp(j) a(j3,j2)=a(j2,j3) a(j2,j4)=a(j2,j4)+b1*dp(j) a(j4,j2)=a(j2,j4) a(j2,j5)=a(j2,j5)-b2*dp(j) a(j5,j2)=a(j2,j5) a(j2,j6)=a(j2,j6)+b0*dp(j) a(j6,j2)=a(j2,j6) a(j2,j7)=a(j2,j7)+b0*dp(j) a(j7,j2)=a(j2,j7) a(j2,10)=a(j2,10)+g2*dp(j) a(10,j2)=a(j2,10) c a(j3,j4)=a(j3,j4)-b2*dp(j) a(j4,j3)=a(j3,j4) a(j3,j5)=a(j3,j5)+b1*dp(j) a(j5,j3)=a(j3,j5) a(j3,j8)=a(j3,j8)+b0*dp(j) a(j8,j3)=a(j3,j8) a(j3,j9)=a(j3,j9)+b0*dp(j) a(j9,j3)=a(j3,j9) a(j3,10)=a(j3,10)+g2*dp(j) a(10,j3)=a(j3,10) c a(j4,j4)=a(j4,j4)+f1*dp(j) a(j4,j5)=a(j4,j5)+f5*dp(j) a(j5,j4)=a(j4,j5) a(j4,j6)=a(j4,j6)-f3*dp(j) a(j6,j4)=a(j4,j6) a(j4,j7)=a(j4,j7)-f3*dp(j) a(j7,j4)=a(j4,j7) a(j4,j8)=a(j4,j8)-f3*dp(j) a(j8,j4)=a(j4,j8) a(j4,j9)=a(j4,j9)+f4*dp(j) a(j9,j4)=a(j4,j9) a(j4,10)=a(j4,10)+g3*dp(j) a(10,j4)=a(j4,10) c a(j5,j5)=a(j5,j5)+f1*dp(j) a(j5,j6)=a(j5,j6)+f4*dp(j) a(j6,j5)=a(j5,j6) a(j5,j7)=a(j5,j7)-f3*dp(j) a(j7,j5)=a(j5,j7) a(j5,j8)=a(j5,j8)-f3*dp(j) a(j8,j5)=a(j5,j8) a(j5,j9)=a(j5,j9)-f3*dp(j) a(j9,j5)=a(j5,j9) a(j5,10)=a(j5,10)+g3*dp(j) a(10,j5)=a(j5,10) c a(j6,j8)=a(j6,j8)-f2*dp(j) a(j8,j6)=a(j6,j8) a(j6,j9)=a(j6,j9)-f2*dp(j) a(j9,j6)=a(j6,j9) a(j6,10)=a(j6,10)+g4*dp(j) a(10,j6)=a(j6,10) c a(j7,j8)=a(j7,j8)+f1*dp(j) a(j8,j7)=a(j7,j8) a(j7,j9)=a(j7,j9)-f2*dp(j) a(j9,j7)=a(j7,j9) a(j7,10)=a(j7,10)+g3*dp(j) a(10,j7)=a(j7,10) c a(j8,10)=a(j8,10)+g3*dp(j) a(10,j8)=a(j8,10) a(j9,10)=a(j9,10)+g4*dp(j) a(10,j9)=a(j9,10) a(10,10)=a(10,10)+g1*dp(j) c enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine elerhs(itri,itnode,idof,vx,vy,u,bx,by,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),idof(10) real + vx(*),vy(*),tx(3),ty(3),bx(10),by(10),x(3),y(3), 1 u(*),v(10) save index data index/1,2,3,2,3,1,3,1,2/ c c element right hand side of gradient projection c c compute tangent and normal vectors c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) det=abs(det) c ndof=(iord+1)*(iord+2)/2 do j=1,ndof v(j)=u(idof(j)) enddo c if(iord.eq.1) then d0=det/6.0e0 sx=d0*(x(1)*v(1)+x(2)*v(2)+x(3)*v(3)) sy=d0*(y(1)*v(1)+y(2)*v(2)+y(3)*v(3)) bx(1)=sx bx(2)=sx bx(3)=sx by(1)=sy by(2)=sy by(3)=sy else if(iord.eq.2) then d0=det/30.0e0 do j=1,6 bx(j)=0.0e0 by(j)=0.0e0 v(j)=v(j)*d0 enddo c do j=1,3 j2=index(2,j) j3=index(3,j) j4=j+3 j5=j2+3 j6=j3+3 c z=2.0e0*v(j)-v(j5)-v(j6) bx(j)=bx(j)+x(j)*z by(j)=by(j)+y(j)*z c z=2.0e0*v(j6)-v(j5)-v(j) bx(j2)=bx(j2)+x(j)*z by(j2)=by(j2)+y(j)*z c z=2.0e0*v(j5)-v(j)-v(j6) bx(j3)=bx(j3)+x(j)*z by(j3)=by(j3)+y(j)*z c z=8.0e0*(v(j5)+v(j6))-v(j) bx(j4)=bx(j4)+x(j)*z by(j4)=by(j4)+y(j)*z c z=8.0e0*v(j5)+4.0e0*v(j6)+3.0e0*v(j) bx(j5)=bx(j5)+x(j)*z by(j5)=by(j5)+y(j)*z c z=8.0e0*v(j6)+4.0e0*v(j5)+3.0e0*v(j) bx(j6)=bx(j6)+x(j)*z by(j6)=by(j6)+y(j)*z enddo else if(iord.eq.3) then d0=det/3360.0e0 do j=1,10 bx(j)=0.0e0 by(j)=0.0e0 v(j)=v(j)*d0 enddo c do j=1,3 j2=index(2,j) j3=index(3,j) j4=2*j+2 j5=2*j+3 j6=2*j2+2 j7=2*j2+3 j8=2*j3+2 j9=2*j3+3 c z=128.0e0*v(j)+45.0e0*(v(j6)+v(j9)) + -9.0e0*(v(j7)+v(j8))+108.0e0*v(10) bx(j)=bx(j)+x(j)*z by(j)=by(j)+y(j)*z c z=38.0e0*v(j)+45.0e0*(v(j6)+v(j7)) + -72.0e0*v(j8)+198.0e0*v(j9)+54.0e0*v(10) bx(j2)=bx(j2)+x(j)*z by(j2)=by(j2)+y(j)*z c z=38.0e0*v(j)+45.0e0*(v(j8)+v(j9)) + -72.0e0*v(j7)+198.0e0*v(j6)+54.0e0*v(10) bx(j3)=bx(j3)+x(j)*z by(j3)=by(j3)+y(j)*z c z=45.0e0*v(j)-243.0e0*(v(j6)+v(j8)) + -162.0e0*v(j7)+648.0e0*(v(j9)+v(10)) bx(j4)=bx(j4)+x(j)*z by(j4)=by(j4)+y(j)*z c z=45.0e0*v(j)-243.0e0*(v(j7)+v(j9)) + -162.0e0*v(j8)+648.0e0*(v(j6)+v(10)) bx(j5)=bx(j5)+x(j)*z by(j5)=by(j5)+y(j)*z c z=648.0e0*v(j6)+81.0e0*(v(j7)-v(j9)) + -162.0e0*v(j8)+324.0e0*v(10)-117.0e0*v(j) bx(j6)=bx(j6)+x(j)*z by(j6)=by(j6)+y(j)*z c z=207.0e0*v(j)-243.0e0*v(j6)+648.0e0*v(j7) + +324.0e0*v(j8)-81.0e0*v(j9)-162.0e0*v(10) bx(j7)=bx(j7)+x(j)*z by(j7)=by(j7)+y(j)*z c z=207.0e0*v(j)-243.0e0*v(j9)+648.0e0*v(j8) + +324.0e0*v(j7)-81.0e0*v(j6)-162.0e0*v(10) bx(j8)=bx(j8)+x(j)*z by(j8)=by(j8)+y(j)*z c z=648.0e0*v(j9)+81.0e0*(v(j8)-v(j6)) + -162.0e0*v(j7)+324.0e0*v(10)-117.0e0*v(j) bx(j9)=bx(j9)+x(j)*z by(j9)=by(j9)+y(j)*z c z=324.0e0*(v(j6)+v(j9))+1944.0e0*v(10) + +810.0e0*(v(j7)+v(j8))-54.0e0*v(j) bx(10)=bx(10)+x(j)*z by(10)=by(10)+y(j)*z c enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine elel2p(itri,itnode,icurv,idof,vx,vy,xm,ym,u,b,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),idof(10),icurv(3,*) real + vx(*),vy(*),tx(3),ty(3),b(10),x(3),y(3),u(*),xm(*), 1 ym(*),xp(10),yp(10),up(10),c(3),gv(10) save index data index/1,2,3,2,3,1,3,1,2/ c c derivative evaluation for derivative recovery -- note c all three rhs values for eg gx projection are c equal to gx*det/6, so only one is returned... that is c each single entry in b expands into three entries for an element rhs. c c compute tangent and normal vectors c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) det=abs(det)/6.0e0 call cnodec(itri,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) ndof=(iord+1)*(iord+2)/2 do i=1,ndof up(i)=u(idof(i)) enddo if(isw.eq.1) then if(iord.eq.2) then do j=1,3 if(icurv(j,itri).gt.0) then c(j)=0.0e0 c(index(2,j))=1.0e0/2.0e0 c(index(3,j))=1.0e0/2.0e0 call barinl(c,xp,yp,iord,gv) up(j+3)=0.0e0 do i=1,ndof up(j+3)=up(j+3)+u(idof(i))*gv(i) enddo endif enddo else if(iord.eq.3) then do j=1,3 if(icurv(j,itri).gt.0) then c(j)=0.0e0 c(index(2,j))=2.0e0/3.0e0 c(index(3,j))=1.0e0/3.0e0 call barinl(c,xp,yp,iord,gv) jj=2*j+2 up(jj)=0.0e0 do i=1,ndof up(jj)=up(jj)+u(idof(i))*gv(i) enddo c(j)=0.0e0 c(index(2,j))=1.0e0/3.0e0 c(index(3,j))=2.0e0/3.0e0 call barinl(c,xp,yp,iord,gv) jj=2*j+3 up(jj)=0.0e0 do i=1,ndof up(jj)=up(jj)+u(idof(i))*gv(i) enddo endif enddo c(1)=1.0e0/3.0e0 c(2)=1.0e0/3.0e0 c(3)=1.0e0/3.0e0 call barinl(c,xp,yp,iord,gv) up(10)=0.0e0 do i=1,ndof up(10)=up(10)+u(idof(i))*gv(i) enddo endif endif c if(iord.eq.1) then gx=0.0e0 gy=0.0e0 do j=1,3 gx=gx+x(j)*up(j) gy=gy+y(j)*up(j) enddo b(1)=gx*det b(2)=gy*det else if(iord.eq.2) then gxx=0.0e0 gxy=0.0e0 gyy=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) sj=up(j)*4.0e0 sk=up(j+3)*4.0e0 gxx=gxx+x(j)*x(j)*sj+x(j2)*x(j3)*sk*2.0e0 gxy=gxy+x(j)*y(j)*sj+(x(j2)*y(j3)+y(j2)*x(j3))*sk gyy=gyy+y(j)*y(j)*sj+y(j2)*y(j3)*sk*2.0e0 enddo b(1)=gxx*det b(2)=gxy*det b(3)=gyy*det else if(iord.eq.3) then gxxx=0.0e0 gxxy=0.0e0 gxyy=0.0e0 gyyy=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) k=2*j+2 i=2*j+3 sj=up(j)*27.0e0 sk=up(k)*27.0e0 si=up(i)*27.0e0 c gxxx=gxxx+x(j)**3*sj + +x(j2)*x(j3)*(x(j2)*sk+x(j3)*si)*3.0e0 gxxy=gxxy+y(j)*x(j)**2*sj + +(2.0e0*y(j2)*x(j3)+x(j2)*y(j3))*x(j2)*sk 1 +(2.0e0*y(j3)*x(j2)+x(j3)*y(j2))*x(j3)*si gxyy=gxyy+x(j)*y(j)**2*sj + +(2.0e0*x(j2)*y(j3)+y(j2)*x(j3))*y(j2)*sk 1 +(2.0e0*x(j3)*y(j2)+y(j3)*x(j2))*y(j3)*si gyyy=gyyy+y(j)**3*sj + +y(j2)*y(j3)*(y(j2)*sk+y(j3)*si)*3.0e0 enddo sj=up(10)*54.0e0 gxxx=gxxx+x(1)*x(2)*x(3)*sj*3.0e0 gxxy=gxxy+(y(1)*x(2)*x(3)+x(1)*y(2)*x(3)+x(1)*x(2)*y(3))*sj gxyy=gxyy+(x(1)*y(2)*y(3)+y(1)*x(2)*y(3)+y(1)*y(2)*x(3))*sj gyyy=gyyy+y(1)*y(2)*y(3)*sj*3.0e0 c b(1)=gxxx*det b(2)=gxxy*det b(3)=gxyy*det b(4)=gyyy*det endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine barinl(c,xp,yp,iord,gv) c implicit real (a-h,o-z) implicit integer (i-n) real + c(3),xp(10),yp(10),x(3),y(3),gv(10),gx(10),gy(10),c0(3) data ibit/0/ c c compute the barycentric coordinates that hit the point c given by the input barycentric coords for affine map c do j=1,3 c0(j)=c(j) enddo x(1)=-1.0e0 y(1)=-1.0e0 x(2)=1.0e0 y(2)=0.0e0 x(3)=0.0e0 y(3)=1.0e0 c ndof=(iord+1)*(iord+2)/2 itmax=20 eps=ceps(ibit) do itnum=1,itmax call beval(c,x,y,gv,gx,gy,iord) p11=0.0e0 p12=0.0e0 p21=0.0e0 p22=0.0e0 xx=0.0e0 yy=0.0e0 do j=1,ndof xx=xx+xp(j)*gv(j) yy=yy+yp(j)*gv(j) p11=p11+xp(j)*gx(j) p12=p12+xp(j)*gy(j) p21=p21+yp(j)*gx(j) p22=p22+yp(j)*gy(j) enddo xx=xp(1)*c0(1)+xp(2)*c0(2)+xp(3)*c0(3)-xx yy=yp(1)*c0(1)+yp(2)*c0(2)+yp(3)*c0(3)-yy detn=p11*p22-p21*p12 d2=(xx*p22-yy*p12)/detn d3=(p11*yy-p21*xx)/detn if(sqrt(d2**2+d3**2).le.100.0e0*eps) return c(2)=c(2)+d2 c(3)=c(3)+d3 c(1)=1.0e0-c(2)-c(3) enddo if(itnum.gt.0) stop 4141 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function el2nrm(it,itnode,vx,vy,u,idof,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),idof(*) real + vx(*),vy(*),tx(3),ty(3),u(*),x(3),y(3) save index data index/1,2,3,2,3,1,3,1,2/ c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) det=abs(det)/2.0e0 c if(iord.eq.1) then uu=0.0e0 us=0.0e0 do j=1,3 uu=uu+u(idof(j))**2 us=us+u(idof(j)) enddo el2nrm=det*(uu+us**2)/12.0e0 else if(iord.eq.2) then uu=0.0e0 us=0.0e0 dp=0.0e0 qq=0.0e0 qs=0.0e0 do j=1,3 uu=uu+u(idof(j))**2 us=us+u(idof(j)) dp=dp+u(idof(j))*u(idof(j+3)) qq=qq+u(idof(j+3))**2 qs=qs+u(idof(j+3)) enddo el2nrm=det*(7.0e0*uu-us**2-dp*8.0e0+ + (qq+qs**2)*16.0e0)/180.0e0 else if(iord.eq.3) then uu=0.0e0 us=0.0e0 dp1=0.0e0 dp2=0.0e0 dp3=0.0e0 dp4=0.0e0 qq=0.0e0 q1=0.0e0 q2=0.0e0 q3=0.0e0 q4=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) j4=2*j+2 j5=2*j+3 j6=2*j2+2 j7=2*j2+3 j8=2*j3+2 j9=2*j3+3 c uu=uu+u(idof(j))**2 us=us+u(idof(j)) dp1=dp1+u(idof(j))*(u(idof(j4))+u(idof(j5))) dp2=dp2+u(idof(j))*(u(idof(j7))+u(idof(j8))) dp3=dp3+u(idof(j))*u(idof(10)) dp4=dp4+u(idof(10))*(u(idof(j4))+u(idof(j5))) qq=qq+u(idof(j4))**2+u(idof(j5))**2 q1=q1+u(idof(j4))*u(idof(j5)) q2=q2+u(idof(j4))*u(idof(j7))+u(idof(j8))*u(idof(j5)) q3=q3+u(idof(j4))*(u(idof(j6))+u(idof(j8))) + +u(idof(j5))*(u(idof(j7))+u(idof(j9))) q4=q4+u(idof(j4))*u(idof(j9))+u(idof(j6))*u(idof(j5)) enddo uu=65.0e0*uu+11.0e0*us**2+54.0e0*dp1+36.0e0*dp2 rr=1944.0e0*u(idof(10))**2+72.0e0*dp3+324.0e0*dp4 qq=540.0e0*qq-378.0e0*q1-54.0e0*q2-135.0e0*q3+270.0e0*q4 el2nrm=(uu+rr+qq)*det/6720.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function eh1nrm(it,itnode,vx,vy,u,idof,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3),idof(*) real + vx(*),vy(*),tx(3),ty(3),x(3),y(3),dd(3),dp(3),u(*), 1 u2(10),uu(10) save index data index/1,2,3,2,3,1,3,1,2/ c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) det=abs(det)/2.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) dd(j)=x(j)**2+y(j)**2 dp(j)=x(j2)*x(j3)+y(j2)*y(j3) enddo c if(iord.eq.1) then qx=0.0e0 qy=0.0e0 do j=1,3 qx=qx+x(j)*u(idof(j)) qy=qy+y(j)*u(idof(j)) enddo eh1nrm=(qx**2+qy**2)*det else if(iord.eq.2) then qq=0.0e0 q1=0.0e0 rr=0.0e0 r1=0.0e0 do j=1,6 uu(j)=u(idof(j)) u2(j)=uu(j)**2 enddo do j=1,3 j2=index(2,j) j3=index(3,j) j4=j+3 j5=j2+3 j6=j3+3 c qq=qq+dd(j)*u2(j) rr=rr+dd(j)*(u2(j5)+u2(j6)+uu(j5)*uu(j6)) q1=q1+dp(j)*uu(j2)*uu(j3) r1=r1+dp(j)*(2.0e0*uu(j5)*uu(j6) + +uu(j4)*(uu(j2)+uu(j3)+uu(j4)+uu(j5)+uu(j6))) enddo eh1nrm=(3.0e0*qq+8.0e0*rr-2.0e0*q1+8.0e0*r1)*det/3.0e0 else if(iord.eq.3) then qq=0.0e0 q1=0.0e0 q2=0.0e0 q3=0.0e0 rr=0.0e0 r1=0.0e0 r2=0.0e0 ss=0.0e0 s1=0.0e0 s2=0.0e0 t1=0.0e0 t2=0.0e0 t3=0.0e0 t4=0.0e0 t5=0.0e0 t6=0.0e0 t7=0.0e0 t8=0.0e0 do j=1,10 uu(j)=u(idof(j)) u2(j)=uu(j)**2 enddo do j=1,3 j2=index(2,j) j3=index(3,j) j4=2*j+2 j5=2*j+3 j6=2*j2+2 j7=2*j2+3 j8=2*j3+2 j9=2*j3+3 c qq=qq+dd(j)*u2(j) q1=q1+dd(j)*uu(j)*(uu(j6)+uu(j7)+uu(j8)+uu(j9)) q2=q2+dd(j)*uu(j)*uu(10) q3=q3+dd(j)*(uu(j6)+uu(j9))*uu(10) rr=rr+dd(j)*(u2(j6)+u2(j7)+u2(j8)+u2(j9)+uu(j7)*uu(j8)) r1=r1+dd(j)*(uu(j6)*uu(j7)+uu(j8)*uu(j9)) r2=r2+dd(j)*(uu(j6)*(uu(j8)+uu(j9))+uu(j7)*uu(j9)) ss=ss+dd(j)*u2(10) c s1=s1+dp(j)*uu(10)*(uu(j2)+uu(j3)) s2=s2+dp(j)*uu(10)*(uu(j4)+uu(j5)+uu(j7)+uu(j8)) ss=ss+dp(j)*(uu(10)*(uu(j6)+uu(j9))+u2(10)) t1=t1+dp(j)*(uu(j9)*(uu(j6)+uu(j7))+uu(j6)*uu(j8)) t2=t2+dp(j)*(uu(j5)*(uu(j7)+uu(j8)+uu(j9)) + +uu(j4)*(uu(j6)+uu(j7)+uu(j8))) t3=t3+dp(j)*(uu(j2)*(uu(j6)+uu(j7)) + +uu(j3)*(uu(j8)+uu(j9))) t4=t4+dp(j)*(uu(j9)*uu(j4)+uu(j5)*uu(j6) + +uu(j7)*uu(j8)*2.0e0+u2(j4)+u2(j5)) t5=t5+dp(j)*uu(j4)*uu(j5) t6=t6+dp(j)*(uu(j5)*uu(j3)+uu(j4)*uu(j2)) t7=t7+dp(j)*(uu(j5)*uu(j2)+uu(j4)*uu(j3)) t8=t8+dp(j)*uu(j2)*uu(j3) enddo qq=476.0e0*qq+84.0e0*q1+252.0e0*q2+2268.0e0*q3 rr=1890.0e0*rr-756.0e0*r1-378.0e0*r2 ss=4536.0e0*ss+252.0e0*s1+2268.0e0*s2 tt=-756.0e0*t1-378.0e0*t2+84.0e0*t3+1890.0e0*t4 + +1512.0e0*t5+1596.0e0*t6-672.0e0*t7+196.0e0*t8 eh1nrm=(qq+rr+ss+tt)*det/560.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cquad1(npts,wt,c) c implicit real (a-h,o-z) implicit integer (i-n) real + c(2,6),wt(6) c if(npts.eq.2) then wt(1)=1.0e0/2.0e0 ss=1.0e0/(2.0e0*sqrt(3.0e0)) c(1,1)=0.5e0+ss c(2,1)=0.5e0-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.0e0 c(1,1)=0.5e0 c(2,1)=0.5e0 else if(npts.eq.3) then wt(1)=5.0e0/18.0e0 ss=sqrt(3.0e0/5.0e0)/2.0e0 c(1,1)=0.5e0-ss c(2,1)=0.5e0+ss wt(2)=wt(1) c(1,2)=c(2,1) c(2,2)=c(1,1) wt(3)=4.0e0/9.0e0 c(1,3)=0.5e0 c(2,3)=0.5e0 else if(npts.eq.4) then ww=0.652145154862546e0 ss=0.339981043584856e0 do j=1,2 wt(j)=ww/2.0e0 c(1,j)=0.5e0-ss/2.0e0 c(2,j)=0.5e0+ss/2.0e0 enddo ww=0.347854845137454e0 ss=0.861136311594053e0 do j=1,2 wt(j+2)=ww/2.0e0 c(1,j+2)=0.5e0-ss/2.0e0 c(2,j+2)=0.5e0+ss/2.0e0 enddo else if(npts.eq.5) then ww=0.568888888888889e0 wt(1)=ww/2.0e0 c(1,1)=0.5e0 c(2,1)=0.5e0 ww=0.478628670499366e0 ss=0.538469310105683e0 do j=1,2 wt(j+1)=ww/2.0e0 c(1,j+1)=0.5e0-ss/2.0e0 c(2,j+1)=0.5e0+ss/2.0e0 enddo ww=0.236926685056189e0 ss=0.906179845938664e0 do j=1,2 wt(j+3)=ww/2.0e0 c(1,j+3)=0.5e0-ss/2.0e0 c(2,j+3)=0.5e0+ss/2.0e0 enddo else if(npts.eq.6) then ww=0.467913934572691e0 ss=0.238619186083197e0 do j=1,2 wt(j)=ww/2.0e0 c(1,j)=0.5e0-ss/2.0e0 c(2,j)=0.5e0+ss/2.0e0 enddo ww=0.360761573048139e0 ss=0.661029386466265e0 do j=1,2 wt(j+2)=ww/2.0e0 c(1,j+2)=0.5e0-ss/2.0e0 c(2,j+2)=0.5e0+ss/2.0e0 enddo ww=0.171324492379170e0 ss=0.932469514201352e0 do j=1,2 wt(j+4)=ww/2.0e0 c(1,j+4)=0.5e0-ss/2.0e0 c(2,j+4)=0.5e0+ss/2.0e0 enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine beval(c,x,y,gv,gx,gy,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + c(3),x(3),y(3),gv(10),gx(10),gy(10) save index data index/1,2,3,2,3,1,3,1,2/ c c 3 3 3 c |\ |\ |\ c | \ | \ 6 | \ 5 c | \ | \ | \ c | \ 5| \ 4 | \ c | \ | \ | \ c | \ | \ 7 | 10 \ 4 c |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 c c if(iord.eq.1) then do i=1,3 gv(i)=c(i) gx(i)=x(i) gy(i)=y(i) enddo else if(iord.eq.2) then do i=1,3 i2=index(2,i) i3=index(3,i) c cm=2.0e0*c(i)-1.0e0 gv(i)=c(i)*cm gx(i)=x(i)*(cm+c(i)*2.0e0) gy(i)=y(i)*(cm+c(i)*2.0e0) c gv(i+3)=4.0e0*c(i2)*c(i3) gx(i+3)=4.0e0*(x(i2)*c(i3)+c(i2)*x(i3)) gy(i+3)=4.0e0*(y(i2)*c(i3)+c(i2)*y(i3)) enddo else if(iord.eq.3) then do i=1,3 i2=index(2,i) i3=index(3,i) c cm1=3.0e0*c(i)-1.0e0 cm2=3.0e0*c(i)-2.0e0 gv(i)=c(i)*cm1*cm2/2.0e0 gx(i)=x(i)*(cm1*cm2+3.0e0*c(i)*(cm1+cm2))/2.0e0 gy(i)=y(i)*(cm1*cm2+3.0e0*c(i)*(cm1+cm2))/2.0e0 c cm=3.0e0*c(i2)-1.0e0 gv(2*i+2)=9.0e0*c(i2)*c(i3)*cm/2.0e0 gx(2*i+2)=9.0e0*((x(i2)*c(i3)+c(i2)*x(i3))*cm + +c(i2)*c(i3)*3.0e0*x(i2))/2.0e0 gy(2*i+2)=9.0e0*((y(i2)*c(i3)+c(i2)*y(i3))*cm + +c(i2)*c(i3)*3.0e0*y(i2))/2.0e0 c cm=3.0e0*c(i3)-1.0e0 gv(2*i+3)=9.0e0*c(i2)*c(i3)*cm/2.0e0 gx(2*i+3)=9.0e0*((x(i2)*c(i3)+c(i2)*x(i3))*cm + +c(i2)*c(i3)*3.0e0*x(i3))/2.0e0 gy(2*i+3)=9.0e0*((y(i2)*c(i3)+c(i2)*y(i3))*cm + +c(i2)*c(i3)*3.0e0*y(i3))/2.0e0 c enddo c gv(10)=27.0e0*c(1)*c(2)*c(3) gx(10)=27.0e0*(x(1)*c(2)*c(3)+c(1)*x(2)*c(3)+c(1)*c(2)*x(3)) gy(10)=27.0e0*(y(1)*c(2)*c(3)+c(1)*y(2)*c(3)+c(1)*c(2)*y(3)) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine beval1(c,gv,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + c(3),gv(10) save index data index/1,2,3,2,3,1,3,1,2/ c c 3 3 3 c |\ |\ |\ c | \ | \ 6 | \ 5 c | \ | \ | \ c | \ 5| \ 4 | \ c | \ | \ | \ c | \ | \ 7 | 10 \ 4 c |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 c c if(iord.eq.1) then do i=1,3 gv(i)=c(i) enddo else if(iord.eq.2) then do i=1,3 i2=index(2,i) i3=index(3,i) gv(i)=c(i)*(2.0e0*c(i)-1.0e0) gv(i+3)=4.0e0*c(i2)*c(i3) enddo else if(iord.eq.3) then do i=1,3 i2=index(2,i) i3=index(3,i) gv(i)=c(i)*(3.0e0*c(i)-1.0e0)*(3.0e0*c(i)-2.0e0)/2.0e0 gv(2*i+2)=9.0e0*c(i2)*c(i3)*(3.0e0*c(i2)-1.0e0)/2.0e0 gv(2*i+3)=9.0e0*c(i2)*c(i3)*(3.0e0*c(i3)-1.0e0)/2.0e0 enddo gv(10)=27.0e0*c(1)*c(2)*c(3) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine beval2(c,x,y,gxx,gxy,gyy,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + x(3),y(3),gxx(10),gxy(10),gyy(10),c(3),p(3),q(3), 1 d1(3),p1(3),q1(3),d2(3),p2(3),q2(3) save index data index/1,2,3,2,3,1,3,1,2/ c c 3 3 3 c |\ |\ |\ c | \ | \ 6 | \ 5 c | \ | \ | \ c | \ 5| \ 4 | \ c | \ | \ | \ c | \ | \ 7 | 10 \ 4 c |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 c c if(iord.eq.1) then do j=1,3 gxx(j)=0.0e0 gxy(j)=0.0e0 gyy(j)=0.0e0 enddo else if(iord.eq.2) then do j=1,3 p(j)=2.0e0*x(j) q(j)=2.0e0*y(j) enddo do j=1,3 j2=index(2,j) j3=index(3,j) c gxx(j)=x(j)*p(j)*2.0e0 gxy(j)=x(j)*q(j)+y(j)*p(j) gyy(j)=y(j)*q(j)*2.0e0 c k=j+3 gxx(k)=8.0e0*x(j2)*x(j3) gxy(k)=4.0e0*(x(j2)*y(j3)+y(j2)*x(j3)) gyy(k)=8.0e0*y(j2)*y(j3) enddo else if(iord.eq.3) then do j=1,3 d1(j)=3.0e0*c(j)-1.0e0 p1(j)=3.0e0*x(j) q1(j)=3.0e0*y(j) d2(j)=3.0e0*c(j)-2.0e0 p2(j)=3.0e0*x(j) q2(j)=3.0e0*y(j) enddo do j=1,3 j2=index(2,j) j3=index(3,j) c gxx(j)=c(j)*p1(j)*p2(j) + +x(j)*d1(j)*p2(j) 1 +x(j)*p1(j)*d2(j) gxy(j)=x(j)*q1(j)*d2(j)+x(j)*d1(j)*q2(j) + +y(j)*p1(j)*d2(j)+c(j)*p1(j)*q2(j) 1 +y(j)*d1(j)*p2(j)+c(j)*q1(j)*p2(j) gxy(j)=gxy(j)/2.0e0 gyy(j)=c(j)*q1(j)*q2(j) + +y(j)*d1(j)*q2(j) 1 +y(j)*q1(j)*d2(j) c jj=j2 k=2*j+2 do m=1,2 gxx(k)=c(j2)*x(j3)*p1(jj) + +x(j2)*c(j3)*p1(jj) + +x(j2)*x(j3)*d1(jj) gxx(k)=gxx(k)*9.0e0 gxy(k)=x(j2)*y(j3)*d1(jj)+x(j2)*c(j3)*q1(jj) + +y(j2)*x(j3)*d1(jj)+c(j2)*x(j3)*q1(jj) + +y(j2)*c(j3)*p1(jj)+c(j2)*y(j3)*p1(jj) gxy(k)=gxy(k)*9.0e0/2.0e0 gyy(k)=c(j2)*y(j3)*q1(jj) + +y(j2)*c(j3)*q1(jj) + +y(j2)*y(j3)*d1(jj) gyy(k)=gyy(k)*9.0e0 c jj=j3 k=2*j+3 enddo enddo c gxx(10)=c(1)*x(2)*x(3) + +x(1)*c(2)*x(3) + +x(1)*x(2)*c(3) gxx(10)=gxx(10)*54.0e0 gxy(10)=x(1)*y(2)*c(3)+x(1)*c(2)*y(3) + +y(1)*x(2)*c(3)+c(1)*x(2)*y(3) + +y(1)*c(2)*x(3)+c(1)*y(2)*x(3) gxy(10)=gxy(10)*27.0e0 gyy(10)=c(1)*y(2)*y(3) + +y(1)*c(2)*y(3) + +y(1)*y(2)*c(3) gyy(10)=gyy(10)*54.0e0 c endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine beval3(c,x,y,g,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + x(3),y(3),g(10,10),c(3),d(3),p(3),q(3), 1 d1(3),p1(3),q1(3),d2(3),p2(3),q2(3) save index data index/1,2,3,2,3,1,3,1,2/ c c 3 3 3 c |\ |\ |\ c | \ | \ 6 | \ 5 c | \ | \ | \ c | \ 5| \ 4 | \ c | \ | \ | \ c | \ | \ 7 | 10 \ 4 c |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 c c 1 = g c 2 = gx c 3 = gy c 4 = gxx c 5 = gxy c 6 = gyy c 7 = gxxx c 8 = gxxy c 9 = gxyy c 10 = gyyy c if(iord.eq.1) then do j=1,3 g(1,j)=c(j) g(2,j)=x(j) g(3,j)=y(j) enddo else if(iord.eq.2) then do j=1,3 d(j)=2.0e0*c(j)-1.0e0 p(j)=2.0e0*x(j) q(j)=2.0e0*y(j) enddo do j=1,3 j2=index(2,j) j3=index(3,j) c g(1,j)=c(j)*d(j) g(2,j)=x(j)*d(j)+c(j)*p(j) g(3,j)=y(j)*d(j)+c(j)*q(j) c g(4,j)=x(j)*p(j)*2.0e0 g(5,j)=x(j)*q(j)+y(j)*p(j) g(6,j)=y(j)*q(j)*2.0e0 c k=j+3 g(1,k)=4.0e0*c(j2)*c(j3) g(2,k)=4.0e0*(x(j2)*c(j3)+c(j2)*x(j3)) g(3,k)=4.0e0*(y(j2)*c(j3)+c(j2)*y(j3)) c g(4,k)=8.0e0*x(j2)*x(j3) g(5,k)=4.0e0*(x(j2)*y(j3)+y(j2)*x(j3)) g(6,k)=8.0e0*y(j2)*y(j3) enddo else if(iord.eq.3) then do j=1,3 d1(j)=3.0e0*c(j)-1.0e0 p1(j)=3.0e0*x(j) q1(j)=3.0e0*y(j) d2(j)=3.0e0*c(j)-2.0e0 p2(j)=3.0e0*x(j) q2(j)=3.0e0*y(j) enddo do j=1,3 j2=index(2,j) j3=index(3,j) c g(1,j)=c(j)*d1(j)*d2(j)/2.0e0 g(2,j)=x(j)*d1(j)*d2(j) + +c(j)*p1(j)*d2(j) 1 +c(j)*d1(j)*p2(j) g(2,j)=g(2,j)/2.0e0 g(3,j)=y(j)*d1(j)*d2(j) + +c(j)*q1(j)*d2(j) 1 +c(j)*d1(j)*q2(j) g(3,j)=g(3,j)/2.0e0 c g(4,j)=c(j)*p1(j)*p2(j) + +x(j)*d1(j)*p2(j) 1 +x(j)*p1(j)*d2(j) g(5,j)=x(j)*q1(j)*d2(j)+x(j)*d1(j)*q2(j) + +y(j)*p1(j)*d2(j)+c(j)*p1(j)*q2(j) 1 +y(j)*d1(j)*p2(j)+c(j)*q1(j)*p2(j) g(5,j)=g(5,j)/2.0e0 g(6,j)=c(j)*q1(j)*q2(j) + +y(j)*d1(j)*q2(j) 1 +y(j)*q1(j)*d2(j) c g(7,j)=x(j)*p1(j)*p2(j)*3.0e0 g(8,j)=y(j)*p1(j)*p2(j) + +x(j)*q1(j)*p2(j) 1 +x(j)*p1(j)*q2(j) g(9,j)=x(j)*q1(j)*q2(j) + +y(j)*p1(j)*q2(j) 1 +y(j)*q1(j)*p2(j) g(10,j)=y(j)*q1(j)*q2(j)*3.0e0 c jj=j2 k=2*j+2 do m=1,2 g(1,k)=c(j2)*c(j3)*d1(jj) g(1,k)=g(1,k)*9.0e0/2.0e0 c g(2,k)=x(j2)*c(j3)*d1(jj) + +c(j2)*x(j3)*d1(jj) + +c(j2)*c(j3)*p1(jj) g(2,k)=g(2,k)*9.0e0/2.0e0 g(3,k)=y(j2)*c(j3)*d1(jj) + +c(j2)*y(j3)*d1(jj) + +c(j2)*c(j3)*q1(jj) g(3,k)=g(3,k)*9.0e0/2.0e0 c g(4,k)=c(j2)*x(j3)*p1(jj) + +x(j2)*c(j3)*p1(jj) + +x(j2)*x(j3)*d1(jj) g(4,k)=g(4,k)*9.0e0 g(5,k)=x(j2)*y(j3)*d1(jj)+x(j2)*c(j3)*q1(jj) + +y(j2)*x(j3)*d1(jj)+c(j2)*x(j3)*q1(jj) + +y(j2)*c(j3)*p1(jj)+c(j2)*y(j3)*p1(jj) g(5,k)=g(5,k)*9.0e0/2.0e0 g(6,k)=c(j2)*y(j3)*q1(jj) + +y(j2)*c(j3)*q1(jj) + +y(j2)*y(j3)*d1(jj) g(6,k)=g(6,k)*9.0e0 c g(7,k)=x(j2)*x(j3)*p1(jj) g(7,k)=g(7,k)*27.0e0 g(8,k)=y(j2)*x(j3)*p1(jj) + +x(j2)*y(j3)*p1(jj) + +x(j2)*x(j3)*q1(jj) g(8,k)=g(8,k)*9.0e0 g(9,k)=x(j2)*y(j3)*q1(jj) + +y(j2)*x(j3)*q1(jj) + +y(j2)*y(j3)*p1(jj) g(9,k)=g(9,k)*9.0e0 g(10,k)=y(j2)*y(j3)*q1(jj) g(10,k)=g(10,k)*27.0e0 c jj=j3 k=2*j+3 enddo enddo c g(1,10)=c(1)*c(2)*c(3) g(1,10)=g(1,10)*27.0e0 g(2,10)=x(1)*c(2)*c(3) + +c(1)*x(2)*c(3) + +c(1)*c(2)*x(3) g(2,10)=g(2,10)*27.0e0 g(3,10)=y(1)*c(2)*c(3) + +c(1)*y(2)*c(3) + +c(1)*c(2)*y(3) g(3,10)=g(3,10)*27.0e0 c g(4,10)=c(1)*x(2)*x(3) + +x(1)*c(2)*x(3) + +x(1)*x(2)*c(3) g(4,10)=g(4,10)*54.0e0 g(5,10)=x(1)*y(2)*c(3)+x(1)*c(2)*y(3) + +y(1)*x(2)*c(3)+c(1)*x(2)*y(3) + +y(1)*c(2)*x(3)+c(1)*y(2)*x(3) g(5,10)=g(5,10)*27.0e0 g(6,10)=c(1)*y(2)*y(3) + +y(1)*c(2)*y(3) + +y(1)*y(2)*c(3) g(6,10)=g(6,10)*54.0e0 c g(7,10)=x(1)*x(2)*x(3) g(7,10)=g(7,10)*162.0e0 g(8,10)=y(1)*x(2)*x(3) + +x(1)*y(2)*x(3) + +x(1)*x(2)*y(3) g(8,10)=g(8,10)*54.0e0 g(9,10)=x(1)*y(2)*y(3) + +y(1)*x(2)*y(3) + +y(1)*y(2)*x(3) g(9,10)=g(9,10)*54.0e0 g(10,10)=y(1)*y(2)*y(3) g(10,10)=g(10,10)*162.0e0 c endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine deval(it,itnode,vx,vy,g,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3),itnode(5,*) real + x(3),y(3),g(5,15),tx(3),ty(3),vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c 3 3 3 3 c |\ |\ |\ |\ c | \ | \ 6 | \ 5 7 | \ 6 c | \ | \ | \ | \ c | \ 5| \ 4 | \ 8 | 15\ 5 c | \ | \ | \ | \ c | \ | \ 7 | 10 \ 4 9 | 1314\ 4 c |______\ |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 1 10 11 12 2 c c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) c if(iord.eq.1) then c c 1 = gx c 2 = gy c do j=1,3 g(1,j)=x(j) g(2,j)=y(j) enddo else if(iord.eq.2) then c c 1 = gxx c 2 = gxy c 3 = gyy c do j=1,3 j2=index(2,j) j3=index(3,j) c c c*(2*c-1) c g(1,j)=x(j)*x(j)*4.0e0 g(2,j)=x(j)*y(j)*4.0e0 g(3,j)=y(j)*y(j)*4.0e0 c c 4*c2*c3 c k=j+3 g(1,k)=8.0e0*x(j2)*x(j3) g(2,k)=4.0e0*(x(j2)*y(j3)+y(j2)*x(j3)) g(3,k)=8.0e0*y(j2)*y(j3) enddo else if(iord.eq.3) then c c 1 = gxxx c 2 = gxxy c 3 = gxyy c 4 = gyyy c do j=1,3 j2=index(2,j) j3=index(3,j) c c c*(3*c-1)(3*c-2)/2 c g(1,j)=x(j)*x(j)*x(j)*27.0e0 g(2,j)=y(j)*x(j)*x(j)*27.0e0 g(3,j)=y(j)*y(j)*x(j)*27.0e0 g(4,j)=y(j)*y(j)*y(j)*27.0e0 c c c2*c3*(3*c2-1)*9/2 c c jj=j2 k=2*j+2 do m=1,2 c g(1,k)=x(j2)*x(j3)*x(jj)*81.0e0 g(2,k)=(y(j2)*x(j3)*x(jj)+x(j2)*y(j3)*x(jj) + +x(j2)*x(j3)*y(jj))*27.0e0 g(3,k)=(x(j2)*y(j3)*y(jj)+y(j2)*x(j3)*y(jj) + +y(j2)*y(j3)*x(jj))*27.0e0 g(4,k)=y(j2)*y(j3)*y(jj)*81.0e0 c jj=j3 k=2*j+3 enddo enddo c g(1,10)=x(1)*x(2)*x(3)*162.0e0 g(2,10)=(y(1)*x(2)*x(3)+x(1)*y(2)*x(3) + +x(1)*x(2)*y(3))*54.0e0 g(3,10)=(x(1)*y(2)*y(3)+y(1)*x(2)*y(3) + +y(1)*y(2)*x(3))*54.0e0 g(4,10)=y(1)*y(2)*y(3)*162.0e0 c else if(iord.eq.4) then c c 1 = gxxxx c 2 = gxxxy c 3 = gxxyy c 4 = gxyyy c 5 = gyyyy c do j=1,3 j2=index(2,j) j3=index(3,j) c c c*(4*c-1)*(2*c-1)*(4*c-3)/3 c g(1,j)=x(j)*x(j)*x(j)*x(j)*256.0e0 g(2,j)=x(j)*x(j)*x(j)*y(j)*256.0e0 g(3,j)=x(j)*x(j)*y(j)*y(j)*256.0e0 g(4,j)=x(j)*y(j)*y(j)*y(j)*256.0e0 g(5,j)=y(j)*y(j)*y(j)*y(j)*256.0e0 c c c*(4*c-1)*(2*c-1)*c(j)*16/3 c jj=j3 k=3*j2+3 do m=1,2 c g(1,k)=x(j)*x(j)*x(j)*x(jj)*1024.0e0 g(2,k)=(3.0e0*y(j)*x(jj)+x(j)*y(jj)) + *x(j)*x(j)*256.0e0 g(3,k)=(y(j)*x(jj)+x(j)*y(jj))*x(j)*y(j)*512.0e0 g(4,k)=(3.0e0*x(j)*y(jj)+y(j)*x(jj)) + *y(j)*y(j)*256.0e0 g(5,k)=y(j)*y(j)*y(j)*y(jj)*1024.0e0 c jj=j2 k=3*j3+1 enddo c c c2*(4*c2-1)*(4*c3-1)*c3*4 c k=3*j+2 g(1,k)=x(j2)*x(j2)*x(j3)*x(j3)*1536.0e0 g(2,k)=(y(j2)*x(j3)+x(j2)*y(j3))*x(j2)*x(j3)*768.0e0 g(3,k)=(y(j2)*y(j2)*x(j3)*x(j3) + +y(j2)*x(j2)*x(j3)*y(j3)*4.0e0 1 +x(j2)*x(j2)*y(j3)*y(j3))*256.0e0 g(4,k)=(y(j2)*x(j3)+x(j2)*y(j3))*y(j2)*y(j3)*768.0e0 g(5,k)=y(j2)*y(j2)*y(j3)*y(j3)*1536.0e0 c c c1*c2*c3*(4*cj-1)*32 c k=j+12 g(1,k)=x(1)*x(2)*x(3)*x(j)*3072.0e0 g(2,k)=(y(1)*x(2)*x(3)*x(j)+x(1)*y(2)*x(3)*x(j) + +x(1)*x(2)*y(3)*x(j)+x(1)*x(2)*x(3)*y(j))*768.0e0 g(3,k)=(y(1)*y(2)*x(3)*x(j)+y(1)*x(2)*y(3)*x(j) + +y(1)*x(2)*x(3)*y(j)+x(1)*y(2)*y(3)*x(j) 1 +x(1)*y(2)*x(3)*y(j)+x(1)*x(2)*y(3)*y(j))*512.0e0 g(4,k)=(x(1)*y(2)*y(3)*y(j)+y(1)*x(2)*y(3)*y(j) + +y(1)*y(2)*x(3)*y(j)+y(1)*y(2)*y(3)*x(j))*768.0e0 g(5,k)=y(1)*y(2)*y(3)*y(j)*3072.0e0 enddo c endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cnodes(c,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + c(3,*) save index data index/1,2,3,2,3,1,3,1,2/ c c 3 3 3 3 c |\ |\ |\ |\ c | \ | \ 6 | \ 5 7 | \ 6 c | \ | \ | \ | \ c | \ 5| \ 4 | \ 8 | 15\ 5 c | \ | \ | \ | \ c | \ | \ 7 | 10 \ 4 9 | 1314\ 4 c |______\ |______\ |______\ |______\ c 1 2 1 6 2 1 8 9 2 1 10 11 12 2 c c if(iord.eq.1) then do i=1,3 do j=1,3 c(j,i)=0.0e0 enddo c(i,i)=1.0e0 enddo else if(iord.eq.2) then do i=1,3 do j=1,3 c(j,i)=0.0e0 c(j,i+3)=0.5e0 enddo c(i,i)=1.0e0 c(i,i+3)=0.0e0 enddo else if(iord.eq.3) then do i=1,3 do j=1,3 c(j,i)=0.0e0 c(j,2*i+2)=0.0e0 c(j,2*i+3)=0.0e0 enddo c(i,i)=1.0e0 c(i,10)=1.0e0/3.0e0 i2=index(2,i) i3=index(3,i) c(i2,2*i+2)=2.0e0/3.0e0 c(i3,2*i+2)=1.0e0/3.0e0 c(i2,2*i+3)=1.0e0/3.0e0 c(i3,2*i+3)=2.0e0/3.0e0 enddo else if(iord.eq.4) then do i=1,3 i2=index(2,i) i3=index(3,i) i4=3*i+1 i5=3*i+2 i6=3*i+3 i13=i+12 do j=1,3 c(j,i)=0.0e0 c(j,i4)=0.0e0 c(j,i5)=0.5e0 c(j,i6)=0.0e0 c(j,i13)=0.25e0 enddo c c(i,i)=1.0e0 c(i2,i4)=0.75e0 c(i3,i4)=0.25e0 c(i,i5)=0.0e0 c(i2,i6)=0.25e0 c(i3,i6)=0.75e0 c(i,i13)=0.5e0 enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine afmap(itri,itnode,vx,vy,tx,ty,x,y,det) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3),itnode(5,*) real + x(3),y(3),tx(3),ty(3),vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c tangent and normal vectors for triangle itri 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) do j=1,3 x(j)=-ty(j)/det y(j)=tx(j)/det enddo c return end c***************************** file: mg2.f ***************************** c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine trigen(vx,vy,xm,ym,itnode,ibndry,ja,a,ip,rp,sp, + iu,ru,su,w,qxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),iu(100),ja(*) real + 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.0.or.ip(6).gt.3) ip(6)=1 if(ip(7).lt.-5.or.ip(7).gt.6) ip(7)=1 if(ip(12).ne.1) ip(12)=0 if(ip(8).ne.1) ip(8)=0 if(ip(20).lt.-13.or.ip(20).gt.13) ip(20)=0 iadapt=iabs(ip(20)) nvtrgt=max0(0,ip(22)) ip(22)=nvtrgt ip(25)=0 if(ip(6).ne.0) ip(24)=0 c mpisw=ip(48) nproc=ip(49) irgn=ip(50) if(iadapt.ge.7.and.iadapt.le.9) then if(mpisw.ne.1) then ip(25)=48 go to 50 endif call exflag(ip(24)) if(ip(24).ne.0) then ip(25)=24 go to 50 endif endif 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(6).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(90) itdof=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(82) maxt=ip(83) maxv=ip(84) maxb=ip(86) maxpth=ip(81) c ibegin=iz iend=lenw c iord=ip(26) ndof=(iord+1)*(iord+2)/2 c c if(ip(6).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.0e0 rp(45)=0.0e0 rp(53)=1.0e0 rp(59)=0.0e0 rp(60)=0.0e0 rp(64)=1.0e-3 if(ip(7).eq.3.and.ip(9).lt.3) ip(9)=3 if(ip(7).eq.4) ip(9)=8 ip(70)=0 else call timer(w(jtime),-1) endif 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 ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) if(ip(20).eq.-5) then c c clean up skeleton c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(iequv,nvf,'head',ibegin,iend,iflag) lenjb=4*max0(nvf,nbf) call memptr(jbb,lenjb,'head',ibegin,iend,iflag) lenjv=7*max0(nvf,nbf) call memptr(jvv,3*lenjv,'head',ibegin,iend,iflag) lenjw=14*max0(nvf,nbf) call memptr(jww,lenjw,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 60 endif call timer(w(jtime),19) call sgen(ip,vx,vy,xm,ym,itnode,ibndry,w(jbb), + w(iequv),w(jvv),lenjv,rp,w(jww)) call timer(w(jtime),9) call memptr(isv,0,'free',ibegin,iend,iflag) if(ip(25).ne.0) go to 60 call dschek(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) go to 50 c c pointers c else 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) if(iflag.ne.0) then ip(25)=82 go to 60 endif c c call tgen c call timer(w(jtime),19) 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) call timer(w(jtime),1) call memptr(isv,0,'free',ibegin,iend,iflag) endif c endif c c ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) lenb=ip(76)*(iord+2) iudl=iuu+(ip(77)-1)*maxv ndf=ip(5) maxd=ip(89) c c initialize triangluation c compute user specified triangulations c isw=0 if(ip(6).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 ip(6)=0 c c setup itdof c ntf=ip(1) nvf=ip(2) nbf=ip(4) call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(iequv,nvf,'head',ibegin,iend,iflag) call memptr(itedge,3*ntf,'head',ibegin,iend,iflag) call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) ll=3*ntf+nbf+nvf call memptr(mark,ll,'head',ibegin,iend,iflag) ndof=(iord+1)*(iord+2)/2 call mkdof(ip,itnode,ibndry,w(itedge),w(ibedge), + w(iequv),w(mark),ndof,w(itdof)) call memptr(isv,0,'free',ibegin,iend,iflag) c ndf=ip(5) maxd=ip(89) c call gfinit(ip,maxd,w(iuu),w(iee)) endif c c compute error estimates c isw=0 if(iadapt.le.4) isw=1 if(iadapt.eq.8) 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,ndf,'head',ibegin,iend,iflag) call memptr(mark,ndf,'head',ibegin,iend,iflag) call memptr(img,15*ndf,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 50 endif call timer(w(jtime),19) call cdlfn(ip,itnode,ndof,w(itdof),w(ibb),w(iudl), + ja,a,w(ka),w(mark),w(img),w(jhist)) call timer(w(jtime),7) call memptr(isv,0,'free',ibegin,iend,iflag) endif c call memptr(ksv,0,'mark',ibegin,iend,iflag) call memptr(ibump,maxt*lenb,'head',ibegin,iend,iflag) call memptr(jsv,0,'mark',ibegin,iend,iflag) call memptr(itldof,3*ntf,'head',ibegin,iend,iflag) c c compute itldof c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(itedge,3*ntf,'head',ibegin,iend,iflag) call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) ll=nvf+nbf+3*ntf call memptr(ivtype,ll,'head',ibegin,iend,iflag) call memptr(iseed,nvf,'head',ibegin,iend,iflag) call citdof(ip,itnode,ibndry,w(itedge),w(ibedge), + w(ivtype),w(iseed),w(itldof)) ndl=ip(78) call memptr(isv,0,'free',ibegin,iend,iflag) ll=max0(ndf,nvf,ndl) call memptr(idist,ll,'head',ibegin,iend,iflag) call memptr(jc,25*ndl+3*ntf,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 50 endif call timer(w(jtime),19) call errest(ip,rp,itnode,ibndry,vx,vy,xm,ym,w(iuu), + w(iee),w(ibump),w(iudl),w(jc),w(idist),ndof, 1 w(itdof),w(itldof),w(jhist),w(jstat),qxy) call timer(w(jtime),6) if(iadapt.eq.8) then call memptr(ksv,0,'free',ibegin,iend,iflag) go to 10 else call memptr(jsv,0,'free',ibegin,iend,iflag) endif 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)=82 go to 50 endif call cedge1(nvf,ntf,nbf,itnode,ibndry,w(itedge), + w(ibedge),w(list),jflag) call memptr(isv,0,'free',ibegin,iend,iflag) endif c c refine or unrefine c 10 if(iadapt.eq.1) then call memptr(ivtype,maxv,'head',ibegin,iend,iflag) ll=max0(maxt,maxv,maxd) call memptr(iseed,ll,'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) if(iflag.ne.0) then ip(25)=82 go to 50 endif call timer(w(jtime),19) call refine(ip,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),ndof,w(itdof)) 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) if(iflag.ne.0) then ip(25)=82 go to 50 endif call timer(w(jtime),19) 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),ndof,w(itdof)) 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) ll=max0(maxt,maxv,maxd) call memptr(iseed,ll,'head',ibegin,iend,iflag) call memptr(ipp,ll,'head',ibegin,iend,iflag) call memptr(iqq,ll,'head',ibegin,iend,iflag) call memptr(iqual,ll,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 50 endif call timer(w(jtime),19) 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),ndof,w(itdof)) ip(22)=nvf call timer(w(jtime),3) call refine(ip,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),ndof,w(itdof)) ip(22)=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)=82 go to 50 endif call timer(w(jtime),19) 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(21)) ip(21)=irefn call memptr(ija,4*nvf,'head',ibegin,iend,iflag) call memptr(mark,ntf,'head',ibegin,iend,iflag) len1=irefn+1 call memptr(nodev,len1**2,'head',ibegin,iend,iflag) len2=iord*irefn+1 call memptr(nodef,len2**2,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 50 endif call timer(w(jtime),19) call unifrm(ip,itnode,ibndry,vx,vy,xm,ym,maxd,w(iuu), + w(iee),lenb,w(ibump),w(ija),w(ibedge),w(mark), 1 ndof,w(itdof),len1,w(nodev),len2,w(nodef),1) call timer(w(jtime),4) c c create skeleton c else if(iadapt.eq.6) then c c convert higher order elements to linear on finer mesh c irefn=max0(1,iord) call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ija,4*nvf,'head',ibegin,iend,iflag) call memptr(mark,ntf,'head',ibegin,iend,iflag) len1=irefn+1 call memptr(nodev,len1**2,'head',ibegin,iend,iflag) len2=iord*irefn+1 call memptr(nodef,len2**2,'head',ibegin,iend,iflag) call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) ibump=iuu if(iflag.ne.0) then ip(25)=82 go to 50 endif call cedge3(nvf,ntf,nbf,itnode,ibndry,w(ibedge), + w(ija),jflag) call timer(w(jtime),19) call unifrm(ip,itnode,ibndry,vx,vy,xm,ym,maxd,w(iuu), + w(iee),lenb,w(ibump),w(ija),w(ibedge),w(mark), 1 ndof,w(itdof),len1,w(nodev),len2,w(nodef),0) call timer(w(jtime),4) call memptr(isv,0,'free',ibegin,iend,iflag) ntf=ip(1) nvf=ip(2) nbf=ip(4) c c initialize data structures c 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,3*lenjv,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 60 endif c call rinit(ip,rp,itnode,ibndry,vx,vy,w(ivz),xm,ym,w(iuu), + w(iarea),w(itedge),w(ibedge),w(iequv),w(jv), 1 ndof,w(itdof),qxy) if(ip(25).ne.0) go to 50 c call timer(w(jtime),19) 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(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) call memptr(keq,ntf,'head',ibegin,iend,iflag) call memptr(keqc,ntf,'head',ibegin,iend,iflag) call memptr(kmap,ntf,'head',ibegin,iend,iflag) call memptr(iaa,5*nvf,'head',ibegin,iend,iflag) call memptr(jaa,5*nvf,'head',ibegin,iend,iflag) ljz=max0(7*ntf,8*nproc-4) call memptr(jz,ljz,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 20 endif call timer(w(jtime),19) call ldbal(ip,itnode,w(itedge),w(ibedge),ibndry, + w(iee),w(ipp),w(iqq),w(jaa),w(iaa),w(jl),w(jz), 1 w(keq),w(keqc),w(kmap),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),19) call bcast(vx,vy,xm,ym,ibndry,itnode,ja,a,ip,rp,sp, + iu,ru,su,w) jtime=ip(92) call timer(w(jtime),15) c c make mesh conforming c else if(iadapt.eq.8) then do iter=1,2 c c cut c call memptr(isv,0,'mark',ibegin,iend,iflag) ll=max0(8*maxb,3*maxt) call memptr(itedge,ll,'head',ibegin,iend,iflag) call memptr(ibedge,2*maxb,'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) if(iflag.ne.0) then ip(25)=82 go to 30 endif call timer(w(jtime),19) call cutr(ip,itnode,ibndry,vx,vy,w(iee),w(ipp),w(iqq), + w(ibef),w(iaft),w(itedge),w(ibedge),maxd,w,1, 1 ndof,w(itdof)) call timer(w(jtime),12) if(ip(25).ne.0) go to 30 c call mkpth(ip,irgn,w(ipath),itnode,ibndry,w(ibedge), + ndof,w(itdof),w(itedge),w(ipp)) if(ip(25).ne.0) go to 30 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) if(iflag.ne.0) then ip(25)=82 go to 30 endif call timer(w(jtime),19) call expth(ip,w(ipath),w(ipath0),w(ic),w(jc)) call timer(w(jtime),17) call memptr(isv,0,'free',ibegin,iend,iflag) if(ip(25).ne.0) go to 30 c c paste c call memptr(isv,0,'mark',ibegin,iend,iflag) call memptr(ibedge,2*maxb,'head',ibegin,iend,iflag) ll=max0(8*maxb,3*maxt) call memptr(itedge,ll,'head',ibegin,iend,iflag) llist=max0(maxv+maxb+3*maxt,4*maxpth,6*maxb) call memptr(list,llist,'head',ibegin,iend,iflag) call memptr(ivtype,maxv,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 30 endif if(iter.eq.2) then call timer(w(jtime),19) call paste1(ip,itnode,ibndry,vx,vy,xm,ym,maxd, + w(iuu),w(itedge),w(ibedge),w(ivtype),w(list), 1 w(ipath),w(ivtype),ndof,w(itdof)) call timer(w(jtime),14) else call timer(w(jtime),19) call paste(ip,itnode,w(itedge),ibndry,w(ibedge), + w(ipath),vx,vy,xm,ym,maxd,w,w(list),1,ndof, 1 w(itdof)) call timer(w(jtime),13) endif call memptr(isv,0,'free',ibegin,iend,iflag) 30 call exflag(ip(25)) if(ip(25).ne.0) go to 50 enddo c c cut and paste c else if(iadapt.eq.9) then 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,ndf) call memptr(ipp,lpp,'head',ibegin,iend,iflag) lqq=max0(ntf,maxb,ndf) 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)=82 go to 50 endif call timer(w(jtime),19) call cutr(ip,itnode,ibndry,vx,vy,w(iee),w(ipp),w(iqq), + w(ibef),w(iaft),w(itedge),w(ibedge),maxd,w(iuu),0, 1 ndof,w(itdof)) call timer(w(jtime),12) call memptr(isv,0,'free',ibegin,iend,iflag) call exflag(ip(25)) if(ip(25).ne.0) go to 50 c c master process collects the global fine mesh c call timer(w(jtime),19) call collct(vx,vy,ibndry,itnode,ip,sp,w(iee), + maxd,w(iuu),ndof,w(itdof),w(iz)) call timer(w(jtime),16) call exflag(ip(25)) 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) ll=max0(8*maxb,3*maxt) call memptr(itedge,ll,'head',ibegin,iend,iflag) llist=max0(maxv+maxb+3*maxt,4*maxpth,6*maxb) call memptr(list,llist,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 go to 40 endif call timer(w(jtime),19) call paste(ip,itnode,w(itedge),ibndry,w(ibedge), + w(ipath),vx,vy,xm,ym,maxd,w,w(list),0,ndof, 1 w(itdof)) call timer(w(jtime),13) call memptr(isv,0,'free',ibegin,iend,iflag) if(ip(25).ne.0) go to 40 endif 40 call exflag(ip(25)) endif c 50 call timer(w(jtime),19) c 60 iflag=ip(25) c c messages c if(iflag.eq.0) then if(ip(20).eq.9) then write(unit=sp(11),fmt='(a19,i2,3(a6,i7),a6,i6,a1)') + 'trigen: ok (iadapt=',ip(20),', ntg=',ip(37), 1 ', nvg=',ip(38),', ndg=',ip(40), 1 ', nbg=',ip(39),')' elseif(itnode(3,1).eq.0) then write(unit=sp(11),fmt='(a19,i2,3(a6,i6),a6,i5,a1)') + 'trigen: ok (iadapt=',ip(20),', ntf=',ip(1), 1 ', nvf=',ip(2),', ncf=',ip(3),', nbf=',ip(4),')' else write(unit=sp(11),fmt='(a19,i2,3(a6,i6),a6,i5,a1)') + 'trigen: ok (iadapt=',ip(20),', ntf=',ip(1), 1 ', nvf=',ip(2),', ndf=',ip(5),', nbf=',ip(4),')' endif else if(iflag.ge.82.and.iflag.le.89) then write(unit=sp(11),fmt='(a12,i3,a22)') + 'trigen error',iflag,': insufficient storage' if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.25) then write(unit=sp(11),fmt='(a12,i3,a28)') + 'trigen error',iflag,': wrong input data structure' else if(iflag.eq.24) then write(unit=sp(11),fmt='(a12,i3,a8,i4)') + 'trigen error',iflag,': region',ip(24) else if(iflag.eq.48) then write(unit=sp(11),fmt='(a12,i3,a12)') + 'trigen error',iflag,': mpi is off' else if(iflag.eq.49) then write(unit=sp(11),fmt='(a12,i3,a22)') + 'trigen error',iflag,': nproc > ntf in ldbal' if(nproc.gt.1) ip(24)=irgn else if(iflag.eq.72) then write(unit=sp(11),fmt='(a12,i3,a23)') + 'trigen error',iflag,': interface array error' ip(72)=0 if(nproc.gt.1) ip(24)=irgn else write(unit=sp(11),fmt='(a12,i3,a15)') + 'trigen error',iflag,': unknown error' if(nproc.gt.1) ip(24)=irgn endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine errest(ip,rp,itnode,ibndry,vx,vy,xm,ym,u,e,bump, + udl,z,idist,ndof,itdof,itldof,hist,pstat,qxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),idist(*), 1 itdof(ndof,*),idof(10),itldof(3,*) real + u(*),vx(*),vy(*),bump(*),rp(100),e(*),hist(22,*), 1 pstat(10,*),udl(*),xm(*),ym(*),z(*) 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) ndf=ip(5) ndl=ip(78) iadapt=ip(20) nvtrgt=ip(22) mpisw=ip(48) nproc=ip(49) irgn=ip(50) nef=ip(76) ngf=ip(77) iprob=ip(7) maxd=ip(89) iord=ip(26) lenb=nef*(iord+2) c c initial error estimates c if(iadapt.ge.0) then maxlnk=4*ndl icurv=1 ja=icurv+3*ntf ia1=ja+maxlnk ia2=ia1+maxlnk irr=ia2+maxlnk iz=irr+ndl*(iord+1) ibedge=ja list=ibedge+2*nbf call cedge3(nvf,ntf,nbf,itnode,ibndry,z(ibedge), + z(list),jflag) call ccurv(ntf,nbf,ibndry,z(ibedge),z(icurv)) call cbump(ndl,ntf,ndf,maxd,nef,iord,u,vx,vy,xm,ym, + itnode,itldof,z(icurv),z(ja),z(ia1),z(ia2),z(irr), 1 z(iz),ndof,itdof,lenb,bump,e,rp) else call usrfn(ntf,iord,itnode,ndof,itdof,iprob,vx,vy, + ngf,maxd,u,e,rp,lenb,bump,qxy) endif ii=0 if(mpisw.eq.1.and.iadapt.eq.0) ii=1 if(iadapt.eq.8) ii=1 if(ii.eq.1) then call pnorm(ip,rp,itnode,vx,vy,lenb,bump,maxd,nef, + u,idist,ndof,itdof,hist) endif ii=iabs(iadapt) if(ii.eq.1.and.nvtrgt.lt.nvf) then call hist2(hist,rp,-1,ndf) else call hist2(hist,rp,ii,ndf) endif call pstat1(ntf,nproc,pstat,itnode,e,2) if(mpisw.eq.1.and.ii.le.4) then c c iz should be of size 11*nvf (for linears) c c compute distance function in graph c maxlnk=nvf*4 ja=1 jc=ja+maxlnk jord=ja iq=ja call setgr(ntf,nvf,nbf,itnode,ibndry,z(ja),maxlnk) c call cgdist(nvf,ntf,nbf,z(ja),z(jc),z(iq), + z(jord),idist,irgn,itnode,ibndry,0) c itheta=1 ifact=2 r0=1.0e-1 do i=1,ntf if(itnode(4,i).ne.irgn) then ii=min0(idist(itnode(1,i)),idist(itnode(2,i)), + idist(itnode(3,i)))-itheta if(ii.gt.0) then ss=1.0e-6 call l2gmap(i,idof,ndof,itdof) do j=1,ndof ss=amax1(ss,abs(udl(idof(j)))) enddo ratio=r0*amin1(ss,1.0e0)/float(ifact*ii) else ratio=r0 endif k=(i-1)*lenb do j=1,lenb bump(j+k)=bump(j+k)*ratio enddo endif enddo c endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine refine(ip,itnode,ibndry,vx,vy,xm,ym,gf,e,bump, + iseed,itedge,ibedge,vtype,p,q,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*),p(*),q(*), 1 itedge(3,*),vtype(*),ibedge(2,*),itdof(ndof,*) real + gf(*),e(*),xm(*),ym(*),vx(*),vy(*),bump(*) c c check to see if we have solved problem on current finest grid c maxt=ip(83) maxv=ip(84) maxb=ip(86) ndf=ip(5) maxd=ip(89) iord=ip(26) lenb=ip(76)*(iord+2) ngf=ip(77) ntf=ip(1) nvf=ip(2) nbf=ip(4) ibase=ip(70) nvtrgt=min0(ip(22),8*nvf/(iord+1)) if(nvf.ge.nvtrgt) return iflag=0 c c c do i=1,ntf iseed(i)=0 p(i)=i q(i)=i enddo do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) 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 itri0=p(1) if(e(itri0).le.0.0e0) go to 60 c 45 call etst1(itri0,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) call newnot(itri,iedge,nvf,ntf,nbf,ndf,iord,itnode, + itedge,ibndry,ibedge,ndof,itdof,vx,vy,xm,ym, 1 maxv,maxt,maxb,maxd,gf,ngf,ibase,lenb,bump, 2 p,q,e,1,iflag) c if(iflag.ne.0) go to 60 if(isw.eq.0) go to 45 enddo c c degree edge swapping, geometry improvement c 60 call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,e,1,1,iord,ndof,itdof) call cedge5(nbf,itedge,ibedge,0) c c angmin=1.0e-3 arcmax=0.26e0 call cvtype(ntf,nbf,nvf,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 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) enddo c ip(25)=iflag ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(5)=ndf c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mvemsh(ip,itnode,ibndry,vx,vy,xm,ym, + bump,e,itedge,ibedge,vtype,iseed) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),itedge(3,*),vtype(*), 1 iseed(*),ibedge(2,*) real + vx(*),vy(*),bump(*),xm(*),ym(*),e(*) c c move mesh c ntf=ip(1) nvf=ip(2) nbf=ip(4) iord=ip(26) lenb=ip(76)*(iord+2) c c compute triangle tree data structures c angmin=1.0e-3 arcmax=0.26e0 c c initailize iseed, vtype c call cvtype(ntf,nbf,nvf,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,iord,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 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine unrefn(ip,rp,itnode,ibndry,vx,vy,xm,ym,gf,e,bump, + itedge,ibedge,vtype,p,q,qual,iseed,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*),p(*),q(*), 1 itedge(3,*),vtype(*),ibedge(2,*),corner(9), 2 elist(500),tlist(500),vlist(500),blist(500),vsv(500), 3 itdof(ndof,*) real + gf(*),rp(100),e(*),xm(*),ym(*),vx(*),vy(*), 1 bump(*),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 ntf=ip(1) nvf=ip(2) nbf=ip(4) ndf=ip(5) maxd=ip(89) iord=ip(26) lenb=ip(76)*(iord+2) irgn=ip(50) ibase=ip(70) ngf=ip(77) nvtrgt=max0(ip(22),nvf*iord/(iord+1)) if(rp(15).le.0.0e0.or.rp(15).gt.1.0e0) rp(15)=1.0e0 c if(nvf.le.nvtrgt) go to 60 c angmin=1.0e-3 arcmax=0.26e0 c c initialize iseed, vtype c call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c nn=ntf*lenb emax=0.0e0 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) emax=amax1(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) 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) 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) endif enddo endif c c reduce to degree 3 or 4 by edge swapping c call eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,1,1,iord,ndof,itdof,iflag) c c if(corner(vtype(i)).eq.1) stop 6235 if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,ndof, + itdof,vx,vy,lenb,bump,e,iseed,vtype, 1 vlist,tlist,elist,len,iord,ibase,1) if(vtype(i).eq.8) then len1=elist(len+2)-(len+1) call dlknot(ii,itnode,itedge,ibndry,ibedge,ndof, + itdof,vx,vy,lenb,bump,e,iseed,vtype, 1 vlist(len+2),tlist(len+2), 2 elist(len+2),len1,iord,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) kk=q(j) call updhp(kk,last,p,q,qual,1) enddo enddo 60 call clnup(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,lenb,bump,iseed,gf,maxd,ngf,ndof,itdof) c c improve geometry c call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,e,1,1,iord,ndof,itdof) call cedge5(nbf,itedge,ibedge,0) c c call cvtype(ntf,nbf,nvf,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 do i=1,ntf e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) enddo c ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(5)=ndf c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine unifrm(ip,itnode,ibndry,vx,vy,xm,ym,maxd,gf,e,lenb, + bump,ja,ibedge,mark,ndof,itdof,len1,nodev,len2,nodef,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),ja(*),mark(*),idof(10), 1 ibedge(2,*),itdof(ndof,*),nodev(len1,*),nodef(len2,*) real + gf(maxd,*),bump(lenb,*),e(*),xm(*),ym(*),vx(*),vy(*), 1 c(3),gv(10) c c this routine does uniform refinement c len1=irefn+1 c len2=iord*irefn+1 c if(isw.eq.1) then irefn=ip(21) else irefn=ip(26) endif if(irefn.le.1) return maxt=ip(83) maxv=ip(84) maxb=ip(86) ntf=ip(1) nvf=ip(2) nbf=ip(4) ngf=ip(77) ndf=ip(5) maxd=ip(89) iord=ip(26) nhole=(2*nvf-ntf-nbf-2)/2 ntnew=ntf*irefn**2 if(ntnew.gt.maxt) then ip(25)=83 return endif nbnew=nbf*irefn if(nbnew.gt.maxb) then ip(25)=86 return endif nvnew=(ntnew+nbnew+2-2*nhole)/2 if(nvnew.gt.maxv) then ip(25)=84 return endif c c comput ja c lenja=nvf+1+(3*ntf+nbf)/2 call setgr(ntf,nvf,nbf,itnode,ibndry,ja,lenja) c jrefn=iord*irefn net=(jrefn-2)*(jrefn-1)/2-(iord-2)*(iord-1)/2 nev=(irefn-2)*(irefn-1)/2 ned=ja(nvf+1)-ja(1) ndnew=ndf+(jrefn-iord)*ned+ntf*net if(ndnew.gt.maxd.and.isw.eq.1) then ip(25)=89 return endif c pi=3.141592653589793e0 nv0=nvf nt0=ntf nb0=nbf nd0=ndf 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 c initalize boundary edges c do i=1,nv0 j1=ja(i) j2=ja(i+1)-1 do jj=j1,j2 j=ja(jj) do kk=1,irefn-1 nvf=nvf+1 c2=float(kk)/float(irefn) c1=1.0e0-c2 vx(nvf)=c1*vx(i)+c2*vx(j) vy(nvf)=c1*vy(i)+c2*vy(j) enddo enddo enddo c c add new boundary edges c nb0=nbf do i=1,nb0 iv1=ibndry(1,i) iv2=ibndry(2,i) if(iv1.lt.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)/float(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*float(m))*pi xx=xm(kt)+r*cos(tt)-vx(m3) yy=ym(kt)+r*sin(tt)-vy(m3) c1=(xx*y2-yy*x2)/det c2=(x1*yy-y1*xx)/det c3=1.0e0-c1-c2 vx(m12)=c1*vx(m1)+c2*vx(m2)+c3*vx(m3) vy(m12)=c1*vy(m1)+c2*vy(m2)+c3*vy(m3) 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 c c make new triangles, dofs c do it=1,nt0 c c initialize, transfer known data c iv1=itnode(1,it) iv2=itnode(2,it) iv3=itnode(3,it) call l2gmap(it,idof,ndof,itdof) do i=1,jrefn+1 do j=1,jrefn+2-i nodef(i,j)=0 enddo enddo nodef(1,1)=idof(1) nodef(jrefn+1,1)=idof(2) nodef(1,jrefn+1)=idof(3) if(iord.eq.2) then j1=irefn+1 nodef(j1,j1)=idof(4) nodef(1,j1)=idof(5) nodef(j1,1)=idof(6) else if(iord.eq.3) then j1=irefn+1 j2=2*irefn+1 nodef(j2,j1)=idof(4) nodef(j1,j2)=idof(5) nodef(1,j2)=idof(6) nodef(1,j1)=idof(7) nodef(j1,1)=idof(8) nodef(j2,1)=idof(9) nodef(j1,j1)=idof(10) endif do i=1,irefn+1 do j=1,irefn+2-i nodev(i,j)=0 enddo enddo nodev(1,1)=iv1 nodev(irefn+1,1)=iv2 nodev(1,irefn+1)=iv3 c c 1-2 edge c call jacmap(iv1,iv2,j,jj,ja,0) if(iv1.lt.iv2) then nn=nd0+(jrefn-iord)*(j-ja(1))+1 mm=nv0+(irefn-1)*(j-ja(1))+1 inc=1 else nn=nd0+(jrefn-iord)*(j-ja(1))+(jrefn-iord) mm=nv0+(irefn-1)*(j-ja(1))+irefn-1 inc=-1 endif do i=1,jrefn+1 if(nodef(i,1).eq.0) then nodef(i,1)=nn nn=nn+inc endif enddo do i=1,irefn+1 if(nodev(i,1).eq.0) then nodev(i,1)=mm mm=mm+inc endif enddo c c 1-3 edge c call jacmap(iv1,iv3,j,jj,ja,0) if(iv1.lt.iv3) then nn=nd0+(jrefn-iord)*(j-ja(1))+1 mm=nv0+(irefn-1)*(j-ja(1))+1 inc=1 else nn=nd0+(jrefn-iord)*(j-ja(1))+(jrefn-iord) mm=nv0+(irefn-1)*(j-ja(1))+irefn-1 inc=-1 endif do i=1,jrefn+1 if(nodef(1,i).eq.0) then nodef(1,i)=nn nn=nn+inc endif enddo do i=1,irefn+1 if(nodev(1,i).eq.0) then nodev(1,i)=mm mm=mm+inc endif enddo c c 2-3 edge c call jacmap(iv2,iv3,j,jj,ja,0) if(iv2.lt.iv3) then nn=nd0+(jrefn-iord)*(j-ja(1))+1 mm=nv0+(irefn-1)*(j-ja(1))+1 inc=1 else nn=nd0+(jrefn-iord)*(j-ja(1))+(jrefn-iord) mm=nv0+(irefn-1)*(j-ja(1))+irefn-1 inc=-1 endif do i=1,jrefn+1 if(nodef(jrefn+2-i,i).eq.0) then nodef(jrefn+2-i,i)=nn nn=nn+inc endif enddo do i=1,irefn+1 if(nodev(irefn+2-i,i).eq.0) then nodev(irefn+2-i,i)=mm mm=mm+inc endif enddo c c interior c nn=nd0+(jrefn-iord)*ned+(it-1)*net+1 do i=1,jrefn+1 do j=1,jrefn+2-i if(nodef(i,j).eq.0) then nodef(i,j)=nn nn=nn+1 endif enddo enddo mm=nv0+(irefn-1)*ned+(it-1)*nev+1 do i=1,irefn+1 do j=1,irefn+2-i if(nodev(i,j).eq.0) then nodev(i,j)=mm c2=float(i-1)/float(irefn) c3=float(j-1)/float(irefn) c1=1.0e0-c2-c3 vx(mm)=c1*vx(iv1)+c2*vx(iv2)+c3*vx(iv3) vy(mm)=c1*vy(iv1)+c2*vy(iv2)+c3*vy(iv3) mm=mm+1 endif enddo enddo c c smooth interior vertices for elements with curved edges c if(mark(it).le.0) go to 20 itmax=100 tol=amax1(abs(vx(iv1)-vx(iv2)),abs(vy(iv1)-vy(iv2)), + abs(vx(iv1)-vx(iv3)),abs(vy(iv1)-vy(iv3)), 1 abs(vx(iv2)-vx(iv3)),abs(vy(iv2)-vy(iv3)))*1.e-2 tol=1.e-2 do itnum=1,itmax cc=0.0e0 do i=2,irefn-1 do j=2,irefn+1-i xx=(vx(nodev(i,j-1))+vx(nodev(i,j+1))+ + vx(nodev(i+1,j))+vx(nodev(i-1,j))+ 1 vx(nodev(i+1,j-1))+vx(nodev(i-1,j+1)))/6.0e0 yy=(vy(nodev(i,j-1))+vy(nodev(i,j+1))+ + vy(nodev(i+1,j))+vy(nodev(i-1,j))+ 1 vy(nodev(i+1,j-1))+vy(nodev(i-1,j+1)))/6.0e0 cc=amax1(cc,abs(xx-vx(nodev(i,j))), + abs(yy-vy(nodev(i,j)))) vx(nodev(i,j))=xx vy(nodev(i,j))=yy enddo enddo if(cc.le.tol) go to 20 enddo c c grid function interpolations c 20 if(isw.eq.1) then do i=1,jrefn+1 do j=1,jrefn+2-i k=nodef(i,j) if(k.gt.nd0) then c(2)=float(i-1)/float(jrefn) c(3)=float(j-1)/float(jrefn) c(1)=1.0e0-c(2)-c(3) call beval1(c,gv,iord) do ifn=1,ngf gf(k,ifn)=0.0e0 do m=1,ndof gf(k,ifn)=gf(k,ifn)+ + gf(idof(m),ifn)*gv(m) enddo enddo endif enddo enddo endif c c new triangles c nn=nt0+(irefn**2-1)*(it-1)+1 do i=1,irefn do j=1,i if(i.eq.1) then itnode(1,it)=nodev(1,1) itnode(2,it)=nodev(2,1) itnode(3,it)=nodev(1,2) c itdof(1,it)=nodef(1,1) itdof(2,it)=nodef(1+iord,1) itdof(3,it)=nodef(1,1+iord) if(iord.eq.2) then itdof(4,it)=nodef(2,2) itdof(5,it)=nodef(1,2) itdof(6,it)=nodef(2,1) elseif(iord.eq.3) then itdof(4,it)=nodef(3,2) itdof(5,it)=nodef(2,3) itdof(6,it)=nodef(1,3) itdof(7,it)=nodef(1,2) itdof(8,it)=nodef(2,1) itdof(9,it)=nodef(3,1) itdof(10,it)=nodef(2,2) endif else if(j.eq.1) then itnode(1,nn)=nodev(i,1) itnode(2,nn)=nodev(i+1,1) itnode(3,nn)=nodev(i,2) itnode(4,nn)=itnode(4,it) itnode(5,nn)=itnode(5,it) c ii=iord*(i-1)+1 itdof(1,nn)=nodef(ii,1) itdof(2,nn)=nodef(ii+iord,1) itdof(3,nn)=nodef(ii,iord+1) if(iord.eq.2) then itdof(4,nn)=nodef(ii+1,2) itdof(5,nn)=nodef(ii,2) itdof(6,nn)=nodef(ii+1,1) elseif(iord.eq.3) then itdof(4,nn)=nodef(ii+2,2) itdof(5,nn)=nodef(ii+1,3) itdof(6,nn)=nodef(ii,3) itdof(7,nn)=nodef(ii,2) itdof(8,nn)=nodef(ii+1,1) itdof(9,nn)=nodef(ii+2,1) itdof(10,nn)=nodef(ii+1,2) endif nn=nn+1 else ij=i-j+1 itnode(1,nn)=nodev(ij+1,j) itnode(2,nn)=nodev(ij,j) itnode(3,nn)=nodev(ij+1,j-1) itnode(4,nn)=itnode(4,it) itnode(5,nn)=itnode(5,it) c ii=iord*(i-j)+1 jj=iord*(j-1)+1 itdof(1,nn)=nodef(ii+iord,jj) itdof(2,nn)=nodef(ii,jj) itdof(3,nn)=nodef(ii+iord,jj-iord) if(iord.eq.2) then itdof(4,nn)=nodef(ii+1,jj-1) itdof(5,nn)=nodef(ii+2,jj-1) itdof(6,nn)=nodef(ii+1,jj) elseif(iord.eq.3) then itdof(4,nn)=nodef(ii+1,jj-1) itdof(5,nn)=nodef(ii+2,jj-2) itdof(6,nn)=nodef(ii+3,jj-2) itdof(7,nn)=nodef(ii+3,jj-1) itdof(8,nn)=nodef(ii+2,jj) itdof(9,nn)=nodef(ii+1,jj) itdof(10,nn)=nodef(ii+2,jj-1) endif nn=nn+1 c itnode(1,nn)=nodev(ij,j) itnode(2,nn)=nodev(ij+1,j) itnode(3,nn)=nodev(ij,j+1) itnode(4,nn)=itnode(4,it) itnode(5,nn)=itnode(5,it) c itdof(1,nn)=nodef(ii,jj) itdof(2,nn)=nodef(ii+iord,jj) itdof(3,nn)=nodef(ii,jj+iord) if(iord.eq.2) then itdof(4,nn)=nodef(ii+1,jj+1) itdof(5,nn)=nodef(ii,jj+1) itdof(6,nn)=nodef(ii+1,jj) elseif(iord.eq.3) then itdof(4,nn)=nodef(ii+2,jj+1) itdof(5,nn)=nodef(ii+1,jj+2) itdof(6,nn)=nodef(ii,jj+2) itdof(7,nn)=nodef(ii,jj+1) itdof(8,nn)=nodef(ii+1,jj) itdof(9,nn)=nodef(ii+2,jj) itdof(10,nn)=nodef(ii+1,jj+1) endif nn=nn+1 endif enddo enddo c c update bump, e c if(isw.eq.1) then n1=nt0+(irefn**2-1)*(it-1)+1 n2=nn-1 e(it)=tqual(it,itnode,vx,vy,lenb,bump,iord) do i=n1,n2 do j=1,lenb bump(j,i)=bump(j,it) enddo e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) enddo endif enddo c nvf=nv0+(irefn-1)*ned+nt0*nev ndf=nd0+(jrefn-iord)*ned+nt0*net ntf=nt0*irefn**2 c ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(5)=ndf c ip(25)=0 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dlknot(i,itnode,itedge,ibndry,ibedge,ndof,itdof, + vx,vy,lenb,bump,e,iseed,vtype, 1 vlist,tlist,elist,len,iord,ibase,isw) c implicit real (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,*),itdof(ndof,*),idof(10),kdof(10),jdof(10) real + 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 icase=2 numax=2 if(len.eq.3) then jj=2 icase=1 else do m=2,len+1 gg(m)=geom(vlist(m-1),vlist(m), + vlist(m+1),vx,vy) enddo if(amin1(gg(2),gg(4)).lt.amin1(gg(3),gg(5))) then jj=2 else jj=1 endif endif else if(vtype(i).eq.6.or.vtype(i).eq.8) then icase=3 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 icase=2 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 icase=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.0e0 enddo e(it)=tqual(it,itnode,vx,vy,lenb,bump,iord) endif enddo c c update itdof c if(isw.eq.0) return it=tlist(jj) ied=iabs(elist(jj)) i2=index(2,ied) i3=index(3,ied) call l2gmap(it,idof,ndof,itdof) kt=tlist(jj+1) ked=iabs(elist(jj+1)) k2=index(2,ked) k3=index(3,ked) call l2gmap(kt,kdof,ndof,itdof) itdof(ied,it)=kdof(k3) if(icase.eq.1) then jt=tlist(jj+2) jed=iabs(elist(jj+2)) call l2gmap(jt,jdof,ndof,itdof) if(iord.eq.2) then itdof(i2+3,it)=kdof(ked+3) itdof(i3+3,it)=jdof(jed+3) else if(iord.eq.3) then itdof(2*i2+2,it)=kdof(2*ked+2) itdof(2*i2+3,it)=kdof(2*ked+3) itdof(2*i3+2,it)=jdof(2*jed+2) itdof(2*i3+3,it)=jdof(2*jed+3) itdof(10,it)=idof(ied) endif else if(iord.eq.2) then itdof(i2+3,it)=kdof(ked+3) itdof(i3+3,it)=idof(ied) else if(iord.eq.3) then itdof(2*i2+2,it)=kdof(2*ked+2) itdof(2*i2+3,it)=kdof(2*ked+3) itdof(2*i3+2,it)=kdof(2*k2+3) itdof(2*i3+3,it)=idof(2*i3+2) itdof(10,it)=idof(2*i2+3) endif if(icase.eq.3) return it=tlist(jj+3) ied=iabs(elist(jj+3)) i2=index(2,ied) i3=index(3,ied) call l2gmap(it,idof,ndof,itdof) kt=tlist(jj+2) ked=iabs(elist(jj+2)) k2=index(2,ked) k3=index(3,ked) call l2gmap(kt,kdof,ndof,itdof) itdof(ied,it)=kdof(k2) if(iord.eq.2) then itdof(i2+3,it)=idof(ied) itdof(i3+3,it)=kdof(ked+3) else if(iord.eq.3) then itdof(2*i3+2,it)=kdof(2*ked+2) itdof(2*i3+3,it)=kdof(2*ked+3) itdof(2*i2+2,it)=idof(2*i2+3) itdof(2*i2+3,it)=kdof(2*k3+2) itdof(10,it)=idof(2*i3+2) endif endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) c implicit real (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 j3=index(3,j) if(itedge(j3,k).gt.0) then kk=itedge(j3,k)/4 ks=itedge(j3,k)-4*kk k=kk j=index(3,ks) go to 5 else ib=-itedge(j3,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 j2=index(2,j) j3=index(3,j) vlist(len)=itnode(j2,k) vlist(len+1)=itnode(j3,k) if(itedge(j3,k).gt.0) then tlist(len-1)=itedge(j3,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(j3,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(j3,k) endif endif tlist(len)=k len=len+1 if(len.gt.500) stop 1309 if(itedge(j2,k).gt.0) then kk=itedge(j2,k)/4 ks=itedge(j2,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(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 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(j2,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.500) stop 1310 k=ibedge(1,ib)/4 ks=ibedge(1,ib)-4*k j=index(2,ks) 35 j2=index(2,j) j3=index(3,j) vlist(ll)=itnode(j2,k) vlist(ll+1)=itnode(j3,k) if(itedge(j3,k).gt.0) then tlist(ll-1)=itedge(j3,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(j3,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(j3,k) blist(ll)=0 endif endif tlist(ll)=k ll=ll+1 if(ll.gt.100) stop 1311 if(itedge(j2,k).gt.0) then kk=itedge(j2,k)/4 ks=itedge(j2,k)-4*kk j=index(2,ks) k=kk tlist(ll)=k go to 35 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 j=index(2,ks) k=kk tlist(ll)=k go to 35 else tlist(ll)=itedge(j2,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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function tqual2(it,itnode,vx,vy,lenb,bump,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) real + vx(*),vy(*),bump(lenb,*),tx(3),ty(3),dx(3),dy(3), 1 b(3),coeff(6),x(3),y(3) save index data index/1,2,3,2,3,1,3,1,2/ c c local error estimate in l2 norm c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) do j=1,3 j2=index(2,j) j3=index(3,j) dx(j)=tx(j2)-tx(j3) dy(j)=ty(j2)-ty(j3) enddo c tqual2=0.0e0 det=abs(det)/2.0e0 c if(iord.eq.1) then do i=1,lenb,3 uxx=bump(i,it) uxy=bump(i+1,it) uyy=bump(i+2,it) do j=1,3 coeff(j)=-(uxx*tx(j)**2+uyy*ty(j)**2 + +uxy*2.0e0*tx(j)*ty(j))/2.0e0 enddo q1=(coeff(1)+coeff(2)+coeff(3))**2 q2=coeff(1)**2+coeff(2)**2+coeff(3)**2 tqual2=tqual2+(q1+q2)*det/180.0e0 enddo else if(iord.eq.2) then do i=1,lenb,4 uxxx=bump(i,it) uxxy=bump(i+1,it) uxyy=bump(i+2,it) uyyy=bump(i+3,it) c do j=1,3 coeff(j)=uxxx*tx(j)**3+uyyy*ty(j)**3 + +(uxxy*tx(j)+uxyy*ty(j))*tx(j)*ty(j)*3.0e0 enddo coeff(4)=uxxx*dx(1)*dx(2)*dx(3)+uyyy*dy(1)*dy(2)*dy(3) + +uxxy*(dx(1)*dx(2)*dy(3)+dx(1)*dy(2)*dx(3) 1 +dy(1)*dx(2)*dx(3))+uxyy*(dy(1)*dy(2)*dx(3) 2 +dy(1)*dx(2)*dy(3)+dx(1)*dy(2)*dy(3)) do j=1,4 coeff(j)=coeff(j)/12.0e0 enddo c q1=(coeff(1)+coeff(2)+coeff(3))**2 q2=coeff(1)**2+coeff(2)**2+coeff(3)**2 q4=coeff(4)**2 tqual2=tqual2+(4.0e0*q2-q1+q4)*det/2520.0e0 enddo else if(iord.eq.3) then ad=1.0e0/900.0e0 a0=1.0e0/3150.0e0 bd=1.0e0/12600.0e0 b0=-1.0e0/25200.0e0 cd=1.0e0/12600.0e0 c0=-1.0e0/25200.0e0 do i=1,lenb,5 uxxxx=bump(i,it) uxxxy=bump(i+1,it) uxxyy=bump(i+2,it) uxyyy=bump(i+3,it) uyyyy=bump(i+4,it) c do j=1,3 coeff(j)=uxxxx*tx(j)**4 + +uxxxy*tx(j)**3 *ty(j) *4.0e0 1 +uxxyy*tx(j)**2 *ty(j)**2*6.0e0 2 +uxyyy*tx(j) *ty(j)**3*4.0e0 3 +uyyyy* ty(j)**4 b(j)=uxxxx*tx(j)**3*dx(j) + +uxxxy*tx(j)**2*(tx(j)*dy(j)+3.0e0*dx(j)*ty(j)) 1 +uxxyy*tx(j)*ty(j)*(dx(j)*ty(j)+tx(j)*dy(j))*3.0e0 2 +uxyyy*ty(j)**2*(ty(j)*dx(j)+3.0e0*tx(j)*dy(j)) 3 +uyyyy*ty(j)**3*dy(j) enddo do j=1,3 coeff(j+3)=(b(index(3,j))-b(index(2,j)))/108.0e0 coeff(j)=coeff(j)/216.0e0 enddo c sa=coeff(1)+coeff(2)+coeff(3) ss=coeff(1)**2+coeff(2)**2+coeff(3)**2 qs=coeff(4)**2+coeff(5)**2+coeff(6)**2 dp=coeff(1)*coeff(4)+coeff(2)*coeff(5)+coeff(3)*coeff(6) c c note coeff(4)+coeff(5)+coeff(6)=0 c qq=a0*sa**2+(ad-a0)*ss+(bd-b0)*qs+(cd-c0)*dp*2.0e0 tqual2=tqual2+det*qq enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function tqual(it,itnode,vx,vy,lenb,bump,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) real + vx(*),vy(*),bump(lenb,*),tx(3),ty(3),dx(3),dy(3), 1 b(3),coeff(6),x(3),y(3),dd(3),dp(3),ds(3) save index data index/1,2,3,2,3,1,3,1,2/ c c local error estimate in h1 norm c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) do j=1,3 j2=index(2,j) j3=index(3,j) dx(j)=tx(j2)-tx(j3) dy(j)=ty(j2)-ty(j3) dd(j)=x(j)**2+y(j)**2 ds(j)=x(j2)**2+y(j2)**2+x(j3)**2+y(j3)**2 dp(j)=x(j2)*x(j3)+y(j2)*y(j3) enddo c tqual=0.0e0 det=abs(det)/2.0e0 if(iord.eq.1) then do i=1,lenb,3 uxx=bump(i,it) uxy=bump(i+1,it) uyy=bump(i+2,it) do j=1,3 coeff(j)=-(uxx*tx(j)**2+uyy*ty(j)**2 + +uxy*2.0e0*tx(j)*ty(j))/2.0e0 enddo se=dp(1)*((coeff(2)-coeff(3))**2+coeff(1)**2) + +dp(2)*((coeff(3)-coeff(1))**2+coeff(2)**2) 1 +dp(3)*((coeff(1)-coeff(2))**2+coeff(3)**2) tqual=tqual-se*det/6.0e0 enddo else if(iord.eq.2) then do i=1,lenb,4 uxxx=bump(i,it) uxxy=bump(i+1,it) uxyy=bump(i+2,it) uyyy=bump(i+3,it) c do j=1,3 coeff(j)=uxxx*tx(j)**3+uyyy*ty(j)**3 + +(uxxy*tx(j)+uxyy*ty(j))*tx(j)*ty(j)*3.0e0 enddo coeff(4)=uxxx*dx(1)*dx(2)*dx(3)+uyyy*dy(1)*dy(2)*dy(3) + +uxxy*(dx(1)*dx(2)*dy(3)+dx(1)*dy(2)*dx(3) 1 +dy(1)*dx(2)*dx(3))+uxyy*(dy(1)*dy(2)*dx(3) 2 +dy(1)*dx(2)*dy(3)+dx(1)*dy(2)*dy(3)) do j=1,4 coeff(j)=coeff(j)/12.0e0 enddo c c s=dd(1)+dd(2)+dd(3) q1=s*(coeff(1)+coeff(2)+coeff(3))**2 q2=(dd(1)*(coeff(2)-coeff(3))**2 + +dd(2)*(coeff(3)-coeff(1))**2 1 +dd(3)*(coeff(1)-coeff(2))**2)*2.0e0 q3=2.0e0*coeff(4)*(coeff(1)*(dd(3)-dd(2))+ + coeff(2)*(dd(1)-dd(3))+coeff(3)*(dd(2)-dd(1))) q4=s*coeff(4)**2/2.0e0 tqual=tqual+det*(q1+q2+q3+q4)/90.0e0 enddo else if(iord.eq.3) then do i=1,lenb,5 uxxxx=bump(i,it) uxxxy=bump(i+1,it) uxxyy=bump(i+2,it) uxyyy=bump(i+3,it) uyyyy=bump(i+4,it) c do j=1,3 coeff(j)=uxxxx*tx(j)**4 + +uxxxy*tx(j)**3 *ty(j) *4.0e0 1 +uxxyy*tx(j)**2 *ty(j)**2*6.0e0 2 +uxyyy*tx(j) *ty(j)**3*4.0e0 3 +uyyyy* ty(j)**4 b(j)=uxxxx*tx(j)**3*dx(j) + +uxxxy*tx(j)**2*(tx(j)*dy(j)+3.0e0*dx(j)*ty(j)) 1 +uxxyy*tx(j)*ty(j)*(dx(j)*ty(j)+tx(j)*dy(j))*3.0e0 2 +uxyyy*ty(j)**2*(ty(j)*dx(j)+3.0e0*tx(j)*dy(j)) 3 +uyyyy*ty(j)**3*dy(j) enddo do j=1,3 coeff(j+3)=(b(index(3,j))-b(index(2,j)))/108.0e0 coeff(j)=coeff(j)/216.0e0 enddo c c matrix elements from element h1 matrix c s1=0.0e0 r1=0.0e0 q1=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) k=j+3 k2=j2+3 k3=j3+3 s1=s1+coeff(j)**2*(408.0e0*ds(j)+192.0e0*dp(j)) + +coeff(j2)*coeff(j3)*(96.0e0*dp(j)-72.0e0*dd(j)) r1=r1+coeff(k)**2*(22.0e0*dd(j)+10.0e0*ds(j)) + +coeff(k2)*coeff(k3)*(4.0e0*dp(j)-20.0e0*ds(j)) q1=q1+coeff(j)*(coeff(k)*(12.0e0*ds(j)+48.0e0*dd(j)) + +coeff(k2)*(60.0e0*dd(j2)-72.0e0*dd(j3) 1 +48.0e0*dp(j2)) 2 +coeff(k3)*(60.0e0*dd(j3)-72.0e0*dd(j2) 3 +48.0e0*dp(j3))) enddo c tqual=tqual+det*(s1+r1+q1)/5040.0e0 enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function tquald(it,itnode,vx,vy,bump,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) real + vx(*),vy(*),bump(*),tx(3),ty(3),dx(3),dy(3), 1 b(3),coeff(6),x(3),y(3),dp(3), 2 dxxx(3),dxxy(3),dxyy(3),dyyy(3),sxx(3),sxy(3),syy(3), 3 dxx(3),dxy(3),dyy(3) save index data index/1,2,3,2,3,1,3,1,2/ c c local error estimate for normalization of bump c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) c do j=1,3 j2=index(2,j) j3=index(3,j) dx(j)=tx(j2)-tx(j3) dy(j)=ty(j2)-ty(j3) enddo c det=abs(det)/2.0e0 if(iord.eq.1) then do j=1,3 j2=index(2,j) j3=index(3,j) dp(j)=x(j2)*x(j3)+y(j2)*y(j3) enddo uxx=bump(1) uxy=bump(2) uyy=bump(3) do j=1,3 coeff(j)=-(uxx*tx(j)**2+uyy*ty(j)**2 + +uxy*2.0e0*tx(j)*ty(j))/2.0e0 enddo se=dp(1)*((coeff(2)-coeff(3))**2+coeff(1)**2) + +dp(2)*((coeff(3)-coeff(1))**2+coeff(2)**2) 1 +dp(3)*((coeff(1)-coeff(2))**2+coeff(3)**2) tquald=-se*det/6.0e0 else if(iord.eq.2) then uxxx=bump(1) uxxy=bump(2) uxyy=bump(3) uyyy=bump(4) c do j=1,3 coeff(j)=uxxx*tx(j)**3+uyyy*ty(j)**3 + +(uxxy*tx(j)+uxyy*ty(j))*tx(j)*ty(j)*3.0e0 enddo coeff(4)=uxxx*dx(1)*dx(2)*dx(3)+uyyy*dy(1)*dy(2)*dy(3) + +uxxy*(dx(1)*dx(2)*dy(3)+dx(1)*dy(2)*dx(3) 1 +dy(1)*dx(2)*dx(3))+uxyy*(dy(1)*dy(2)*dx(3) 2 +dy(1)*dx(2)*dy(3)+dx(1)*dy(2)*dy(3)) do j=1,4 coeff(j)=coeff(j)/12.0e0 enddo c do j=1,3 dxx(j)=0.0e0 dxy(j)=0.0e0 dyy(j)=0.0e0 enddo do j=1,3 j2=index(2,j) j3=index(3,j) c qa=coeff(j)*2.0e0 dxx(j2)=dxx(j2)+(2.0e0*x(j2)-x(j3))*x(j3)*qa dxx(j3)=dxx(j3)-(2.0e0*x(j3)-x(j2))*x(j2)*qa dxx(j)=dxx(j)+2.0e0*coeff(4)*x(j2)*x(j3) c dxy(j2)=dxy(j2)+((2.0e0*x(j2)-x(j3))*y(j3) + +(2.0e0*y(j2)-y(j3))*x(j3))*coeff(j) dxy(j3)=dxy(j3)-((2.0e0*x(j3)-x(j2))*y(j2) + +(2.0e0*y(j3)-y(j2))*x(j2))*coeff(j) dxy(j)=dxy(j)+coeff(4)*(x(j2)*y(j3)+y(j2)*x(j3)) c dyy(j2)=dyy(j2)+(2.0e0*y(j2)-y(j3))*y(j3)*qa dyy(j3)=dyy(j3)-(2.0e0*y(j3)-y(j2))*y(j2)*qa dyy(j)=dyy(j)+2.0e0*coeff(4)*y(j2)*y(j3) enddo s1=(dxx(1)+dxx(2)+dxx(3))**2 + +dxx(1)**2+dxx(2)**2+dxx(3)**2 s2=(dxy(1)+dxy(2)+dxy(3))**2 + +dxy(1)**2+dxy(2)**2+dxy(3)**2 s3=(dyy(1)+dyy(2)+dyy(3))**2 + +dyy(1)**2+dyy(2)**2+dyy(3)**2 c tquald=det*(s1+2.0e0*s2+s3)/12.0e0 else if(iord.eq.3) then uxxxx=bump(1) uxxxy=bump(2) uxxyy=bump(3) uxyyy=bump(4) uyyyy=bump(5) c do j=1,3 sxx(j)=x(j)**2 sxy(j)=x(j)*y(j)*2.0e0 syy(j)=y(j)**2 enddo pxxx=x(1)*x(2)*x(3)*6.0e0 pyyy=y(1)*y(2)*y(3)*6.0e0 sxxy=(x(1)*x(2)*y(3)+x(1)*y(2)*x(3)+y(1)*x(2)*x(3))*2.0e0 sxyy=(y(1)*y(2)*x(3)+y(1)*x(2)*y(3)+x(1)*y(2)*y(3))*2.0e0 c do j=1,3 coeff(j)=uxxxx*tx(j)**4 + +uxxxy*tx(j)**3 *ty(j) *4.0e0 1 +uxxyy*tx(j)**2 *ty(j)**2*6.0e0 2 +uxyyy*tx(j) *ty(j)**3*4.0e0 3 +uyyyy* ty(j)**4 b(j)=uxxxx*tx(j)**3*dx(j) + +uxxxy*tx(j)**2*(tx(j)*dy(j)+3.0e0*dx(j)*ty(j)) 1 +uxxyy*tx(j)*ty(j)*(dx(j)*ty(j)+tx(j)*dy(j))*3.0e0 2 +uxyyy*ty(j)**2*(ty(j)*dx(j)+3.0e0*tx(j)*dy(j)) 3 +uyyyy*ty(j)**3*dy(j) enddo do j=1,3 coeff(j+3)=(b(index(3,j))-b(index(2,j)))/108.0e0 coeff(j)=coeff(j)/216.0e0 enddo c c matrix elements from element h1 matrix c do j=1,3 dxxx(j)=0.0e0 dxxy(j)=0.0e0 dxyy(j)=0.0e0 dyyy(j)=0.0e0 enddo do j=1,3 j2=index(2,j) j3=index(3,j) c c edge functions c qa=coeff(j)*18.0e0*x(j2)*x(j3) dxxx(j)=dxxx(j)+qa*x(j) dxxx(j2)=dxxx(j2)+qa*(x(j)+6.0e0*x(j3)) dxxx(j3)=dxxx(j3)+qa*(x(j)+6.0e0*x(j2)) c qa=coeff(j)*6.0e0*(sxx(j2)*y(j3)+sxy(j2)*x(j3)) qb=coeff(j)*6.0e0*(sxx(j3)*y(j2)+sxy(j3)*x(j2)) dxxy(j)=dxxy(j)-(qa+qb) dxxy(j2)=dxxy(j2)-(qa+qb)+6.0e0*qb dxxy(j3)=dxxy(j3)-(qa+qb)+6.0e0*qa c qa=coeff(j)*6.0e0*(syy(j2)*x(j3)+sxy(j2)*y(j3)) qb=coeff(j)*6.0e0*(syy(j3)*x(j2)+sxy(j3)*y(j2)) dxyy(j)=dxyy(j)-(qa+qb) dxyy(j2)=dxyy(j2)-(qa+qb)+6.0e0*qb dxyy(j3)=dxyy(j3)-(qa+qb)+6.0e0*qa c qa=coeff(j)*18.0e0*y(j2)*y(j3) dyyy(j)=dyyy(j)+qa*y(j) dyyy(j2)=dyyy(j2)+qa*(y(j)+6.0e0*y(j3)) dyyy(j3)=dyyy(j3)+qa*(y(j)+6.0e0*y(j2)) c c interior functions c qa=coeff(j+3)*pxxx qb=coeff(j+3)*18.0e0*sxx(j) dxxx(j)=dxxx(j)+5.0e0*qa dxxx(j2)=dxxx(j2)-qa+qb*x(j3) dxxx(j3)=dxxx(j3)-qa+qb*x(j2) c qa=coeff(j+3)*sxxy qb=coeff(j+3)*6.0e0*sxx(j) qc=coeff(j+3)*6.0e0*sxy(j) dxxy(j)=dxxy(j)+5.0e0*qa dxxy(j2)=dxxy(j2)-qa+qb*y(j3)+qc*x(j3) dxxy(j3)=dxxy(j3)-qa+qb*y(j2)+qc*x(j2) c qa=coeff(j+3)*sxyy qb=coeff(j+3)*6.0e0*syy(j) qc=coeff(j+3)*6.0e0*sxy(j) dxyy(j)=dxyy(j)+5.0e0*qa dxyy(j2)=dxyy(j2)-qa+qb*x(j3)+qc*y(j3) dxyy(j3)=dxyy(j3)-qa+qb*x(j2)+qc*y(j2) c qa=coeff(j+3)*pyyy qb=coeff(j+3)*18.0e0*syy(j) dyyy(j)=dyyy(j)+5.0e0*qa dyyy(j2)=dyyy(j2)-qa+qb*y(j3) dyyy(j3)=dyyy(j3)-qa+qb*y(j2) enddo s1=(dxxx(1)+dxxx(2)+dxxx(3))**2 + +dxxx(1)**2+dxxx(2)**2+dxxx(3)**2 s2=(dxxy(1)+dxxy(2)+dxxy(3))**2 + +dxxy(1)**2+dxxy(2)**2+dxxy(3)**2 s3=(dxyy(1)+dxyy(2)+dxyy(3))**2 + +dxyy(1)**2+dxyy(2)**2+dxyy(3)**2 s4=(dyyy(1)+dyyy(2)+dyyy(3))**2 + +dyyy(1)**2+dyyy(2)**2+dyyy(3)**2 tquald=det*(s1+3.0e0*(s2+s3)+s4)/12.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function tqualn(it,itnode,icurv,vx,vy,xm,ym, + u,nvf,du,idof,iord,jdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3),itnode(5,*),idof(*),icurv(3,*),jdof(*) real + x(3),y(3),vx(*),vy(*),du(nvf,*),u(*),tx(3),ty(3), 1 up(10),xm(*),ym(*),gv(10),c(3),xp(10),yp(10) save index data index/1,2,3,2,3,1,3,1,2/ c c local error estimate for normalization of bump c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) c call cnodec(it,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) ndof=(iord+1)*(iord+2)/2 do i=1,ndof up(i)=u(idof(i)) enddo if(isw.eq.1) then if(iord.eq.2) then do j=1,3 if(icurv(j,it).gt.0) then c(j)=0.0e0 c(index(2,j))=1.0e0/2.0e0 c(index(3,j))=1.0e0/2.0e0 call barinl(c,xp,yp,iord,gv) up(j+3)=0.0e0 do i=1,ndof up(j+3)=up(j+3)+u(idof(i))*gv(i) enddo endif enddo else if(iord.eq.3) then do j=1,3 if(icurv(j,it).gt.0) then c(j)=0.0e0 c(index(2,j))=2.0e0/3.0e0 c(index(3,j))=1.0e0/3.0e0 call barinl(c,xp,yp,iord,gv) jj=2*j+2 up(jj)=0.0e0 do i=1,ndof up(jj)=up(jj)+u(idof(i))*gv(i) enddo c(j)=0.0e0 c(index(2,j))=1.0e0/3.0e0 c(index(3,j))=2.0e0/3.0e0 call barinl(c,xp,yp,iord,gv) jj=2*j+3 up(jj)=0.0e0 do i=1,ndof up(jj)=up(jj)+u(idof(i))*gv(i) enddo endif enddo c(1)=1.0e0/3.0e0 c(2)=1.0e0/3.0e0 c(3)=1.0e0/3.0e0 call barinl(c,xp,yp,iord,gv) up(10)=0.0e0 do i=1,ndof up(10)=up(10)+u(idof(i))*gv(i) enddo endif endif c if(iord.eq.1) then gx=0.0e0 gy=0.0e0 do j=1,3 gx=gx+x(j)*up(j) gy=gy+y(j)*up(j) enddo ss=0.0e0 do j=1,3 j2=jdof(index(2,j)) j3=jdof(index(3,j)) ex=(du(j2,1)+du(j3,1))/2.0e0-gx ey=(du(j2,2)+du(j3,2))/2.0e0-gy ss=ss+ex**2+ey**2 enddo tqualn=abs(det)*ss/6.0e0 else if(iord.eq.2) then gxx=0.0e0 gxy=0.0e0 gyy=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) sj=up(j)*4.0e0 sk=up(j+3)*4.0e0 gxx=gxx+x(j)*x(j)*sj+x(j2)*x(j3)*sk*2.0e0 gxy=gxy+x(j)*y(j)*sj+(x(j2)*y(j3)+y(j2)*x(j3))*sk gyy=gyy+y(j)*y(j)*sj+y(j2)*y(j3)*sk*2.0e0 enddo ss=0.0e0 do j=1,3 j2=jdof(index(2,j)) j3=jdof(index(3,j)) exx=(du(j2,1)+du(j3,1))/2.0e0-gxx exy=(du(j2,2)+du(j3,2))/2.0e0-gxy eyy=(du(j2,3)+du(j3,3))/2.0e0-gyy ss=ss+exx**2+2.0e0*exy**2+eyy**2 enddo tqualn=abs(det)*ss/6.0e0 else if(iord.eq.3) then gxxx=0.0e0 gxxy=0.0e0 gxyy=0.0e0 gyyy=0.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) k=2*j+2 i=2*j+3 sj=up(j)*27.0e0 sk=up(k)*27.0e0 si=up(i)*27.0e0 c gxxx=gxxx+x(j)**3*sj + +x(j2)*x(j3)*(x(j2)*sk+x(j3)*si)*3.0e0 gxxy=gxxy+y(j)*x(j)**2*sj + +(2.0e0*y(j2)*x(j3)+x(j2)*y(j3))*x(j2)*sk 1 +(2.0e0*y(j3)*x(j2)+x(j3)*y(j2))*x(j3)*si gxyy=gxyy+x(j)*y(j)**2*sj + +(2.0e0*x(j2)*y(j3)+y(j2)*x(j3))*y(j2)*sk 1 +(2.0e0*x(j3)*y(j2)+y(j3)*x(j2))*y(j3)*si gyyy=gyyy+y(j)**3*sj + +y(j2)*y(j3)*(y(j2)*sk+y(j3)*si)*3.0e0 enddo sj=up(10)*54.0e0 gxxx=gxxx+x(1)*x(2)*x(3)*sj*3.0e0 gxxy=gxxy+(y(1)*x(2)*x(3)+x(1)*y(2)*x(3)+x(1)*x(2)*y(3))*sj gxyy=gxyy+(x(1)*y(2)*y(3)+y(1)*x(2)*y(3)+y(1)*y(2)*x(3))*sj gyyy=gyyy+y(1)*y(2)*y(3)*sj*3.0e0 c ss=0.0e0 do j=1,3 j2=jdof(index(2,j)) j3=jdof(index(3,j)) exxx=(du(j2,1)+du(j3,1))/2.0e0-gxxx exxy=(du(j2,2)+du(j3,2))/2.0e0-gxxy exyy=(du(j2,3)+du(j3,3))/2.0e0-gxyy eyyy=(du(j2,4)+du(j3,4))/2.0e0-gyyy ss=ss+exxx**2+3.0e0*(exxy**2+exyy**2)+eyyy**2 enddo tqualn=abs(det)*ss/6.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function qtst(i,vx,vy,vtype,vlist0, + elist0,len0,qmin) c implicit real (a-h,o-z) implicit integer (i-n) integer + vtype(*),vlist0(*),elist0(*),vlist(10),elist(10),ie(2) real + vx(*),vy(*) c c check geometry of new elements c qtst=-1.0e0 if(vtype(i).ge.6) go to 30 len=len0 if(len.gt.6) return do j=1,len+2 vlist(j)=vlist0(j) elist(j)=elist0(j) enddo if(len.eq.3) then qtst=1.0e0 return endif ivf1=0 ivf2=0 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(ie(2)-ie(1).lt.2) return if(ie(2)-ie(1).gt.len-2) return ivf1=vlist(ie(1)) ivf2=vlist(ie(2)) endif qtst=1.0e0 c c 10 if(len.gt.4) then jj=2 gs=-1.0e0 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.0e0) 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 enddo qtst=amin1(qtst,gs) if(qtst.le.qmin) return do j=2,jj-1 vlist(j-1)=vlist(j) enddo do j=jj+1,len+1 vlist(j-2)=vlist(j) enddo len=len-1 vlist(len+1)=vlist(1) vlist(len+2)=vlist(2) go to 10 endif if(ivf1.eq.0) then g1=geom(vlist(4),vlist(1),vlist(2),vx,vy) g2=geom(vlist(1),vlist(2),vlist(3),vx,vy) g3=geom(vlist(2),vlist(3),vlist(4),vx,vy) g4=geom(vlist(3),vlist(4),vlist(1),vx,vy) gs=amax1(amin1(g1,g3),amin1(g2,g3)) else if(vlist(1).eq.ivf1.or.vlist(3).eq.ivf1) then g2=geom(vlist(1),vlist(2),vlist(3),vx,vy) g4=geom(vlist(3),vlist(4),vlist(1),vx,vy) gs=amin1(g2,g4) else g1=geom(vlist(4),vlist(1),vlist(2),vx,vy) g3=geom(vlist(2),vlist(3),vlist(4),vx,vy) gs=amin1(g1,g3) endif qtst=amin1(qtst,gs) return c c boundary cases c 30 len=len0 if(len.gt.4) return do j=1,len+1 vlist(j)=vlist0(j) enddo qtst=1.0e0 if(len.gt.3) then jj=3 gs=-1.0e0 do 40 j=3,len qq=geom(i,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0e0) 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 enddo qtst=amin1(qtst,gs) if(qtst.le.qmin) return do j=1,jj-1 vlist(j-1)=vlist(j) enddo do j=jj+1,len+1 vlist(j-2)=vlist(j) enddo len=len-1 endif gg=geom(vlist(2),vlist(3),vlist(4),vx,vy) qtst=amin1(qtst,gs) if(qtst.le.qmin) return c c linked edges c if(vtype(i).ne.8) return ll=len+3 len1=elist0(len+2) ii=vlist0(len+2) len=len1+2-ll if(len.gt.4) then qtst=-1.0e0 return endif do j=ll,len1+1 vlist(j-ll+1)=vlist0(j) enddo if(len.gt.3) then jj=3 gs=-1.0e0 do 50 j=3,len qq=geom(ii,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0e0) go to 50 gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg.gt.gs) then jj=j gs=gg endif 50 enddo qtst=amin1(qtst,gs) if(qtst.le.qmin) return do j=1,jj-1 vlist(j-1)=vlist(j) enddo do j=jj+1,len+1 vlist(j-2)=vlist(j) enddo len=len-1 endif gg=geom(vlist(2),vlist(3),vlist(4),vx,vy) qtst=amin1(qtst,gs) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function vqual(i,emax,vlist,tlist,elist, + len,e,vtype,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + vtype(*),vlist(500),tlist(500),elist(500), 1 corner(9) real + e(*),bias(4),vx(*),vy(*) save bias,corner data bias/0.6e0,0.8e0,0.9e0,1.0e0/ data corner/0,0,1,0,1,0,1,0,1/ c c compute quality function for vertex c vqual=-emax if(corner(vtype(i)).eq.1) return c c test geometry c qmin=0.4e0 qq=qtst(i,vx,vy,vtype,vlist,elist,len,qmin) if(qq.lt.qmin) return c if(vtype(i).ge.6) then qq=0.0e0 do j=2,len qq=amax1(qq,e(tlist(j))) enddo vqual=-qq*bias(2*len-4) if(vtype(i).eq.8) then len1=elist(len+2) do j=len+3,len1 qq=amax1(qq,e(tlist(j))) enddo vqual=amin1(-qq*bias(len1-5),vqual) endif else qq=0.0e0 do j=2,len+1 qq=amax1(qq,e(tlist(j))) enddo vqual=-qq*bias(len-2) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dorder(ip,p,q,ndof,itdof,maxd,gf) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itdof(ndof,*),ip(100) real + gf(maxd,*),gg(100) c c reorder gridfunction arrays with respect to permutation p c ntf=ip(1) ndf=ip(5) ngf=ip(77) c do i=1,ndf q(p(i))=i enddo c c move real arrays c do 20 i=1,ndf 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 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 j=k go to 10 endif do m=1,ngf gf(j,m)=gg(m) enddo 20 continue c c fixup p c do i=1,ndf p(q(i))=i enddo c c fix up dofs in itdof c do i=1,ntf do j=1,ndof itdof(j,i)=q(itdof(j,i)) enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine vorder(ip,p,q,itnode,ibndry,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itnode(5,*),ibndry(6,*),ip(100) real + vx(*),vy(*) c c physically reorder the vertex arrays with respect to c permutation p c ntf=ip(1) nvf=ip(2) nbf=ip(4) 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 r1=vx(i) r2=vy(i) j=i 10 k=p(j) p(j)=-k if(k.ne.i) then vx(j)=vx(k) vy(j)=vy(k) j=k go to 10 endif 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 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine border(ip,p,q,ibndry) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clnup(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,lenb,bump,mark,gf,maxd,ngf,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),mark(*), 1 ibedge(2,*),itdof(ndof,*) real + vx(*),vy(*),bump(lenb,*),gf(maxd,*) 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 do j=1,ndof itdof(j,ntnew)=itdof(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 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 now fix dofs c do i=1,ndf mark(i)=0 enddo do i=1,ntf do j=1,ndof mark(itdof(j,i))=1 enddo enddo ndnew=0 do i=1,ndf if(mark(i).ne.0) then ndnew=ndnew+1 mark(i)=ndnew do k=1,ngf gf(ndnew,k)=gf(i,k) enddo endif enddo ndf=ndnew do i=1,ntf do j=1,ndof itdof(j,i)=mark(itdof(j,i)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clnup2(nvf,ntf,nbf,ndf,newnvf,newntf,newnbf,newndf, + nvi,nbi,ndi,irgn,itnode,itedge,ibndry,ibedge,vx,vy, 1 mark,gf,maxd,ngf,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),mark(*),ibedge(2,*), 1 index(3,3),itdof(ndof,*) real + vx(*),vy(*),gf(maxd,*) 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,ndof itdof(j,ntnew)=itdof(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) 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 c c now fix dof arrays c do i=1,newndf mark(i)=i enddo do i=newndf+1,ndf mark(i)=0 enddo do i=newntf+1,ntf do j=1,ndof mark(itdof(j,i))=itdof(j,i) enddo enddo ndnew=newndf ndinew=newndf do i=newndf+1,ndf if(mark(i).ne.0) then ndnew=ndnew+1 if(i.le.ndi) ndinew=ndinew+1 mark(i)=ndnew do k=1,ngf gf(ndnew,k)=gf(i,k) enddo endif enddo ndf=ndnew ndi=ndinew do i=newntf+1,ntf do j=1,ndof itdof(j,i)=mark(itdof(j,i)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mfe1(nvf,nbf,iord,itmax,vx,vy,xm,ym,iseed,vtype, + itnode,itedge,ibndry,ibedge,lenb,bump) c implicit real (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) real + vx(*),vy(*),xm(*),ym(*),bump(lenb,*),g(6),g1(6) save corner data corner/0,0,1,0,1,0,1,0,1/ c c rezone the region c tol=1.0e-2 eps=0.5e0 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,iord, + lenb,bump,g) if(vtype(i).eq.8) then call geval(ii,vx,vy,vlist,tlist,ks1,len1,iord, + lenb,bump,g1) g(1)=g(1)+g1(1) g(2)=g(2)+cc*g1(2)-ss*g1(3) g(3)=g(3)+ss*g1(2)+cc*g1(3) g(4)=g(4)+cc2*g1(4)-2.0e0*cs2*g1(5)+ss2*g1(6) g(5)=g(5)+cs2*(g1(4)-g1(6))+(cc2-ss2)*g1(5) g(6)=g(6)+ss2*g1(4)+2.0e0*cs2*g1(5)+cc2*g1(6) endif gs=amax1(abs(g(4)),abs(g(5)),abs(g(6))) if(gs.eq.0.0e0) go to 50 do j=1,6 g(j)=g(j)/gs enddo f0=g(1) g0=sqrt(g(2)**2+g(3)**2) c c compute approximate newton direction c det=g(4)*g(6)-g(5)**2 if(det.eq.0.0e0) go to 50 px=-(g(2)*g(6)-g(3)*g(5))/det py=-(g(4)*g(3)-g(5)*g(2))/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=sqrt(px**2+py**2) if(pp*g0.eq.0.0e0) go to 50 d0=(px*g(2)+py*g(3))/(g0*pp) if(d0+tol.ge.0.0e0) go to 50 smin=0.0e0 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=amin1(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=sqrt(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,iord, + lenb,bump,g) if(vtype(i).eq.8) then call geval(ii,vx,vy,vlist,tlist,ks1,len1,iord, + lenb,bump,g1) g(1)=g(1)+g1(1) g(2)=g(2)+cc*g1(2)-ss*g1(3) g(3)=g(3)+ss*g1(2)+cc*g1(3) g(4)=g(4)+cc2*g1(4)-2.0e0*cs2*g1(5)+ss2*g1(6) g(5)=g(5)+cs2*(g1(4)-g1(6))+(cc2-ss2)*g1(5) g(6)=g(6)+ss2*g1(4)+2.0e0*cs2*g1(5)+cc2*g1(6) endif do j=1,6 g(j)=g(j)/gs enddo fk=g(1) gk=sqrt(g(2)*g(2)+g(3)*g(3)) if(fk.lt.eps*f0) go to 50 if(gk.lt.eps*g0) go to 50 r=g(2)*px+g(3)*py dk=r/(gk*pp) if(abs(dk).lt.eps) go to 50 s=g(4)*px**2+2.0e0*g(5)*px*py+g(6)*py**2 if(r*s.lt.0.0e0) 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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine geval(iv1,vx,vy,vlist,tlist,ks,len,iord,lenb,bump,g) c implicit real (a-h,o-z) implicit integer (i-n) integer + tlist(*),vlist(*),iv(3) real + vx(*),vy(*),bump(lenb,*),g1(6),g(6) c c compute direction vector using newton direction c do j=1,6 g(j)=0.0e0 enddo do k=ks,len iv(1)=iv1 iv(2)=vlist(k) iv(3)=vlist(k+1) it=tlist(k) do m=1,lenb,iord+2 call geval2(iv,vx,vy,bump(m,it),g1,iord) do j=1,6 g(j)=g(j)+g1(j) enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine geval2(iv,vx,vy,bump,g,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + iv(3) real + vx(*),vy(*),bump(*),tx(3),ty(3),ss(6),x(3),y(3), 1 cf(6,6),tt(3),tt2(3),tx2(3),ty2(3),txy(3), 2 ff(6,3),g1(6),g2(6),g3(6),g4(6),g(6) c c evaluate error, its gradient and hessian for mesh moving c c compute tangent and normal vectors c call afmap(1,iv,vx,vy,tx,ty,x,y,det) c tt(1)=0.0e0 tt(2)=1.0e0 tt(3)=-1.0e0 c do j=1,3 tx2(j)=tx(j)**2 ty2(j)=ty(j)**2 tt2(j)=tt(j)**2 txy(j)=tx(j)*ty(j) c ff(1,j)=tx2(j)+ty2(j) ff(2,j)=2.0e0*tt(j)*tx(j) ff(3,j)=2.0e0*tt(j)*ty(j) ff(4,j)=2.0e0*tt2(j) ff(5,j)=0.0e0 ff(6,j)=2.0e0*tt2(j) enddo c c this takes into account det c det=tx(2)*ty(3)-tx(3)*ty(2) detx=tt(2)*ty(3)-tt(3)*ty(2) dety=tx(2)*tt(3)-tx(3)*tt(2) if(det.gt.0.0e0) then ss(1)=1.0e0/det ss(2)=-detx/det**2 ss(3)=-dety/det**2 ss(4)=2.0e0*detx**2/det**3 ss(5)=2.0e0*detx*dety/det**3 ss(6)=2.0e0*dety**2/det**3 else ss(1)=-1.0e0/det ss(2)=detx/det**2 ss(3)=dety/det**2 ss(4)=-2.0e0*detx**2/det**3 ss(5)=-2.0e0*detx*dety/det**3 ss(6)=-2.0e0*dety**2/det**3 endif c if(iord.eq.1) then c c evaluate coeffs and their derivatives c uxx=bump(1) uxy=bump(2) uyy=bump(3) do j=1,3 c cf(1,j)=-(uxx*tx2(j)+uyy*ty2(j)+uxy*2.0e0*txy(j))/2.0e0 cf(2,j)=-(uxx*tx(j)+uxy*ty(j))*tt(j) cf(3,j)=-(uyy*ty(j)+uxy*tx(j))*tt(j) cf(4,j)=-uxx*tt2(j) cf(5,j)=-uxy*tt2(j) cf(6,j)=-uyy*tt2(j) enddo else if(iord.eq.2) then c c evaluate coeffs and their derivatives c uxxx=bump(1) uxxy=bump(2) uxyy=bump(3) uyyy=bump(4) c do j=1,3 cf(1,j)=uxxx*tx(j)**3+uyyy*ty(j)**3 + +(uxxy*tx(j)+uxyy*ty(j))*txy(j)*3.0e0 cf(2,j)=(uxxx*tx2(j)+uxyy*ty2(j) + +2.0e0*uxxy*txy(j))*tt(j)*3.0e0 cf(3,j)=(uyyy*ty2(j)+uxxy*tx2(j) + +2.0e0*uxyy*txy(j))*tt(j)*3.0e0 cf(4,j)=(uxxx*tx(j)+uxxy*ty(j))*tt2(j)*6.0e0 cf(5,j)=(uxxy*tx(j)+uxyy*ty(j))*tt2(j)*6.0e0 cf(6,j)=(uxyy*tx(j)+uyyy*ty(j))*tt2(j)*6.0e0 c enddo else if(iord.eq.3) then c c evaluate coeffs and their derivatives c uxxxx=bump(1) uxxxy=bump(2) uxxyy=bump(3) uxyyy=bump(4) uyyyy=bump(5) c do j=1,3 cf(1,j)=uxxxx*tx2(j)**2+uyyyy*ty2(j)**2 + +(uxxxy*tx2(j)+uxyyy*ty2(j))*txy(j)*4.0e0 1 +uxxyy*txy(j)**2*6.0e0 cf(2,j)=(uxxxx*tx(j)*tx2(j) + +uxyyy*ty(j)*ty2(j))*4.0e0*tt(j) 1 +(uxxxy*tx(j)+uxxyy*ty(j))*txy(j)*12.0e0*tt(j) cf(3,j)=(uxxxy*tx(j)*tx2(j) + +uyyyy*ty(j)*ty2(j))*4.0e0*tt(j) 1 +(uxxyy*tx(j)+uxyyy*ty(j))*txy(j)*12.0e0*tt(j) cf(4,j)=(uxxxx*tx2(j)+2.0e0*uxxxy*txy(j) + +uxxyy*ty2(j))*12.0e0*tt2(j) cf(5,j)=(uxxxy*tx2(j)+2.0e0*uxxyy*txy(j) + +uxyyy*ty2(j))*12.0e0*tt2(j) cf(6,j)=(uxxyy*tx2(j)+2.0e0*uxyyy*txy(j) + +uyyyy*ty2(j))*12.0e0*tt2(j) enddo endif do k=1,6 g1(k)=0.0e0 g3(k)=ff(k,1)+ff(k,2)+ff(k,3) enddo call cdp(g3,ss,g4) do j=1,3 call cdp(cf(1,j),cf(1,j),g2) do k=1,6 g1(k)=g1(k)+g2(k) enddo enddo call cdp(g1,g4,g) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine geval1(iv,vx,vy,bump,g,iord) c implicit real (a-h,o-z) implicit integer (i-n) integer + iv(3),index(3,3) real + vx(*),vy(*),bump(*),tx(3),ty(3),dx(3),dy(3),ss(6), 1 b(6,6),cf(6,6),tt(3),dd(3),tt2(3),tx2(3),ty2(3), 2 txy(3),dxc(3),dyc(3),ddc(3),cxy(3),x(3),y(3), 3 ff(6,3),fp(6,3),fs(6,3),g1(6),g2(6),g3(6),g4(6), 4 g5(6),g6(6),g7(6),g8(6),g9(6),g(6) save index data index/1,2,3,2,3,1,3,1,2/ c c evaluate error, its gradient and hessian for mesh moving c call afmap(1,iv,vx,vy,tx,ty,x,y,det) tt(1)=0.0e0 tt(2)=1.0e0 tt(3)=-1.0e0 do j=1,3 j2=index(2,j) j3=index(3,j) tx2(j)=tx(j)**2 ty2(j)=ty(j)**2 tt2(j)=tt(j)**2 txy(j)=tx(j)*ty(j) dx(j)=tx(j2)-tx(j3) dy(j)=ty(j2)-ty(j3) dd(j)=tt(j2)-tt(j3) enddo c c this takes into account det c det=tx(2)*ty(3)-tx(3)*ty(2) detx=tt(2)*ty(3)-tt(3)*ty(2) dety=tx(2)*tt(3)-tx(3)*tt(2) if(det.gt.0.0e0) then ss(1)=1.0e0/det ss(2)=-detx/det**2 ss(3)=-dety/det**2 ss(4)=2.0e0*detx**2/det**3 ss(5)=2.0e0*detx*dety/det**3 ss(6)=2.0e0*dety**2/det**3 else ss(1)=-1.0e0/det ss(2)=detx/det**2 ss(3)=dety/det**2 ss(4)=-2.0e0*detx**2/det**3 ss(5)=-2.0e0*detx*dety/det**3 ss(6)=-2.0e0*dety**2/det**3 endif c if(iord.eq.1) then c c evaluate coeffs and their derivatives c uxx=bump(1) uxy=bump(2) uyy=bump(3) do j=1,3 c j2=index(2,j) j3=index(3,j) fp(1,j)=tx(j2)*tx(j3)+ty(j2)*ty(j3) fp(2,j)=tt(j2)*tx(j3)+tx(j2)*tt(j3) fp(3,j)=tt(j2)*ty(j3)+ty(j2)*tt(j3) fp(4,j)=2.0e0*tt(j2)*tt(j3) fp(5,j)=0.0e0 fp(6,j)=2.0e0*tt(j2)*tt(j3) c cf(1,j)=-(uxx*tx2(j)+uyy*ty2(j)+uxy*2.0e0*txy(j))/2.0e0 cf(2,j)=-(uxx*tx(j)+uxy*ty(j))*tt(j) cf(3,j)=-(uyy*ty(j)+uxy*tx(j))*tt(j) cf(4,j)=-uxx*tt2(j) cf(5,j)=-uxy*tt2(j) cf(6,j)=-uyy*tt2(j) enddo c c gradient norm and its derivatives c do j=1,6 g1(j)=0.0e0 enddo do j=1,3 j2=index(2,j) j3=index(3,j) do k=1,6 g2(k)=cf(k,j2)-cf(k,j3) enddo call cdp(g2,g2,g3) call cdp(cf(1,j),cf(1,j),g4) do k=1,6 g3(k)=g4(k)+g3(k) enddo call cdp(fp(1,j),g3,g2) do k=1,6 g1(k)=g1(k)-g2(k)/12.0e0 enddo enddo call cdp(g1,ss,g) else if(iord.eq.2) then c c evaluate coeffs and their derivatives c uxxx=bump(1) uxxy=bump(2) uxyy=bump(3) uyyy=bump(4) c do j=1,3 c ff(1,j)=tx2(j)+ty2(j) ff(2,j)=2.0e0*tt(j)*tx(j) ff(3,j)=2.0e0*tt(j)*ty(j) ff(4,j)=2.0e0*tt(j)**2 ff(5,j)=0.0e0 ff(6,j)=2.0e0*tt(j)**2 c cf(1,j)=uxxx*tx(j)**3+uyyy*ty(j)**3 + +(uxxy*tx(j)+uxyy*ty(j))*txy(j)*3.0e0 cf(2,j)=(uxxx*tx2(j)+uxyy*ty2(j) + +2.0e0*uxxy*txy(j))*tt(j)*3.0e0 cf(3,j)=(uyyy*ty2(j)+uxxy*tx2(j) + +2.0e0*uxyy*txy(j))*tt(j)*3.0e0 cf(4,j)=(uxxx*tx(j)+uxxy*ty(j))*tt2(j)*6.0e0 cf(5,j)=(uxxy*tx(j)+uxyy*ty(j))*tt2(j)*6.0e0 cf(6,j)=(uxyy*tx(j)+uyyy*ty(j))*tt2(j)*6.0e0 c dxc(j)=dx(j2)*dx(j3) dyc(j)=dy(j2)*dy(j3) ddc(j)=dd(j2)*dd(j3) cxy(j)=dx(j3)*dy(j2)+dx(j2)*dy(j3) enddo cf(1,4)=uxxx*dx(1)*dx(2)*dx(3)+uyyy*dy(1)*dy(2)*dy(3) + +uxxy*(dxc(1)*dy(1)+dxc(2)*dy(2)+dxc(3)*dy(3)) 1 +uxyy*(dyc(1)*dx(1)+dyc(2)*dx(2)+dyc(3)*dx(3)) cf(2,4)=uxxx*(dxc(1)*dd(1)+dxc(2)*dd(2)+dxc(3)*dd(3)) + +uxxy*(cxy(1)*dd(1)+cxy(2)*dd(2)+cxy(3)*dd(3)) 1 +uxyy*(dyc(1)*dd(1)+dyc(2)*dd(2)+dyc(3)*dd(3)) cf(3,4)=uxxy*(dxc(1)*dd(1)+dxc(2)*dd(2)+dxc(3)*dd(3)) + +uxyy*(cxy(1)*dd(1)+cxy(2)*dd(2)+cxy(3)*dd(3)) 1 +uyyy*(dyc(1)*dd(1)+dyc(2)*dd(2)+dyc(3)*dd(3)) c cf(4,4)=uxxx*(dx(1)*ddc(1)+dx(2)*ddc(2)+dx(3)*ddc(3))*2.0e0 + +uxxy*(dy(1)*ddc(1)+dy(2)*ddc(2)+dy(3)*ddc(3))*2.0e0 cf(5,4)=uxxy*(dx(1)*ddc(1)+dx(2)*ddc(2)+dx(3)*ddc(3))*2.0e0 + +uxyy*(dy(1)*ddc(1)+dy(2)*ddc(2)+dy(3)*ddc(3))*2.0e0 cf(6,4)=uxyy*(dx(1)*ddc(1)+dx(2)*ddc(2)+dx(3)*ddc(3))*2.0e0 + +uyyy*(dy(1)*ddc(1)+dy(2)*ddc(2)+dy(3)*ddc(3))*2.0e0 do j=1,4 do k=1,6 cf(k,j)=cf(k,j)/12.0e0 enddo enddo c c gradient norm and its derivatives c call cdp(cf(1,4),cf(1,4),g4) do j=1,6 g1(j)=cf(j,1)+cf(j,2)+cf(j,3) g3(j)=ff(j,1)+ff(j,2)+ff(j,3) enddo call cdp(g1,g1,g2) do j=1,6 g2(j)=g2(j)+g4(j)/2.0e0 enddo call cdp(g2,g3,g1) c do j=1,3 j2=index(2,j) j3=index(3,j) do k=1,6 g2(k)=cf(k,j2)-cf(k,j3) enddo call cdp(g2,g2,g3) call cdp(g3,ff(1,j),g2) do k=1,6 g1(k)=g1(k)+g2(k)*2.0e0 g3(k)=ff(k,j3)-ff(k,j2) enddo call cdp(cf(1,j),cf(1,4),g2) call cdp(g2,g3,g4) do k=1,6 g1(k)=g1(k)+g4(k)*2.0e0 enddo enddo do j=1,6 g1(j)=g1(j)/180.0e0 enddo call cdp(g1,ss,g) else if(iord.eq.3) then c c evaluate coeffs and their derivatives c uxxxx=bump(1) uxxxy=bump(2) uxxyy=bump(3) uxyyy=bump(4) uyyyy=bump(5) c do j=1,3 j2=index(2,j) j3=index(3,j) c ff(1,j)=tx2(j)+ty2(j) ff(2,j)=2.0e0*tt(j)*tx(j) ff(3,j)=2.0e0*tt(j)*ty(j) ff(4,j)=2.0e0*tt(j)**2 ff(5,j)=0.0e0 ff(6,j)=2.0e0*tt(j)**2 c fp(1,j)=tx(j2)*tx(j3)+ty(j2)*ty(j3) fp(2,j)=tt(j2)*tx(j3)+tx(j2)*tt(j3) fp(3,j)=tt(j2)*ty(j3)+ty(j2)*tt(j3) fp(4,j)=2.0e0*tt(j2)*tt(j3) fp(5,j)=0.0e0 fp(6,j)=2.0e0*tt(j2)*tt(j3) c fs(1,j)=tx2(j2)+ty2(j2)+tx2(j3)+ty2(j3) fs(2,j)=2.0e0*(tt(j2)*tx(j2)+tt(j3)*tx(j3)) fs(3,j)=2.0e0*(tt(j2)*ty(j2)+tt(j3)*ty(j3)) fs(4,j)=2.0e0*(tt(j2)**2+tt(j3)**2) fs(5,j)=0.0e0 fs(6,j)=2.0e0*(tt(j2)**2+tt(j3)**2) c cf(1,j)=uxxxx*tx2(j)**2+uyyyy*ty2(j)**2 + +(uxxxy*tx2(j)+uxyyy*ty2(j))*txy(j)*4.0e0 1 +uxxyy*txy(j)**2*6.0e0 cf(2,j)=(uxxxx*tx(j)*tx2(j) + +uxyyy*ty(j)*ty2(j))*4.0e0*tt(j) 1 +(uxxxy*tx(j)+uxxyy*ty(j))*txy(j)*12.0e0*tt(j) cf(3,j)=(uxxxy*tx(j)*tx2(j) + +uyyyy*ty(j)*ty2(j))*4.0e0*tt(j) 1 +(uxxyy*tx(j)+uxyyy*ty(j))*txy(j)*12.0e0*tt(j) cf(4,j)=(uxxxx*tx2(j)+2.0e0*uxxxy*txy(j) + +uxxyy*ty2(j))*12.0e0*tt2(j) cf(5,j)=(uxxxy*tx2(j)+2.0e0*uxxyy*txy(j) + +uxyyy*ty2(j))*12.0e0*tt2(j) cf(6,j)=(uxxyy*tx2(j)+2.0e0*uxyyy*txy(j) + +uyyyy*ty2(j))*12.0e0*tt2(j) c txdx=tx(j)*dx(j) tydy=ty(j)*dy(j) txdy=tx(j)*dy(j) dxty=dx(j)*ty(j) ttdd=tt(j)*dd(j) c b(1,j)=uxxxx*tx2(j)*txdx+uyyyy*ty2(j)*tydy + +uxxxy*tx2(j)*(txdy+3.0e0*dxty) 1 +uxxyy*txy(j)*(txdy+dxty)*3.0e0 2 +uxyyy*ty2(j)*(dxty+3.0e0*txdy) b(2,j)=uxxxx*tx2(j)*(dx(j)*tt(j)*3.0e0+tx(j)*dd(j)) + +uxxxy*tx(j)*(txdy*tt(j) 1 +2.0e0*dxty*tt(j)+txy(j)*dd(j))*3.0e0 2 +uxxyy*ty(j)*(dxty*tt(j) 3 +2.0e0*txdy*tt(j)+txy(j)*dd(j))*3.0e0 4 +uxyyy*ty2(j)*(dy(j)*tt(j)*3.0e0+ty(j)*dd(j)) b(3,j)=uxxxy*tx2(j)*(dx(j)*tt(j)*3.0e0+tx(j)*dd(j)) + +uxxyy*tx(j)*(txdy*tt(j) 1 +2.0e0*dxty*tt(j)+txy(j)*dd(j))*3.0e0 2 +uxyyy*ty(j)*(dxty*tt(j) 3 +2.0e0*txdy*tt(j)+txy(j)*dd(j))*3.0e0 4 +uyyyy*ty2(j)*(dy(j)*tt(j)*3.0e0+ty(j)*dd(j)) b(4,j)=uxxxx*(txdx*tt2(j)+tx2(j)*ttdd)*6.0e0 + +uxxxy*((txdy+dxty)*tt2(j) 1 +2.0e0*ttdd*txy(j))*6.0e0 2 +uxxyy*(tydy*tt2(j)+ty2(j)*ttdd)*6.0e0 b(5,j)=uxxxy*(txdx*tt2(j)+tx2(j)*ttdd)*6.0e0 + +uxxyy*((txdy+dxty)*tt2(j) 1 +2.0e0*ttdd*txy(j))*6.0e0 2 +uxyyy*(tydy*tt2(j)+ty2(j)*ttdd)*6.0e0 b(6,j)=uxxyy*(txdx*tt2(j)+tx2(j)*ttdd)*6.0e0 + +uxyyy*((txdy+dxty)*tt2(j) 1 +2.0e0*ttdd*txy(j))*6.0e0 2 +uyyyy*(tydy*tt2(j)+ty2(j)*ttdd)*6.0e0 enddo do i=1,6 g(i)=0.0e0 do j=1,3 cf(i,j+3)=(b(i,index(3,j))-b(i,index(2,j)))/108.0e0 cf(i,j)=cf(i,j)/216.0e0 enddo enddo c c gradient norm and its derivatives c do j=1,3 j2=index(2,j) j3=index(3,j) k=j+3 k2=j2+3 k3=j3+3 c call cdp(cf(1,j),cf(1,j),g1) call cdp(cf(1,j2),cf(1,j3),g3) do m=1,6 g2(m)=34.0e0*fs(m,j)+16.0e0*fp(m,j) g4(m)=8.0e0*fp(m,j)-6.0e0*fs(m,j) enddo call cdp(g1,g2,g5) call cdp(g3,g4,g6) do m=1,6 g(m)=g(m)+(g5(m)+g6(m))*6.0e0 enddo c call cdp(cf(1,k),cf(1,k),g1) call cdp(cf(1,k2),cf(1,k3),g3) do m=1,6 g2(m)=11.0e0*ff(m,j)+5.0e0*fs(m,j) g4(m)=2.0e0*fp(m,j)-10.0e0*fs(m,j) enddo call cdp(g1,g2,g5) call cdp(g3,g4,g6) do m=1,6 g(m)=g(m)+g5(m)+g6(m) enddo c call cdp(cf(1,j),cf(1,k),g1) call cdp(cf(1,j),cf(1,k2),g3) call cdp(cf(1,j),cf(1,k3),g5) do m=1,6 g2(m)=ff(m,j2)+ff(m,j3)+4.0e0*ff(m,j) g4(m)=5.0e0*ff(m,j2)-6.0e0*ff(m,j3)+4.0e0*fp(m,j2) g6(m)=5.0e0*ff(m,j3)-6.0e0*ff(m,j2)+4.0e0*fp(m,j3) enddo call cdp(g1,g2,g7) call cdp(g3,g4,g8) call cdp(g5,g6,g9) do m=1,6 g(m)=g(m)+(g7(m)+g8(m)+g9(m))*6.0e0 enddo enddo do j=1,5 g1(j)=g(j)/5040.0e0 enddo call cdp(g1,ss,g) c endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cdp(v1,v2,g) c implicit real (a-h,o-z) implicit integer (i-n) c real + v1(6),v2(6),g(6) c g(1)=v1(1)*v2(1) g(2)=v1(2)*v2(1)+v1(1)*v2(2) g(3)=v1(3)*v2(1)+v1(1)*v2(3) g(4)=v1(4)*v2(1)+2.0e0*v1(2)*v2(2)+v1(1)*v2(4) g(5)=v1(5)*v2(1)+v1(3)*v2(2)+v1(2)*v2(3)+v1(1)*v2(5) g(6)=v1(6)*v2(1)+2.0e0*v1(3)*v2(3)+v1(1)*v2(6) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mfe2(nvf,nbf,itmax,vx,vy,xm,ym,iseed,vtype,itnode, + itedge,ibndry,ibedge) c implicit real (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) real + 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.0e-3 s3=sqrt(3.0e0)/2.0e0 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.0e0 qmin2=1.0e0 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.0e0*(px*(x1+x2)+py*(y1+y2)) ad=2.0e0*(px**2+py**2) aa=ad*bn if(aa.ne.0.0e0) then bb=ad*det/aa cc=(bd*det-bn*cd)/aa disc=sqrt(bb**2-cc) if(bb.gt.0.0e0) then r1=-cc/(bb+disc) r2=-(bb+disc) else r1=disc-bb r2=-cc/(bb-disc) endif if(bn.gt.0.0e0) then beta=amax1(r1,r2) else beta=amin1(r1,r2) endif else beta=-(bd*det-bn*cd)/(2.0e0*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.0e0 ymk=(vy(kb)+vy(ka))/2.0e0 xmax=xmk-dyk ymax=ymk+dxk rk=sqrt(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.0e0 yml=(vy(lb)+vy(la))/2.0e0 rl=sqrt(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.0e0 if(a.gt.0.0e0) beta=(b+sqrt(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*amax1(abs(xmin),abs(xmax), 1 abs(ymin),abs(ymax)) 85 zx=abs(xmin-xmax)/(abs(xmin)+abs(xmax)+eps) zy=abs(ymin-ymax)/(abs(ymin)+abs(ymax)+eps) if(amax1(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=sqrt(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.0e0 vy(i)=(ymin+ymax)/2.0e0 if(vtype(i).eq.8) then vx(ii)=(xmin1+xmax1)/2.0e0 vy(ii)=(ymin1+ymax1)/2.0e0 endif qq=1.0e0 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=amin1(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function stpmx(i,vx,vy,vlist,ks,len,px,py) c implicit real (a-h,o-z) implicit integer (i-n) integer + vlist(*) real + vx(*),vy(*) c c compute maximum step c qmin=0.6e0 stpmx=1.0e0 qq=2.0e0*sqrt(3.0e0)/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.0e0 a=2.0e0*(px**2+py**2) c=cn-qq*cd b=bn-qq*bd discr=b**2-a*c if(discr.lt.0.0e0) then aa=bd**2 bb=bn*bd-a*cd/2.0e0 cc=bn**2-a*cn if(bb.gt.0.0e0) then rr=(sqrt(bb**2-aa*cc)+bb)/aa else rr=-cc/(sqrt(bb**2-aa*cc)-bb) endif ss=(bn-rr*bd)/a else discr=sqrt(discr) if(b.lt.0.0e0) then r1=(-b+discr)/a r2=c/(-b+discr) else r1=-(b+discr)/a r2=-c/(b+discr) endif ss=amax1(r1,r2) endif stpmx=amin1(stpmx,ss) enddo c c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ldbal(ip,itnode,itedge,ibedge,ibndry,e,p,q, + ja,a,jl,z,kequv,kequvc,map,hist,time,pstat) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),newtag, 1 ip(100),ibedge(2,*),q(*),p(*),jl(*),oldtag,ja(*), 2 list(1000),kequv(*),kequvc(*),map(*) real + e(*),z(*),a(*),hist(22,*),pstat(10,*),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) log2p=int(alog(float(nproc)+0.1e0)/alog(2.0e0))+1 if(nproc.ge.ntf) then do i=1,ntf itnode(4,i)=i enddo if(nproc.ne.ntf) 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,z,jflag) c call cequvt(ntf,nproc,itnode,itedge,e,p,q,kequvc,kequv) c i1=1 i2=i1+2*nproc-1 i3=i2+2*nproc-1 i4=i3+2*nproc-1 n1=ntf+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 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 if(jend-jbeg.gt.1) then call timer(time,9) call lbev(jbeg,jend,p,q,itedge,z(n1), + hist,ja,a,kequv,kequvc,map,iflag) call timer(time,11) endif do j=jbeg,jend z(j)=z(map(p(j))+n1-1)+2.0e0*float(i-1) enddo enddo c c split, do crude collapse of tiny regions c call spord(ibeg,iend,z,p,q,itnode,e,nproc, + newtag,oldtag,kequv,kequvc) call rtst(p,q,itnode,itedge,nr,list,e,nproc) enddo enddo c c smoothing c call smth0(ntf,itedge,e,nproc,itnode,z(i1),z(i2),z(i3),z(i4)) 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,z) call pstat1(ntf,nproc,pstat,itnode,e,1) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lbev(ibeg,iend,p,q,itedge,z,hist,ja,a, + kequv,kequvc,map,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itedge(3,*),ihist,ja(*),kequv(*), 1 kequvc(*),map(*) real + z(*),hist(22,*),a(*) save ihist data ihist/23/ c c split region into two approximately equal pieces c c pointers (lenz > 7 n) c c parameters c itmax=200 tol=1.0e-2 ispd=1 c c make ja, a c call mtxasm(ibeg,iend,itedge,ja,a,p,q,kequv,kequvc,n,map) if(n.eq.1) then z(1)=1.0e0 return else if(n.eq.2) then z(1)=1.0e0/sqrt(2.0e0) z(2)=-z(1) return endif c iev0=n+1 irhs=iev0+n idx=irhs+n i1=idx+n i2=i1+n i3=i2+n c c initialize c nn=(n/2)*2 ss=1.0e0/sqrt(float(nn)) z(n)=0.0e0 do i=1,nn,2 z(i)=ss z(i+1)=-ss enddo do i=1,n z(iev0+i-1)=0.0e0 enddo c c main iteration loop c ihist=ihist+1 if(ihist.gt.26) ihist=23 call hist1(hist(1,ihist),0,1.0e0) 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) return call sgs(n,ja,a,z(idx),z(irhs),ispd) call tev(n,ja,a,z,z(idx),z(iev0),z(i1),z(i2),z(i3)) enddo iflag=1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ldinit(ip,itnode,ibndry,p,q) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ldbdy(ip,itnode,ibndry,itedge,ibedge,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),itedge(3,*), 1 ibedge(2,*),index(3,3),list(*) 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(86) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,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)=86 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine crdist(ntf,irgn,nproc,itnode,itedge,ibndry,ibedge, + order,mark,idist) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),order(*),idist(*),mark(*), 1 ibedge(2,*),ibndry(6,*) c c compute the graph distance between regions c do i=1,nproc idist(i)=nproc+1 enddo idist(irgn)=0 c do i=1,ntf mark(i)=0 enddo next=1 do i=1,ntf if(itnode(4,i).eq.irgn) then mark(i)=1 order(next)=i next=next+1 endif enddo c do ii=1,ntf if(ii.ge.next) go to 10 i=order(ii) do j=1,3 if(itedge(j,i).gt.0) then k=itedge(j,i)/4 ir=itnode(4,i) kr=itnode(4,k) if(ir.ne.kr) idist(kr)=min0(idist(kr),idist(ir)+1) if(mark(k).eq.0) then mark(k)=1 order(next)=k next=next+1 endif else k=0 iedge=-itedge(j,i) if(ibndry(4,iedge).eq.0) then k=ibedge(1,iedge)/4 if(k.eq.i) k=ibedge(2,iedge)/4 else if(ibndry(4,iedge).lt.0) then kedge=-ibndry(4,iedge) k=ibedge(1,kedge)/4 endif if(k.gt.0) then ir=itnode(4,i) kr=itnode(4,k) if(ir.ne.kr) + idist(kr)=min0(idist(kr),idist(ir)+1) if(mark(k).eq.0) then mark(k)=1 order(next)=k next=next+1 endif endif endif enddo enddo 10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pdepth(nproc,ipath,idepth) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*),idepth(*) c c compute greatest distance to leaf for all elements in tree c do iseg=ipath(2,nproc+2),ipath(1,nproc+2),-1 ison=ipath(2,iseg) if(ison.le.0) then idepth(iseg)=0 else idepth(iseg)=max0(idepth(ison),idepth(ison+1))+1 endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mklst(ibeg,iend,itedge,itnode,p,q,nr,mxlst,list) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkjl(ntf,mnrgn,mxrgn,jl,itnode,p,q) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mtxasm(ibeg,iend,itedge,ja,a,p,q,kequv,kequvc,n,map) c implicit real (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),p(*),q(*),ja(*),kequv(*),map(*),kequvc(*) real + a(*) c c determine n c call blkord(ibeg,iend,p,q,kequv,kequvc) n=0 do i=ibeg,iend if(kequv(p(i)).eq.p(i)) n=n+1 map(p(i))=n enddo c do i=1,n+1 ja(i)=0 enddo c c do i=ibeg,iend it=p(i) do jj=1,3 jt=itedge(jj,it)/4 if(jt.gt.0) then j=q(jt) if(j.ge.i.and.j.le.iend) then kmin=min0(map(it),map(jt)) kmax=max0(map(it),map(jt)) if(kmax.gt.kmin) ja(kmin+1)=ja(kmin+1)+1 endif endif enddo enddo c ja(1)=n+2 do i=2,n+1 ja(i)=ja(i-1)+ja(i) enddo c do i=n+2,ja(n+1)-1 ja(i)=0 enddo c do i=ibeg,iend it=p(i) do jj=1,3 jt=itedge(jj,it)/4 if(jt.gt.0) then j=q(jt) if(j.ge.i.and.j.le.iend) then kmin=min0(map(it),map(jt)) kmax=max0(map(it),map(jt)) if(kmax.le.kmin) go to 10 do kk=ja(kmin),ja(kmin+1)-1 if(ja(kk).eq.0) then ja(kk)=kmax go to 10 else if(ja(kk).eq.kmax) then go to 10 endif enddo endif endif 10 enddo enddo c c squeeze out zero column indices c ii=ja(1) do i=1,n i0=ii ii=ja(i+1) i1=ja(i) do j=i0,ii-1 if(ja(j).ne.0) then ja(i1)=ja(j) i1=i1+1 endif enddo ja(i+1)=i1 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 c c now compute a c do i=1,ja(n+1)-1 a(i)=0.0e0 enddo do i=ibeg,iend it=p(i) do jj=1,3 jt=itedge(jj,it)/4 if(jt.gt.0) then j=q(jt) if(j.ge.i.and.j.le.iend) then kmin=min0(map(it),map(jt)) kmax=max0(map(it),map(jt)) if(kmax.gt.kmin) then a(kmin)=a(kmin)+1.0e0 a(kmax)=a(kmax)+1.0e0 call jacmap(kmin,kmax,ij,ji,ja,0) a(ij)=a(ij)-1.0e0 endif endif endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cequvt(ntf,nproc,itnode,itedge,e,p,q,mark,kequv) c implicit real (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),p(*),q(*),mark(*),kequv(*),itnode(5,*) real + e(*) c c ef=1.0e-2 tf=1.0e-2 imx=100 c ee=0.0e0 do i=1,ntf p(i)=i q(i)=i mark(i)=0 kequv(i)=i ee=ee+e(i) enddo ee=ef*ee/float(nproc) tt=tf*float(ntf)/float(nproc) ii=min0(int(tt+0.5e0),imx) c if(ii.le.1.or.ee.le.0.0e0) then do i=1,ntf mark(i)=kequv(i) itnode(4,i)=1 enddo return endif c c initialize heap c nn=ntf/2 len=ntf do k=nn,1,-1 call updhp(k,len,p,q,e,0) enddo c 10 it=p(1) p(1)=p(len) q(p(1))=1 p(len)=it q(it)=len klen=len len=len-1 call updhp(1,len,p,q,e,0) imark=it mark(it)=imark et=e(it) nt=1 20 if(et.ge.ee) go to 40 if(nt.ge.ii) go to 40 if(klen.le.len) go to 40 kt=p(klen) do j=1,3 jt=itedge(j,kt)/4 if(jt.le.0) go to 30 if(mark(jt).ne.0) go to 30 if(et+e(jt).gt.ee) go to 30 if(nt+1.gt.ii) go to 30 kequv(jt)=kequv(it) kequv(it)=jt nt=nt+1 et=et+e(jt) mark(jt)=imark jj=q(jt) p(jj)=p(len) q(p(jj))=jj p(len)=jt q(jt)=len len=len-1 call updhp(jj,len,p,q,e,0) 30 enddo klen=klen-1 go to 20 40 if(len.gt.1) go to 10 c c make all equivalent elements point at a smallest member c save circular list in mark c do i=1,ntf mark(i)=kequv(i) enddo do i=1,ntf if(kequv(i).gt.0) then num=1 imin=i next=i 70 next=kequv(next) if(next.ne.i) then imin=min0(imin,next) num=num+1 go to 70 endif last=imin do k=1,num next=kequv(last) kequv(last)=-imin last=next enddo endif enddo do i=1,ntf kequv(i)=-kequv(i) p(i)=i q(i)=i itnode(4,i)=1 enddo c c initialize p and q c call blkord(1,ntf,p,q,kequv,mark) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blkord(ibeg,iend,p,q,kequv,kequvc) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),kequv(*),kequvc(*) c c order blocks c i=ibeg 10 ii=p(i) if(kequv(ii).ne.ii) then it=kequv(ii) j=q(it) p(i)=it p(j)=ii q(ii)=j q(it)=i else it=ii endif i=i+1 kt=it 20 kt=kequvc(kt) if(kt.ne.it) then ii=p(i) j=q(kt) p(i)=kt p(j)=ii q(ii)=j q(kt)=i i=i+1 go to 20 endif if(i.lt.iend) go to 10 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tresid(n,ja,a,x,b,dx,ev,bnorm) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + 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.0e0 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/float(n) do i=1,n b(i)=b(i)-ss dx(i)=0.0e0 enddo bnorm=rl2nrm(n,b)/ev return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tev(n,ja,a,ev,dev,ev0,aev,adev,aev0) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*) real + a(*),ev(*),aev(*),dev(*),adev(*), 1 ev0(*),aev0(*),aa(3,3),r(3),q(3,3) c c orthogonalize c ispd=1 sd=0.0e0 do i=1,n sd=sd+dev(i) enddo sd=sd/float(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.0e0 s0=0.0e0 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/float(n) s0=s0/float(n) do i=1,n ev(i)=ev(i)-ss ev0(i)=ev0(i)-s0 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rtst(p,q,itnode,itedge,nr,list,e,nproc) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),itedge(3,*),itnode(5,*),list(*),list0(1000), 1 list1(1000) real + 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.0e0 ecur1=0.0e0 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.0e0 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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine spord(ibeg,iend,z,p,q,itnode,e,nproc, + newtag,oldtag,kequv,kequvc) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),newtag,oldtag,itnode(5,*),kequv(*),kequvc(*) real + z(*),e(*) c c snew=0.0e0 sold=0.0e0 nnew=0 nold=0 c c n=iend-ibeg+1 nn=n/2 do i=nn,1,-1 call mkheap(i,n,z(ibeg),p(ibeg)) enddo do i=iend,ibeg+1,-1 i1=p(i) p(i)=p(ibeg) p(ibeg)=i1 z1=z(i) z(i)=z(ibeg) z(ibeg)=z1 call mkheap(1,i-ibeg,z(ibeg),p(ibeg)) enddo c c do i=ibeg,iend q(p(i))=i enddo c group blocks c call blkord(ibeg,iend,p,q,kequv,kequvc) 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=float(knew) told=float(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 iptr=iptr-1 jptr=jptr+1 i=p(iptr) j=p(jptr) if(kequv(i).ne.kequv(j)) return c kk=kequv(i) kbeg=q(kk) kend=kbeg 30 if(kequv(p(kend+1)).eq.kk) then kend=kend+1 go to 30 endif c c forced move to new side c if(kbeg.lt.nbeg.and.kend.le.nend) then do i=jptr,kend itnode(4,p(i))=newtag enddo c c forced move to old side c else if(kbeg.ge.nbeg.and.kend.gt.nend) then do i=kbeg,iptr itnode(4,p(i))=oldtag enddo c c a split is forced c else if(kbeg.lt.nbeg.and.kend.gt.nend) then kequvc(p(kend))=p(jptr) kequvc(p(iptr))=kk do i=jptr,kend kequv(p(i))=p(jptr) enddo else c c shift the samllest number of elements c if(iptr-kbeg.lt.kend-jptr) then do i=kbeg,iptr itnode(4,p(i))=oldtag enddo else do i=jptr,kend itnode(4,p(i))=newtag enddo endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function nchild(k,n) c implicit real (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=alog(2.0e0) q=alog(float(n)+0.1e0)/a nl=int(q) q=alog(float(k)+0.1e0)/a kl=int(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine smth0(ntf,itedge,e,nproc,itnode,wt,iwt,ichild,wtrgt) c implicit real (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),itnode(5,*),index(3,3),iwt(*), 1 ichild(*),tag(3),nnum(3),ntag(3,3),jnum(3) real + e(*),wt(*),wtrgt(*) save index data index/1,2,3,2,3,1,3,1,2/ c itmax=50 c c initialize wt,iwt c do i=1,2*nproc-1 wt(i)=0.0e0 iwt(i)=0 ichild(i)=nchild(i,nproc) enddo wtot=0.0e0 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*float(ichild(i))/float(nproc) enddo c c the main loop c do itnum=1,itmax ichng=0 kchng=0 jchng=0 do i=1,ntf itag=itnode(4,i) if(iwt(itag).le.ichild(itag)) go to 50 c c parameters for this triangle and its neighbors c inum=0 ibdy=0 kk=0 ii=0 do j=1,3 nnum(j)=0 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 do mm=1,3 m=itedge(mm,k)/4 if(m.le.0) then ntag(mm,j)=0 else ntag(mm,j)=itnode(4,m) if(ntag(mm,j).eq.itag) + nnum(j)=nnum(j)+1 endif enddo inum=inum+1 ii=j else kk=j endif endif enddo c c exclude obvious cases c if(ibdy+inum.ge.3) go to 50 if(inum.ge.2) go to 20 if(inum.eq.0) go to 10 c c zero or one edge shared with region itag c mm=itedge(ii,i)/4 k2=index(2,ii) k3=index(3,ii) if(nnum(ii).eq.3) go to 10 if(tag(k2).eq.tag(k2)) go to 10 n2=0 n3=0 do j=1,3 if(ntag(j,ii).eq.tag(k2)) n2=n2+1 if(ntag(j,ii).eq.tag(k3)) n3=n3+1 enddo if(n2.eq.1.and.n3.eq.1) then if(tag(k2).eq.0) then ktag=tag(k3) else if(tag(k3).eq.0) then ktag=tag(k2) else if(wt(tag(k2)).lt.wt(tag(k3))) then ktag=tag(k2) else ktag=tag(k3) endif go to 40 else if(nnum(ii).eq.2) then if(n2.eq.1) then ktag=tag(k2) else if(n3.eq.1) then ktag=tag(k3) endif if(ktag.gt.0) go to 40 endif 10 jtag=0 do j=1,3 if(tag(j).ne.itag.and.tag(j).ne.0) then c c see if relative load balance is improved c gold=amax1(abs(wt(itag)-wtrgt(itag)), + abs(wt(tag(j))-wtrgt(tag(j)))) gnew=amax1(abs(wt(itag)-e(i)-wtrgt(itag)), + abs(wt(tag(j))+e(i)-wtrgt(tag(j)))) if(jtag.eq.0) then gg=gold-gnew jtag=tag(j) else if(gold-gnew.gt.gg) then gg=gold-gnew jtag=tag(j) endif endif enddo if(jtag.eq.0) go to 50 c c accept all cases that reduce interface verts c accept other cases that improve load balance c if(inum.eq.1) then if(tag(k2).ne.tag(k3)) then if(gg.le.0.0e0) go to 50 endif endif ichng=ichng+1 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 go to 50 20 if(ibdy.gt.0) go to 50 ktag=tag(kk) k2=index(2,kk) k3=index(3,kk) i2=itedge(k2,i)/4 i3=itedge(k3,i)/4 jnum(k2)=0 jnum(k3)=0 do j=1,3 if(ntag(j,k2).eq.ktag) jnum(k2)=jnum(k2)+1 if(ntag(j,k3).eq.ktag) jnum(k3)=jnum(k3)+1 enddo c c test for three element cap or two element quad c isw=0 if(jnum(k2).eq.1.and.nnum(k2).eq.2) isw=isw+1 if(jnum(k3).eq.1.and.nnum(k3).eq.2) isw=isw+1 if(isw.eq.2) then go to 30 else if(nnum(k2).eq.3) then mm=i3 if(isw.eq.1) go to 40 else if(nnum(k3).eq.3) then mm=i2 if(isw.eq.1) go to 40 else if(nnum(k2).eq.1) then mm=i2 if(nnum(k3).eq.1) go to 50 if(jnum(k2).eq.2) then if(isw.eq.1) go to 30 go to 40 endif else if(nnum(k3).eq.1) then mm=i3 if(jnum(k3).eq.2) then if(isw.eq.1) go to 30 go to 40 endif else if(isw.eq.1) then mm=i2 if(jnum(k2).eq.1) go to 40 mm=i3 if(jnum(k3).eq.1) go to 40 endif go to 50 c c always remove caps because they reduce interface verts c 30 ee=e(i)+e(i2)+e(i3) kchng=kchng+1 iwt(itag)=iwt(itag)-3 iwt(ktag)=iwt(ktag)+3 wt(itag)=wt(itag)-ee wt(ktag)=wt(ktag)+ee itnode(4,i)=ktag itnode(4,i2)=ktag itnode(4,i3)=ktag go to 50 c c switch quads that improve load balance c 40 ee=e(i)+e(mm) gold=amax1(abs(wt(itag)-wtrgt(itag)), + abs(wt(ktag)-wtrgt(ktag))) gnew=amax1(abs(wt(itag)-ee-wtrgt(itag)), + abs(wt(ktag)+ee-wtrgt(ktag))) if(gnew.ge.gold) go to 50 jchng=jchng+1 iwt(itag)=iwt(itag)-2 iwt(ktag)=iwt(ktag)+2 wt(itag)=wt(itag)-ee wt(ktag)=wt(ktag)+ee itnode(4,i)=ktag itnode(4,mm)=ktag 50 enddo c* write(6,*) 'iter:',itnum,ichng,kchng,jchng if(ichng+kchng+jchng.eq.0) return enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cutr(ip,itnode,ibndry,vx,vy,e,p,q,befor,after, + itedge,ibedge,maxb,gf,icutsw,ndof,itdof) c implicit real (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(*),itdof(ndof,*), 2 idof(10) real + vx(*),vy(*),gf(maxb,*),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) ndf=ip(5) irgn=ip(50) ibase=ip(70) iord=ip(26) ndof=(iord+1)*(iord+2)/2 mbase=max0(nbf,ibase) maxd=ip(89) 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 do j=1,ndof ii=itdof(j,newntf) itdof(j,newntf)=itdof(j,i) itdof(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,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) c c mark degress of freedom c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,p,iflag) do i=1,ndf p(i)=i q(i)=0 enddo do i=1,newntf do j=1,ndof q(itdof(j,i))=2 enddo enddo do i=1,nbb call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 q(idof(j))=3 enddo enddo do i=newnbf+1,nbi call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 if(q(idof(j)).eq.0) q(idof(j))=1 enddo enddo ndi=0 do k=3,1,-1 do ii=1,ndf i=p(ii) if(q(i).eq.k) then ndi=ndi+1 p(ii)=p(ndi) p(ndi)=i endif enddo if(k.eq.3) ndd=ndi if(k.eq.2) newndf=ndi enddo c do i=1,ndf q(p(i))=i enddo nn=0 do i=1,nbb call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 ii=q(idof(j)) if(ii.gt.nn) then nn=nn+1 p(ii)=p(nn) p(nn)=idof(j) q(p(nn))=nn q(p(ii))=ii endif enddo enddo nn=newndf do i=newnbf+1,nbi call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 ii=q(idof(j)) if(ii.gt.nn) then nn=nn+1 p(ii)=p(nn) p(nn)=idof(j) q(p(nn))=nn q(p(ii))=ii endif enddo enddo c call dorder(ip,p,q,ndof,itdof,maxd,gf) c ip(27)=newntf ip(28)=newnvf ip(29)=newnbf ip(30)=newndf ip(31)=nvv ip(32)=nbb ip(33)=ndd ip(34)=nvi ip(35)=nbi ip(36)=ndi 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 ip(5)=newndf ip(27)=ntf ip(28)=nvf ip(29)=nbf ip(30)=ndf c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cutr2(ip,itnode,ibndry,vx,vy,p,q,befor,after, + itedge,ibedge,maxd,gf,ndof,itdof) c implicit real (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(*),itdof(ndof,*), 2 idof(10) real + vx(*),vy(*),gf(maxd,*) save index data index/1,2,3,2,3,1,3,1,2/ c ntf=ip(1) nvf=ip(2) nbf=ip(4) ndf=ip(5) iord=ip(26) newntf=ip(27) newnvf=ip(28) newnbf=ip(29) newndf=ip(30) nvi=ip(34) nbi=ip(35) ndi=ip(36) 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) c c c mark degree of freedom c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,p,iflag) do i=1,ndf p(i)=i q(i)=0 enddo do i=newnbf+1,nbi call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 q(idof(j))=1 enddo enddo ndi=newndf do ii=newndf+1,ndf i=p(ii) if(q(i).eq.1) then ndi=ndi+1 p(ii)=p(ndi) p(ndi)=i endif enddo c do i=1,ndf q(p(i))=i enddo nn=newndf do i=newnbf+1,nbi call l2gmpe(i,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 ii=q(idof(j)) if(ii.gt.nn) then nn=nn+1 p(ii)=p(nn) p(nn)=idof(j) q(p(nn))=nn q(p(ii))=ii endif enddo enddo if(nn.ne.ndi) stop 7631 c call dorder(ip,p,q,ndof,itdof,maxd,gf) c ip(34)=nvi ip(35)=nbi ip(36)=ndi c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkpth(ip,irgn,ipath,itnode,ibndry,ibedge,ndof,itdof, + itree,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*),ibndry(6,*),ip(100),itree(4,*),list(*), 1 ibedge(2,*),itdof(ndof,*),idof(10),itnode(5,*) c c pointer section 1 -- nproc+2 (nproc+2 is global) c c ipath(1,*) first interface tree entry for irgn c ipath(2,*) last interface tree entry for irgn c ipath(3,*) first interface vertex for irgn c mxlab/0 for nproc+2 c ipath(4,*) last interface vertex for irgn c c tree section c root root/leaf internal leaf c ipath(1,*) -l/n -l/n 0/n 0/n c ipath(2,*) son -e son -e c ipath(3,*) e1/v1/d1 v1/d1 e1/v1/d1 v1/d1 c ipath(4,*) e2/v2/d2 v2/d2 e2/v2/d2 v2/d2 c ipath(5,*) d3 d3 d3 d3 c ipath(6,*) d4 d4 d4 d4 c c e = edge k, v = vertex, d = dof c nproc=ip(49) nbb=ip(32) ndd=ip(33) ntf=ip(1) nvf=ip(2) nbf=ip(4) iord=ip(26) ibase=ip(70) maxpth=ip(81) m1=2*nbf+1 m2=2*nbf+m1 c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,list,iflag) do 5 i=1,nbf if(ibndry(4,i).ne.0) go to 5 it=ibedge(1,i)/4 jt=ibedge(2,i)/4 ir=itnode(4,it) jr=itnode(4,jt) if(ir.eq.irgn) go to 5 if(jr.ne.irgn.and.jr.gt.ir) go to 5 ii=ibedge(1,i) ibedge(1,i)=ibedge(2,i) ibedge(2,i)=ii 5 enddo c 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 ipath(5,i)=0 ipath(6,i)=0 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)=-lab ipath(2,nseg)=0 ipath(3,nseg)=k 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(4,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(1,iseg)) enddo istop=nseg do jseg=istart,istop c c make tree c call etree(jseg,ibase,ipath,ibndry,itree,len,list, + list(m1),list(m2)) c c set up tree in ipath c iseg=jseg-1 ipath(2,jseg)=2*len-1 50 iseg=iseg+1 if(iseg.gt.nseg) go to 60 if(ipath(3,iseg).ne.ipath(4,iseg)) then if(nseg+2.gt.maxpth) then ip(25)=72 return endif it=ipath(2,iseg) do i=1,2 ison=itree(2+i,it) ipath(1,nseg+i)=0 ipath(2,nseg+i)=ison ipath(3,nseg+i)=itree(1,ison) ipath(4,nseg+i)=itree(2,ison) enddo c ipath(2,iseg)=nseg+1 if(iseg.eq.jseg) iseg=nseg nseg=nseg+2 else ib=ipath(3,iseg) ipath(2,iseg)=-ib call l2gmpe(ib,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 ipath(2+j,iseg)=idof(j) enddo if(iseg.eq.jseg) go to 60 endif go to 50 60 enddo c if(irgn.gt.0) then ipath(1,irgn)=istart ipath(2,irgn)=nseg ipath(3,irgn)=1 ipath(4,irgn)=ndd c ipath(1,nproc+2)=istart ipath(2,nproc+2)=nseg ipath(3,nproc+2)=mxlab ipath(4,nproc+2)=ndd else ipath(1,1)=istart ipath(2,1)=nseg ipath(3,1)=mxlab ipath(4,1)=ndd ipath(1,2)=istart ipath(2,2)=nseg ipath(3,2)=mxlab ipath(4,2)=ndd endif ip(71)=ndd ip(72)=nseg c c this sets up dof-parent relations c do i=nseg,istart,-1 ison=ipath(2,i) if(ison.gt.0) then ipath(3,i)=ipath(3,ison) ipath(iord+3,i)=ipath(iord+3,ison+1) if(iord.eq.2) then ipath(4,i)=ipath(5,ison) else if(iord.eq.3) then ipath(4,i)=ipath(5,ison) ipath(5,i)=ipath(4,ison+1) endif endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine updhpi(i,len,p,q,list,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + p(*),q(*),list(*) 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(list(p(k)).gt.list(p(kfath))) go to 60 c c push c 10 kson=2*k if(kson.gt.len) return if(kson.lt.len) then if(list(p(kson+1)).gt.list(p(kson))) kson=kson+1 endif if(list(p(k)).ge.list(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(list(p(kfath)).gt.list(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine etree(jseg,ibase,ipath,ibndry,itree,len,list,p,q) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*),ibndry(6,*),itree(4,*),list(*),p(*),q(*) c c itree(1,*) = first edge c itree(2,*) = second edge c itree(3,*) = first son c itree(4,*) = second son c len=0 do i=ipath(3,jseg),ipath(4,jseg) it=iabs(ibndry(5,i))/ibase+1 c c add a leaf c len=len+1 list(len)=it itree(1,len)=i itree(2,len)=i itree(3,len)=0 itree(4,len)=0 enddo c c initialize internal nodes (root will end up at 2*len-1) c last=2*len-1 do i=len+1,last list(i)=0 do j=1,4 itree(j,i)=0 enddo enddo c c initialize heap c do i=1,last p(i)=i q(i)=i enddo nn=len/2 do k=nn,1,-1 call updhpi(k,last,p,q,list,0) enddo c next=len+1 do ii=1,len-1 c c the two largest indices should be a refined pair c i=p(1) p(1)=p(last) p(last)=i q(p(last))=last q(p(1))=1 last=last-1 call updhpi(1,last,p,q,list,0) j=p(1) p(1)=p(last) p(last)=j q(p(last))=last q(p(1))=1 last=last-1 call updhpi(1,last,p,q,list,0) c c create the father node c if(itree(1,i).lt.itree(1,j)) then itree(1,next)=itree(1,i) itree(2,next)=itree(2,j) itree(3,next)=i itree(4,next)=j if(itree(2,i)+1.ne.itree(1,j)) stop 4411 else itree(1,next)=itree(1,j) itree(2,next)=itree(2,i) itree(3,next)=j itree(4,next)=i if(itree(1,i).ne.itree(2,j)+1) stop 4422 endif list(next)=list(i)/2 if(list(i)/2.ne.list(j)/2) stop 4433 k=q(next) call updhpi(k,last,p,q,list,1) next=next+1 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine spth(nproc,irgn,ipath,ipath0) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*),ipath0(6,*) c c order irgn last in ipath c do i=1,ipath(2,nproc+2) do j=1,6 ipath0(j,i)=ipath(j,i) enddo enddo c c ipath(2,nproc+2)=ipath(1,nproc+2)-1 do 20 i=1,nproc if(i.eq.irgn) go to 20 ipath(1,i)=ipath(2,nproc+2)+1 jb0=ipath(1,i)-ipath0(1,i) ipath(2,i)=ipath0(2,i)+jb0 ipath(2,nproc+2)=ipath(2,i) c do j=ipath(1,i),ipath(2,i) do k=1,6 ipath(k,j)=ipath0(k,j-jb0) enddo if(ipath(2,j).gt.0) ipath(2,j)=ipath(2,j)+jb0 enddo 20 enddo c ipath(1,irgn)=ipath(2,nproc+2)+1 jb0=ipath(1,irgn)-ipath0(1,irgn) ipath(2,irgn)=ipath0(2,irgn)+jb0 ipath(2,nproc+2)=ipath(2,irgn) c do j=ipath(1,irgn),ipath(2,irgn) do k=1,6 ipath(k,j)=ipath0(k,j-jb0) enddo if(ipath(2,j).gt.0) ipath(2,j)=ipath(2,j)+jb0 enddo c c fixup neighbors if present c do i=1,nproc do j=ipath0(1,i),ipath0(2,i) ipath0(3,j)=i enddo enddo do i=1,nproc do j=ipath(1,i),ipath(2,i) if(ipath(1,j).gt.0) then k=ipath0(3,ipath(1,j)) ipath(1,j)=ipath(1,j)+ipath(1,k)-ipath0(1,k) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine matchp(nproc,ipath,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*),list(*) c c sort and match the tree roots c mxlab=ipath(3,nproc+2) if(mxlab.le.0) return do i=1,mxlab list(i)=0 enddo do 10 iseg=ipath(1,nproc+2),ipath(2,nproc+2) if(ipath(1,iseg).ge.0) go to 10 lab=iabs(ipath(1,iseg)) if(list(lab).eq.0) then list(lab)=iseg else jseg=list(lab) ipath(1,iseg)=jseg ipath(1,jseg)=iseg endif 10 enddo c c now match children c do 20 iseg=ipath(1,nproc+2),ipath(2,nproc+2) ison=ipath(2,iseg) if(ison.le.0) go to 20 if(ipath(1,ison).gt.0) go to 20 jseg=ipath(1,iseg) if(jseg.le.0) go to 20 if(ipath(1,jseg).ne.iseg) stop 2370 json=ipath(2,jseg) if(json.le.0) go to 20 ipath(1,ison)=json+1 ipath(1,ison+1)=json ipath(1,json)=ison+1 ipath(1,json+1)=ison 20 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkpthi(ip,ipath,itnode,ibndry,ibedge,ndof,itdof, + itree,list,iptsw) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*),ibndry(6,*),ip(100),itree(4,*),list(*), 1 itnode(5,*),itdof(ndof,*),idof(10),ibedge(2,*), 2 index(3,3) save index data index/1,2,3,2,3,1,3,1,2/ c nproc=ip(49) irgn=ip(50) newnvf=ip(28) newnbf=ip(29) newndf=ip(30) ntf=ip(1) nvf=ip(2) nbf=ip(4) iord=ip(26) nvi=ip(34) nbi=ip(35) ndi=ip(36) ibase=ip(70) maxpth=ip(81) mxlab=ipath(3,nproc+2) nvv=ipath(4,nproc+2) nbf=ip(4) m1=2*nbf+1 m2=2*nbf+m1 c* if(iptsw.eq.1) then call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,list,iflag) do 5 i=1,nbf if(ibndry(4,i).ne.0) go to 5 it=ibedge(1,i)/4 jt=ibedge(2,i)/4 ir=itnode(4,it) jr=itnode(4,jt) if(ir.eq.irgn) go to 5 if(jr.ne.irgn.and.jr.gt.ir) go to 5 ii=ibedge(1,i) ibedge(1,i)=ibedge(2,i) ibedge(2,i)=ii 5 enddo c* endif c do i=newnbf+1,nbi it=ibedge(1,i)/4 ied=ibedge(1,i)-4*it ibndry(1,i)=itnode(index(2,ied),it) ibndry(2,i)=itnode(index(3,ied),it) enddo c istart=ipath(2,nproc+2)+1 nseg=istart-1 k=newnbf+1 30 if(k.gt.nbi) go to 40 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)=-lab ipath(2,nseg)=0 ipath(3,nseg)=k 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(4,nseg)=i-1 k=i go to 30 endif enddo c c now make tree c 40 istop=nseg do jseg=istart,istop c c make tree c call etree(jseg,ibase,ipath,ibndry,itree,len,list, + list(m1),list(m2)) c c set up tree in ipath c iseg=jseg-1 ipath(2,jseg)=2*len-1 50 iseg=iseg+1 if(iseg.gt.nseg) go to 60 if(ipath(3,iseg).ne.ipath(4,iseg)) then if(nseg+2.gt.maxpth) then ip(25)=72 return endif it=ipath(2,iseg) do i=1,2 ison=itree(2+i,it) ipath(1,nseg+i)=0 ipath(2,nseg+i)=ison ipath(3,nseg+i)=itree(1,ison) ipath(4,nseg+i)=itree(2,ison) ipath(5,nseg+i)=0 ipath(6,nseg+i)=0 enddo c ipath(2,iseg)=nseg+1 if(iseg.eq.jseg) iseg=nseg nseg=nseg+2 else ib=ipath(3,iseg) ipath(2,iseg)=-ib if(iptsw.eq.1) then call l2gmpe(ib,ibedge,iord,idof,ndof,itdof) do j=1,iord+1 ipath(2+j,iseg)=idof(j)-newndf+nvv enddo else ipath(3,iseg)=ibndry(1,ib)-newnvf+nvv ipath(4,iseg)=ibndry(2,ib)-newnvf+nvv endif if(iseg.eq.jseg) go to 60 endif go to 50 60 enddo c ipath(1,nproc+1)=istart ipath(2,nproc+1)=nseg ipath(3,nproc+1)=nvv+1 if(iptsw.eq.1) then ipath(4,nproc+1)=nvv+(ndi-newndf) do i=istart,nseg do j=1,iord+1 if(ipath(j+2,i).le.nvv) ipath(j+2,i)=0 enddo enddo else ipath(4,nproc+1)=nvv+(nvi-newnvf) do i=istart,nseg if(ipath(2,i).gt.0) then ipath(3,i)=ibndry(1,ipath(3,i))+nvv-newnvf ipath(4,i)=ibndry(2,ipath(4,i))+nvv-newnvf endif if(ipath(3,i).le.nvv) ipath(3,i)=0 if(ipath(4,i).le.nvv) ipath(4,i)=0 enddo endif 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(1,jrgn),ipath(2,jrgn) if(ipath(1,iseg).lt.0) then lab=-ipath(1,iseg) list(lab)=iseg endif enddo enddo do iseg=ipath(1,nproc+1),ipath(2,nproc+1) if(ipath(1,iseg).lt.0) then lab=-ipath(1,iseg) ipath(1,iseg)=list(lab) endif enddo do 70 iseg=ipath(1,nproc+1),ipath(2,nproc+1) ison=ipath(2,iseg) if(ison.le.0) go to 70 if(ipath(1,ison).gt.0) go to 70 jseg=ipath(1,iseg) if(jseg.le.0) go to 70 json=ipath(2,jseg) if(json.gt.0) then ipath(1,ison)=json+1 ipath(1,ison+1)=json endif 70 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cequvd(ndf,nbf,ibndry,ibedge,iequv,iord,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),iequv(*),itdof(ndof,*),ibedge(2,*), 1 idof(10),jdof(10) c c compute equivalent degress of freedom c do i=1,ndf iequv(i)=i enddo c c set up equivalence classes for dofs c do 60 i=1,nbf if(ibndry(4,i).ge.0) go to 60 if(ibndry(5,i).eq.0) go to 60 if(iabs(ibndry(5,i)).eq.5) go to 60 j=-ibndry(4,i) if(j.lt.i) go to 60 c c mark equivalent dofs c call l2gmpe(i,ibedge,iord,idof,ndof,itdof) call l2gmpe(j,ibedge,iord,jdof,ndof,itdof) do 50 mm=1,iord+1 iv=idof(mm) jv=jdof(iord+2-mm) 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 do i=1,ndf 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,ndf iequv(i)=-iequv(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cequv2(irgn,nproc,iord,newndf,ndi,ipath,jequv,mark) c implicit real (a-h,o-z) implicit integer (i-n) integer + jequv(*),ipath(6,*),mark(*) c c compute jequv array c nn=ipath(4,nproc+1) nvv=ipath(4,irgn)-ipath(3,irgn)+1 c do i=1,nn mark(i)=0 jequv(i)=i enddo c c fine part of interface c do 60 iseg=ipath(1,nproc+2),ipath(2,nproc+2) if(ipath(2,iseg).ge.0) go to 60 jseg=ipath(1,iseg) if(jseg.le.0) stop 5890 if(ipath(1,jseg).ne.iseg) stop 5891 if(ipath(2,jseg).ge.0) stop 5892 do 50 mm=1,iord+1 iv=ipath(mm+2,iseg) jv=ipath(iord+4-mm,jseg) it=iv 40 it=jequv(it) if(it.eq.jv) go to 50 if(it.ne.iv) go to 40 it=jequv(iv) jequv(iv)=jequv(jv) jequv(jv)=it 50 enddo 60 enddo c c coarse part of interface c do 90 iseg=ipath(1,nproc+1),ipath(2,nproc+1) if(ipath(2,iseg).ge.0) go to 90 jseg=ipath(1,iseg) if(jseg.le.0) go to 90 do 80 mm=1,iord+1 iv=ipath(mm+2,iseg) if(iv.le.0) go to 80 jv=ipath(iord+4-mm,jseg) it=iv 70 it=jequv(it) if(it.eq.jv) go to 80 if(it.ne.iv) go to 70 it=jequv(iv) jequv(iv)=jequv(jv) jequv(jv)=it 80 enddo 90 enddo c c mark fine interface vertices not present on irgn c do ii=1,nvv i=ii+ipath(3,irgn)-1 it=i 100 it=jequv(it) mark(it)=1 if(it.ne.i) go to 100 enddo do ii=newndf+1,ndi i=ii-newndf+ipath(3,nproc+1)-1 it=i 110 it=jequv(it) mark(it)=1 if(it.ne.i) go to 110 enddo do i=1,nn if(mark(i).eq.0) jequv(i)=-jequv(i) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setgr2(irgn,nproc,ntf,ndd,newndf,ndi,itnode, + ndof,itdof,ipath,jequv,ja0,link,maxja0,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja0(*),ipath(6,*),itnode(5,*),itdof(ndof,*),jequv(*), 1 link(*),idof(10) c c construct interface ja c iflag=1 n=ipath(4,nproc+2) c c c do i=1,n ja0(i)=0 link(i)=0 enddo c c fill out rest of ja c next=n+2 do it=1,ntf call l2gmap(it,idof,ndof,itdof) jrgn=itnode(4,it) c do j=1,ndof do k=j+1,ndof irow=min0(idof(j),idof(k)) icol=max0(idof(j),idof(k)) if(irow.le.ndd) then jrow=i2j(irow,irgn,jrgn,1,0,ipath,jequv) if(icol.le.ndd) then jcol=i2j(icol,irgn,jrgn,1,0,ipath,jequv) else if(icol.le.newndf) then jcol=-icol else if(icol.le.ndi) then iicol=icol-newndf jcol=i2j(iicol,nproc+1,jrgn,1,0,ipath,jequv) else jcol=-icol endif else if(irow.le.newndf) then jrow=0 else if(irow.le.ndi) then iirow=irow-newndf jrow=i2j(iirow,nproc+1,jrgn,1,0,ipath,jequv) if(icol.le.ndi) then iicol=icol-newndf jcol=i2j(iicol,nproc+1,jrgn,1,0,ipath,jequv) else jcol=-icol endif else jrow=0 endif if(jrow.ne.0) then ilink=link(jrow) 10 if(ilink.eq.0) then if(next.gt.maxja0) return ja0(next)=jcol link(next)=link(jrow) link(jrow)=next ja0(jrow)=ja0(jrow)+1 next=next+1 else if(ja0(ilink).ne.jcol) then ilink=link(ilink) go to 10 endif endif enddo enddo enddo c c now make new ja0 c ja0i=n+2 do i=1,n itemp=ja0(i) ja0(i)=ja0i ja0i=ja0i+itemp enddo ja0(n+1)=ja0i c do i=1,n next=link(i) do m=ja0(i),ja0(i+1)-1 ii=next next=link(next) link(ii)=m enddo enddo do i=ja0(1),ja0(n+1)-1 100 if(link(i).ne.i) then jj=ja0(i) ii=link(i) ja0(i)=ja0(ii) link(i)=link(ii) ja0(ii)=jj link(ii)=ii go to 100 endif enddo c c sort indices c do i=1,n len=ja0(i+1)-ja0(i) call ihp(ja0(ja0(i)),len) enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ja0map(ii,jj,i,j,ij,ji,ja0,amtx0) c implicit real (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 stop 9721 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine jamap(i,j,ij,ji,ja,amtx) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function i2j(i,irgn,jrgn,isw,jsw,ipath,jequv) c implicit real (a-h,o-z) implicit integer (i-n) integer + jequv(*),ipath(6,*) 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(3,irgn)-1 else i2j=i endif ii=i2j 10 if(i2j.ge.ipath(3,jrgn).and.i2j.le.ipath(4,jrgn)) then if(jsw.eq.1) i2j=i2j-ipath(3,jrgn)+1 return endif i2j=jequv(i2j) if(i2j.ne.ii) go to 10 i2j=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine paste(ip,itnode,itedge,ibndry,ibedge,ipath, + vx,vy,xm,ym,maxd,gf,list,ipstsw,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ip(100),p(3),q(3), 1 ibedge(2,*),ipath(6,*),list(*),itdof(ndof,*),idof(10), 2 jdof(10) real + vx(*),vy(*),gf(maxd,*),xm(*),ym(*),e(3),bump(3) c c c ntf=ip(1) nvf=ip(2) nbf=ip(4) ndf=ip(5) maxt=ip(83) maxv=ip(84) maxb=ip(86) iord=ip(26) ngf=ip(77) maxpth=ip(81) ibase=ip(70) lenb=3 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,itnode,ibndry,ibedge,ndof,itdof, + itedge,list) endif call matchp(nproc,ipath,list) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,list,iflag) if(iflag.ne.0) stop 8255 call cedge5(nbf,itedge,ibedge,1) c c make short paths c ismth=0 iseg=ipath(1,irgn)-1 nseg=ipath(2,irgn) 40 iseg=iseg+1 if(iseg.gt.nseg) go to 50 if(ipath(2,iseg).gt.0) go to 40 jseg=ipath(1,iseg) if(jseg.le.0) go to 40 if(ipath(2,jseg).le.0) go to 40 ibdy=-ipath(2,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,ndf,iord,itnode, + itedge,ibndry,ibedge,ndof,itdof,vx,vy,xm,ym, 1 maxv,maxt,maxb,maxd,gf,ngf,ibase,lenb,bump, 2 p,q,e,0,iflag) c 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(2,jseg) ipath(2,iseg)=nseg+1 ipath(1,nseg+1)=json+1 ipath(2,nseg+1)=-nbf ipath(3,nseg+1)=ipath(3,iseg) ipath(4,nseg+1)=nvf ipath(1,json+1)=nseg+1 ipath(1,nseg+2)=json ipath(2,nseg+2)=-ibdy ipath(3,nseg+2)=nvf ipath(4,nseg+2)=ipath(4,iseg) ipath(1,json)=nseg+2 nseg=nseg+2 go to 40 c 50 if(ismth.eq.0) go to 55 lenb=3 angmin=1.0e-3 arcmax=0.26e0 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,e,0,1,iord,ndof,itdof) c c smoothing c call cedge5(nbf,itedge,ibedge,0) call cvtype(ntf,nbf,nvf,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 ip(5)=ndf c if(ipstsw.eq.1) return c c adjust interface boundary edges that have been resolved c do 60 iseg=ipath(1,irgn),nseg if(ipath(2,iseg).gt.0) go to 60 jseg=ipath(1,iseg) if(jseg.le.iseg) go to 60 if(ipath(2,jseg).gt.0) go to 60 i=-ipath(2,iseg) j=-ipath(2,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 call l2gmpe(i,ibedge,iord,idof,ndof,itdof) call l2gmpe(j,ibedge,iord,jdof,ndof,itdof) do m=1,ngf do k=1,iord+1 gg=(gf(idof(k),m)+gf(jdof(iord+2-k),m))/2.0e0 gf(idof(k),m)=gg gf(jdof(iord+2-k),m)=gg enddo enddo 60 enddo c c delete extra edges, vertices and degress of freedom c i1=1 i2=i1+ndf i3=i2+ndf c call trmbdy(ip,itnode,ibndry,ibedge,vx,vy,list(i1),list(i2), + list(i3),maxd,gf,ndof,itdof) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine paste1(ip,itnode,ibndry,vx,vy,xm,ym,maxd,gf, + itedge,ibedge,vtype,iseed,ipath,idist,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*),idist(*), 1 itedge(3,*),vtype(*),ibedge(2,*),ipath(6,*), 2 elist(500),tlist(500),vlist(500),blist(500), 3 itdof(ndof,*),p(3),q(3),index(3,3) real + gf(maxd,*),vx(*),vy(*),bump(3),e(3),xm(*),ym(*) save index data index/1,2,3,2,3,1,3,1,2/ c c check to see if we have solved problem on current finest grid c ntf=ip(1) nvf=ip(2) nbf=ip(4) ndf=ip(5) newntf=ip(27) newnvf=ip(28) newnbf=ip(29) newndf=ip(30) nvi=ip(34) nbi=ip(35) ndi=ip(36) maxt=ip(83) maxv=ip(84) maxb=ip(86) iord=ip(26) ngf=ip(77) nproc=ip(49) irgn=ip(50) ibase=ip(70) maxpth=ip(81) lenb=3 nvv=ipath(4,nproc+2) c c initailize c call mkpthi(ip,ipath,itnode,ibndry,ibedge,ndof,itdof, + itedge,iseed,0) c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iseed,iflag) if(iflag.ne.0) stop 1311 call cedge5(nbf,itedge,ibedge,1) c call crdist(ntf,irgn,nproc,itnode,itedge,ibndry,ibedge, + iseed,iseed(ntf+1),idist) call pdepth(nproc,ipath,iseed) mxdist=1 mfact=2 ntfsv=ntf iseg=ipath(1,nproc+1)-1 nseg=ipath(2,nproc+1) 40 iseg=iseg+1 if(iseg.gt.nseg) go to 50 c c test for edges with a crosspoint endpoint c c*** if(min0(ipath(3,iseg),ipath(4,iseg)).gt.0) go to 40 if(ipath(2,iseg).gt.0) go to 40 jseg=ipath(1,iseg) if(jseg.le.0) go to 40 if(ipath(2,jseg).le.0) go to 40 ibdy=-ipath(2,iseg) c c fixup ibedge if necessary c it=ibedge(1,ibdy)/4 jt=ibedge(2,ibdy)/4 if(itnode(4,jt).lt.itnode(4,it)) then ii=ibedge(1,ibdy) ibedge(1,ibdy)=ibedge(2,ibdy) ibedge(2,ibdy)=ii jedge=ibedge(1,ibdy)-4*jt ibndry(1,ibdy)=itnode(index(2,jedge),jt) ibndry(2,ibdy)=itnode(index(3,jedge),jt) endif c c test for interface paths near irgn c itri=ibedge(1,ibdy)/4 i1=idist(itnode(4,itri)) if(ibndry(4,ibdy).eq.0) then itri=ibedge(2,ibdy)/4 i1=min0(idist(itnode(4,itri)),i1) endif if(i1.gt.max0(mxdist,iseed(jseg)/mfact)) go to 40 c*** if(i1.gt.mxdist) go to 40 c 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).eq.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 itrgn=itnode(4,itri) call etst(ibdy,itrgn,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) call newnot(itri,iedge,nvf,ntf,nbf,ndf,iord,itnode, + itedge,ibndry,ibedge,ndof,itdof,vx,vy,xm,ym, 1 maxv,maxt,maxb,maxd,gf,ngf,ibase,lenb,bump, 2 p,q,e,0,iflag) c 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(2,jseg) ipath(2,iseg)=nseg+1 ipath(1,nseg+1)=json+1 ipath(2,nseg+1)=-nbf ipath(3,nseg+1)=ipath(3,iseg) ipath(4,nseg+1)=nvf-newnvf+nvv ipath(1,nseg+2)=json ipath(2,nseg+2)=-ibdy ipath(3,nseg+2)=nvf-newnvf+nvv ipath(4,nseg+2)=ipath(4,iseg) nseg=nseg+2 go to 40 c 50 if(ntfsv.eq.ntf) go to 60 ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(5)=ndf i1=1 i2=i1+max0(nbf,nvf,ndf) i3=i2+max0(nbf,nvf,ndf) i4=i3+max0(nbf,nvf,ndf) call cutr2(ip,itnode,ibndry,vx,vy,iseed(i1),iseed(i2), + iseed(i3),iseed(i4),itedge,ibedge,maxd,gf,ndof,itdof) nvi=ip(34) nbi=ip(35) ndi=ip(36) call mkpthi(ip,ipath,itnode,ibndry,ibedge,ndof,itdof, + itedge,iseed,0) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iseed,iflag) if(iflag.ne.0) stop 1322 call cedge5(nbf,itedge,ibedge,1) c c 60 ic=0 do iseg=ipath(1,nproc+1),ipath(2,nproc+1) ison=ipath(2,iseg) if(ison.gt.0) then if(ipath(1,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 c main elimination loop c do 70 iseg=ipath(2,nproc+1),ipath(1,nproc+1),-1 ison=ipath(2,iseg) if(ison.le.0) go to 70 if(ipath(1,ison).gt.0) go to 70 iv1=ipath(3,ison)-nvv+newnvf iv2=ipath(4,ison)-nvv+newnvf jv1=ipath(3,ison+1)-nvv+newnvf jv2=ipath(4,ison+1)-nvv+newnvf if(ipath(3,ison).eq.0) then i=iv2 else if(iv1.eq.jv2) then i=iv1 else if(iv2.eq.jv1) then i=iv2 else stop 7676 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 eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,0,1,iord,ndof,itdof,iflag) c c if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,ndof, + itdof,vx,vy,lenb,bump,e,iseed,vtype, 1 vlist,tlist,elist,len,iord,ibase,-1) if(vtype(i).eq.8) then len1=elist(len+2)-(len+1) call dlknot(ii,itnode,itedge,ibndry,ibedge,ndof, + itdof,vx,vy,lenb,bump,e,iseed,vtype, 1 vlist(len+2),tlist(len+2),elist(len+2), 2 len1,iord,ibase,-1) endif else stop 6651 endif 70 enddo 80 call clnup2(nvf,ntf,nbf,ndf,newnvf,newntf,newnbf,newndf, + nvi,nbi,ndi,irgn,itnode,itedge,ibndry,ibedge,vx,vy, 1 iseed,gf,maxd,ngf,ndof,itdof) c ip(1)=ntf ip(2)=nvf ip(4)=nbf ip(5)=ndf ip(34)=nvi ip(35)=nbi ip(36)=ndi c call mkpthi(ip,ipath,itnode,ibndry,ibedge,ndof,itdof, + itedge,iseed,1) ic=0 do iseg=ipath(1,nproc+1),ipath(2,nproc+1) ison=ipath(2,iseg) if(ison.gt.0) then if(ipath(1,ison).le.0) ic=ic+1 endif enddo if(ic.ne.0) stop 7612 call matchp(nproc,ipath,iseed) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine newnot(itri,iedge,nvf,ntf,nbf,ndf,iord,itnode, + itedge,ibndry,ibedge,ndof,itdof,vx,vy,xm,ym,maxv,maxt, 1 maxb,maxd,gf,ngf,ibase,lenb,bump,p,q,e,isw,iflag) c implicit real (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),p(*),q(*),id(4,3), 2 itdof(ndof,*),idof(10),jdof(10),imap(7,4),jmap(7,4) real + vx(*),vy(*),gf(maxd,*),c(3),xm(*),ym(*),bump(lenb,*), 1 e(*),gv(10) save index,it,ib,iv,id 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/ data id/1,1,1,1,3,4,4,4,6,9,9,9/ 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=84 return endif if(nbf+ib(icase).gt.maxb) then iflag=86 return endif if(ntf+it(icase).gt.maxt) then iflag=83 return endif if(ndf+id(icase,iord).gt.maxd) then iflag=89 return endif iflag=0 nvf=nvf+iv(icase) nbf=nbf+ib(icase) ntf=ntf+it(icase) ndf0=ndf ndf=ndf+id(icase,iord) c c if(icase.ne.4) go to 5 iv2=itnode(index(2,iedge),itri) iv3=itnode(index(3,iedge),itri) vx(nvf)=(vx(iv2)+vx(iv3))/2.0e0 vy(nvf)=(vy(iv2)+vy(iv3))/2.0e0 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.0e0 vy(nvf)=(vy(ibndry(1,ibdy))+vy(ibndry(2,ibdy)))/2.0e0 endif 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.0e0 vy(nvf-1)=(vy(ibndry(1,jbdy))+vy(ibndry(2,jbdy)))/2.0e0 endif 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 new dofs, interpolation c call l2gmap(itri,idof,ndof,itdof) do j=1,iord+1 do i=1,2*(iord+1-j)+1 imap(i,j)=0 enddo enddo i2=index(2,iedge) i3=index(3,iedge) imap(1,iord+1)=idof(iedge) imap(1,1)=idof(i2) imap(2*iord+1,1)=idof(i3) if(iord.eq.2) then imap(1,2)=idof(i3+3) imap(3,2)=idof(i2+3) imap(3,1)=idof(iedge+3) else if(iord.eq.3) then imap(1,3)=idof(2*i3+2) imap(1,2)=idof(2*i3+3) imap(5,2)=idof(2*i2+2) imap(3,3)=idof(2*i2+3) imap(3,1)=idof(2*iedge+2) imap(5,1)=idof(2*iedge+3) imap(3,2)=idof(10) endif do j=1,iord+1 do i=1,2*(iord+1-j)+1 if(imap(i,j).eq.0) then ndf0=ndf0+1 imap(i,j)=ndf0 c(iedge)=float(j-1)/float(iord) c(i3)=float(i-1)/float(2*iord) c(i2)=1.0e0-c(iedge)-c(i3) call beval1(c,gv,iord) do ifn=1,ngf gf(ndf0,ifn)=0.0e0 do m=1,ndof gf(ndf0,ifn)=gf(ndf0,ifn) + +gf(idof(m),ifn)*gv(m) enddo enddo endif enddo enddo c do j=1,ndof itdof(j,ntf)=itdof(j,itri) enddo itdof(i3,itri)=imap(iord+1,1) itdof(i2,ntf)=imap(iord+1,1) if(iord.eq.2) then itdof(iedge+3,itri)=imap(2,1) itdof(i2+3,itri)=imap(2,2) itdof(iedge+3,ntf)=imap(4,1) itdof(i3+3,ntf)=imap(2,2) else if(iord.eq.3) then itdof(2*iedge+2,itri)=imap(2,1) itdof(2*iedge+3,itri)=imap(3,1) itdof(2*i2+2,itri)=imap(3,2) itdof(2*i2+3,itri)=imap(2,3) itdof(10,itri)=imap(2,2) itdof(2*iedge+2,ntf)=imap(5,1) itdof(2*iedge+3,ntf)=imap(6,1) itdof(2*i3+2,ntf)=imap(2,3) itdof(2*i3+3,ntf)=imap(3,2) itdof(10,ntf)=imap(4,2) endif c c refine jtri c if(icase.eq.1) go to 20 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 ntf1=ntf-1 itedge(index(3,jedge),jtri)=4*ntf1+index(2,jedge) itedge(index(2,jedge),ntf1)=4*jtri+index(3,jedge) if(icase.eq.2) then itedge(jedge,jtri)=-nbf itedge(jedge,ntf1)=-ibdy itnode(index(2,jedge),jtri)=nvf itnode(index(3,jedge),ntf1)=nvf else if(icase.eq.4) then itedge(jedge,ntf1)=4*ntf+iedge itnode(index(2,jedge),jtri)=nvf itnode(index(3,jedge),ntf1)=nvf else itedge(jedge,jtri)=-(nbf-1) itedge(jedge,ntf1)=-jbdy itnode(index(2,jedge),jtri)=nvf-1 itnode(index(3,jedge),ntf1)=nvf-1 endif c m=itedge(index(3,jedge),ntf1) if(m.gt.0) then mtri=m/4 medge=m-4*mtri itedge(medge,mtri)=index(3,jedge)+4*ntf1 else mb=-m if(ibedge(1,mb)/4.eq.jtri) then ibedge(1,mb)=index(3,jedge)+4*ntf1 else ibedge(2,mb)=index(3,jedge)+4*ntf1 endif endif c c new dofs, interpolation c call l2gmap(jtri,jdof,ndof,itdof) do j=1,iord+1 do i=1,2*(iord+1-j)+1 jmap(i,j)=0 enddo enddo j2=index(2,jedge) j3=index(3,jedge) jmap(1,iord+1)=jdof(jedge) jmap(1,1)=jdof(j2) jmap(2*iord+1,1)=jdof(j3) if(iord.eq.2) then jmap(1,2)=jdof(j3+3) jmap(3,2)=jdof(j2+3) jmap(3,1)=jdof(jedge+3) else if(iord.eq.3) then jmap(1,3)=jdof(2*j3+2) jmap(1,2)=jdof(2*j3+3) jmap(5,2)=jdof(2*j2+2) jmap(3,3)=jdof(2*j2+3) jmap(3,1)=jdof(2*jedge+2) jmap(5,1)=jdof(2*jedge+3) jmap(3,2)=jdof(10) endif do i=1,2*iord+1 jmap(i,1)=imap(2*iord+2-i,1) enddo do j=1,iord+1 do i=1,2*(iord+1-j)+1 if(jmap(i,j).eq.0) then ndf0=ndf0+1 jmap(i,j)=ndf0 c(jedge)=float(j-1)/float(iord) c(j3)=float(i-1)/float(2*iord) c(j2)=1.0e0-c(jedge)-c(j3) call beval1(c,gv,iord) do ifn=1,ngf gf(ndf0,ifn)=0.0e0 do m=1,ndof gf(ndf0,ifn)=gf(ndf0,ifn) + +gf(jdof(m),ifn)*gv(m) enddo enddo endif enddo enddo c do j=1,ndof itdof(j,ntf1)=itdof(j,jtri) enddo itdof(j2,jtri)=jmap(iord+1,1) itdof(j3,ntf1)=jmap(iord+1,1) if(iord.eq.2) then itdof(jedge+3,jtri)=jmap(4,1) itdof(j3+3,jtri)=jmap(2,2) itdof(jedge+3,ntf1)=jmap(2,1) itdof(j2+3,ntf1)=jmap(2,2) else if(iord.eq.3) then itdof(2*jedge+2,jtri)=jmap(5,1) itdof(2*jedge+3,jtri)=jmap(6,1) itdof(2*j3+2,jtri)=jmap(2,3) itdof(2*j3+3,jtri)=jmap(3,2) itdof(10,jtri)=jmap(4,2) itdof(2*jedge+2,ntf1)=jmap(2,1) itdof(2*jedge+3,ntf1)=jmap(3,1) itdof(2*j2+2,ntf1)=jmap(3,2) itdof(2*j2+3,ntf1)=jmap(2,3) itdof(10,ntf1)=jmap(2,2) endif c if(isw.eq.1) then do k=1,lenb bump(k,ntf1)=bump(k,jtri) enddo e(ntf1)=tqual(ntf1,itnode,vx,vy,lenb,bump,iord) p(ntf1)=ntf1 q(ntf1)=ntf1 call updhp(ntf1,ntf1,p,q,e,1) e(jtri)=tqual(jtri,itnode,vx,vy,lenb,bump,iord) kk=q(jtri) call updhp(kk,ntf1,p,q,e,1) endif 20 if(isw.eq.1) then do k=1,lenb bump(k,ntf)=bump(k,itri) enddo e(ntf)=tqual(ntf,itnode,vx,vy,lenb,bump,iord) p(ntf)=ntf q(ntf)=ntf call updhp(ntf,ntf,p,q,e,1) e(itri)=tqual(itri,itnode,vx,vy,lenb,bump,iord) kk=q(itri) call updhp(kk,ntf,p,q,e,1) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine etst1(itri0,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ibedge(2,*), 1 index(3,3) real + 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 itri=itri0 thresh=0.9e0 c c find longest edge of itri c iv1=itnode(1,itri) iv2=itnode(2,itri) iv3=itnode(3,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 iedge=1 if(h(iedge).lt.h(2)) iedge=2 if(h(iedge).lt.h(3)) iedge=3 itsv=itri iesv=iedge isw=1 c*** if(isw.eq.1) return c c find out whats on other side 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 return 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 itri=jtri iedge=jedge 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.thresh*amax1(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 kbdy=-itedge(kedge,itri) if(kbdy.lt.0) then jtri=itedge(kedge,itri)/4 jedge=itedge(kedge,itri)-4*jtri else 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 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.thresh*amax1(h(2),h(3))) then iedge=kedge return else itri=jtri iedge=jedge go to 30 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine etst(ibdy,irgn,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ibedge(2,*), 1 index(3,3) real + 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 thresh=0.8e0 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.thresh*amax1(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.thresh*amax1(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.thresh*amax1(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(5,kbdy).ne.0) then if(itri.eq.jtsv) then isw=1 itri=itsv iedge=iesv endif 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 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.thresh*amax1(h(2),h(3))) then iedge=kedge return else itri=jtri iedge=jedge go to 30 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine trmbdy(ip,itnode,ibndry,ibedge,vx,vy,p,q, + iequv,maxd,gf,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),p(*),q(*),iequv(*), 1 itdof(ndof,*),ibedge(2,*) real + vx(*),vy(*),gf(maxd,*) c ntf=ip(1) nvf=ip(2) nbf=ip(4) ndf=ip(5) iord=ip(26) c c mark vertices c call cequvd(ndf,nbf,ibndry,ibedge,iequv,iord,ndof,itdof) do i=1,ndf p(i)=i enddo c c fixup itdof c do i=1,ntf do j=1,ndof itdof(j,i)=iequv(itdof(j,i)) enddo enddo c c now reorder vertices c newndf=0 do i=1,ndf if(iequv(i).eq.i) then newndf=newndf+1 p(i)=p(newndf) p(newndf)=i endif enddo c call dorder(ip,p,q,ndof,itdof,maxd,gf) 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 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,maxd) 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 ip(5)=newndf return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine citdof(ip,itnode,ibndry,itedge,ibedge,vtype, + iseed,itldof) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*),iseed(*),itedge(3,*), 1 vtype(*),elist(500),tlist(500),vlist(500), 2 ibedge(2,*),blist(500),itldof(3,*) c ntf=ip(1) nvf=ip(2) nbf=ip(4) c ierrsw=ip(19) c c do not allow discontinuous gradient c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + vtype,iflag) ndl=0 c if(ierrsw.eq.1) go to 10 c c global recovery c call cequv1(nvf,nbf,ibndry,vtype,1) do i=1,nvf if(vtype(i).eq.i) then ndl=ndl+1 iseed(i)=ndl else iseed(i)=iseed(vtype(i)) endif enddo c do i=1,ntf do j=1,3 itldof(j,i)=iseed(itnode(j,i)) enddo enddo go to 20 c c patchwise recovery c 10 call cedge5(nbf,itedge,ibedge,1) c 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 do i=1,ntf do j=1,3 itldof(j,i)=0 iseed(itnode(j,i))=j+4*i enddo enddo c c initialize itldof c do iv=1,nvf call cirlst(iv,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) isw=1 if(vtype(iv).le.5) then l2=len+1 else l2=len endif do ll=2,l2 i=tlist(ll) j=iabs(elist(ll)) if(isw.eq.1) ndl=ndl+1 if(itldof(j,i).ne.0) stop 5252 itldof(j,i)=ndl isw=0 if(itnode(5,i).ne.itnode(5,tlist(ll+1))) isw=1 enddo enddo do i=1,ntf do j=1,3 if(itldof(j,i).eq.0) stop 6363 enddo enddo c call cedge5(nbf,itedge,ibedge,0) c 20 ip(78)=ndl c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cbump(ndl,ntf,ndf,maxd,nef,iord,u,vx,vy,xm,ym, + itnode,itldof,icurv,ja,a1,a2,r,z,ndof,itdof,lenb,bump,e,rp) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ja(*),idof(10),itldof(3,*),itdof(ndof,*), 1 icurv(3,*),jdof(10) real + vx(*),vy(*),u(maxd,*),r(ndl,*),bump(lenb,*), 1 a1(*),a2(*),z(*),x(3),y(3),tx(3),ty(3),e(*), 2 rx(10),ry(10),er(10),hist(22),rp(100),xm(*),ym(*) data ibit/0/ c c compute recovered gradient c mxcg=20 mxsmth=2 ldof=3 lord=1 eps=amax1(1.0e1*ceps(ibit),1.0e-6) c i1=1+ndl i2=i1+ndl i3=i2+ndl nfun=iord+1 c c compute mass and stiffness matrices for linear elements c maxlnk=ndl*4 call setgr1(ntf,ndl,ldof,itldof,ja,a1,maxlnk,jflag) call l2mtx(ndl,ntf,vx,vy,itnode,ja,a2,lord,ldof,itldof) call h1mtx(ndl,ntf,vx,vy,itnode,ja,a1,lord,ldof,itldof) c do ifn=1,nef do j=1,nfun do i=1,ndl r(i,j)=0.0e0 enddo enddo c c compute right hand sides c do itri=1,ntf call l2gmap(itri,idof,ndof,itdof) call l2gmap(itri,jdof,ldof,itldof) call elel2p(itri,itnode,icurv,idof,vx,vy,xm,ym, + u(1,ifn),er,iord) do k=1,ldof do j=1,nfun r(jdof(k),j)=r(jdof(k),j)+er(j) enddo enddo enddo c c l2 projection and smoothing c do j=1,nfun rnorm=rl2nrm(ndl,r(1,j)) if(rnorm.gt.0.0e0) then do i=1,ndl z(i)=r(i,j)/rnorm enddo call sgscg(ndl,ja,a2,r(1,j),z,mxcg,eps,z(i1), + z(i2),z(i3),hist,iflag) if(mxsmth.gt.0) then do i=1,ndl z(i)=0.0e0 enddo call jcg(ndl,ja,a1,r(1,j),z,mxsmth, + z(i1),z(i2),z(i3),eps) endif do i=1,ndl r(i,j)=r(i,j)*rnorm enddo endif enddo c c compute gradients of recovered functions c umax=0.0e0 do i=1,ndf z(i)=u(i,ifn) umax=amax1(abs(z(i)),umax) enddo if(umax.gt.0.0e0) then do i=1,ndf z(i)=z(i)/umax enddo do i=1,ndl do j=1,nfun r(i,j)=r(i,j)/umax enddo enddo endif do itri=1,ntf c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) call l2gmap(itri,jdof,ldof,itldof) iv1=jdof(1) iv2=jdof(2) iv3=jdof(3) do j=1,nfun rx(j)=x(1)*r(iv1,j)+x(2)*r(iv2,j)+x(3)*r(iv3,j) ry(j)=y(1)*r(iv1,j)+y(2)*r(iv2,j)+y(3)*r(iv3,j) enddo c c initial form of bump c ii=(ifn-1)*(nfun+1) bump(ii+1,itri)=rx(1) do j=2,nfun bump(ii+j,itri)=(rx(j)+ry(j-1))/2.0e0 enddo bump(ii+nfun+1,itri)=ry(nfun) c c final form of bump c call l2gmap(itri,idof,ndof,itdof) call l2gmap(itri,jdof,ldof,itldof) an=tqualn(itri,itnode,icurv,vx,vy,xm,ym,z, + ndl,r,idof,iord,jdof) ad=tquald(itri,itnode,vx,vy,bump(ii+1,itri),iord) if(ad.gt.0.0e0) then aa=sqrt(an/ad) do j=1,nfun+1 bump(ii+j,itri)=bump(ii+j,itri)*aa enddo endif enddo c enddo c c compute norms c enorm1=0.0e0 enorm2=0.0e0 unorm1=0.0e0 unorm2=0.0e0 do i=1,ntf enorm2=enorm2+tqual2(i,itnode,vx,vy,lenb,bump,iord) e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) enorm1=enorm1+e(i) call l2gmap(i,idof,ndof,itdof) do ifn=1,nef unorm1=unorm1+eh1nrm(i,itnode,vx,vy,u(1,ifn),idof,iord) unorm2=unorm2+el2nrm(i,itnode,vx,vy,u(1,ifn),idof,iord) enddo enddo enorm1=sqrt(enorm1) rp(37)=enorm1 unorm1=sqrt(unorm1) rp(38)=unorm1 rp(39)=sqrt(enorm2) rp(40)=sqrt(unorm2) relerr=1.0e0 if(unorm1.ne.0.0e0) relerr=enorm1/unorm1 if(unorm1+enorm1.le.0.0e0) relerr=0.0e0 rp(53)=relerr c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine gproj(ndf,ntf,u,ux,uy,vx,vy,itnode,ja,a,bx,by, + z,iord,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),ja(*),idof(10) real + vx(*),vy(*),u(*),a(*),z(*),ux(*), 1 uy(*),bx(*),by(*),hist(22),ebx(10),eby(10) data ibit/0/ c c compute recovered gradient c mxcg=20 eps=amax1(1.0e1*ceps(ibit),1.0e-6) c i1=1 i2=i1+ndf i3=i2+ndf c c compute mass matrix c maxlnk=ndf*4 if(iord.eq.2) maxlnk=ndf*25/4 if(iord.eq.3) maxlnk=ndf*81/9 call setgr1(ntf,ndf,ndof,itdof,ja,a,maxlnk,jflag) c call l2mtx(ndf,ntf,vx,vy,itnode,ja,a,iord,ndof,itdof) c do i=1,ndf bx(i)=0.0e0 by(i)=0.0e0 enddo c c compute projected gradient c do itri=1,ntf call l2gmap(itri,idof,ndof,itdof) call elerhs(itri,itnode,idof,vx,vy,u,ebx,eby,iord) c do k=1,ndof ivk=idof(k) bx(ivk)=bx(ivk)+ebx(k) by(ivk)=by(ivk)+eby(k) enddo enddo c c l2 projection c call sgscg(ndf,ja,a,ux,bx,mxcg,eps,z(i1), + z(i2),z(i3),hist,iflagx) call sgscg(ndf,ja,a,uy,by,mxcg,eps,z(i1), + z(i2),z(i3),hist,iflagy) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cdlfn(ip,itnode,ndof,itdof,b,udl,ja,a,ka, + mark,z,hist) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ka(*),ja(*),amtx, 1 mark(*),itdof(ndof,*),idof(10) real + udl(*),z(*),hist(22,*),a(*),b(*) data ibit/0/ c c ntf=ip(1) ndf=ip(5) irgn=ip(50) ispd=ip(8) mxcg=ip(10) eps=1.0e2*ceps(ibit) epsmg=amax1(1.0e-3,eps) c c set ups rhs c m0=1 m1=m0+ndf if(ip(73).eq.0.or.ip(74).eq.0) stop 7272 amtx=0 if(ispd.ne.1) amtx=ja(ndf+1)-ja(1) iqptr=ja(ndf+1) c c mark dofs in irgn c do i=1,ndf mark(i)=0 enddo do i=1,ntf if(itnode(4,i).eq.irgn) then call l2gmap(i,idof,ndof,itdof) do j=1,ndof mark(ja(iqptr+idof(j)-1))=1 enddo endif enddo c do i=1,ndf z(i)=0.0e0 if(mark(i).eq.1) z(i)=a(i) enddo do i=1,ndf if(mark(i).eq.1) then 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.0e0 a(j+amtx)=0.0e0 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.0e0 a(j+amtx)=0.0e0 endif enddo endif enddo c c solve equations c if(ispd.eq.0) then jspd=-1 else jspd=1 endif call mtxml0(ndf,ja,a,udl,b,z(m1),jspd) do i=1,ndf b(i)=z(ja(iqptr+i-1))-b(i) enddo call mgilu(ja,a,ka,z) call mg(jspd,mxcg,epsmg,ja,a,z,b, + ka,0,relerr,jflag,z(m1),hist(1,18)) do i=1,ndf udl(i)=udl(i)+z(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cgdist(nvf,ntf,nbf,ja,jc,q,order,idist, + irgn,itnode,ibndry,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jc(*),order(*),idist(*),ibndry(6,*),ja(*), 1 q(*) c c compute distance in graph from irgn c mxdist=0 c call ja2jc(nvf,ja,jc) do i=1,nvf idist(i)=nvf+1 enddo c c mark points in region irgn c do i=1,ntf if(itnode(4,i).eq.irgn) then do j=1,3 ii=itnode(j,i) if(isw.eq.1) ii=q(ii) idist(ii)=0 enddo endif enddo c do kk=1,2 c c breadth first search c next=1 do i=1,nvf if(idist(i).eq.0) then order(next)=i next=next+1 else idist(i)=nvf+1 endif enddo c do ii=1,nvf if(ii.ge.next) go to 10 i=order(ii) do jj=jc(i),jc(i+1)-1 j=jc(jj) if(idist(j).gt.nvf) then idist(j)=idist(i)+1 order(next)=j next=next+1 if(next.gt.nvf) go to 10 endif enddo enddo c c adjust coarse interface edges near cross points c 10 if(kk.eq.2.or.mxdist.le.0) return do i=1,nbf if(ibndry(5,i).ne.0) then do j=1,2 ii=ibndry(j,i) if(isw.eq.1) ii=q(ii) if(idist(ii).le.mxdist) idist(ii)=0 enddo endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine usrfn(ntf,iord,itnode,ndof,itdof,iprob,vx,vy, + ngf,maxd,u,e,rp,lenb,bump,qxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),idof(10),itdof(ndof,*) real + vx(*),vy(*),u(maxd,*),e(*),bump(lenb,*),rp(100), 1 gv(5,15),c(5,15),uu(10),g(5,15) 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 call cnodes(c,iord+1) npts=(iord+2)*(iord+3)/2 do i=1,ntf call l2gmap(i,idof,ndof,itdof) call deval(i,itnode,vx,vy,g,iord+1) call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + npts,gv,c,idof,iord,qxy) do j=1,iord+2 ss=0.0e0 do k=1,npts ss=ss+gv(5,k)*g(j,k) enddo bump(j,i)=ss enddo do j=iord+3,lenb bump(j,i)=0.0e0 enddo enddo c enorm1=0.0e0 enorm2=0.0e0 unorm1=0.0e0 unorm2=0.0e0 call cnodes(c,iord) npts=(iord+1)*(iord+2)/2 do i=1,ntf enorm2=enorm2+tqual2(i,itnode,vx,vy,lenb,bump,iord) e(i)=tqual(i,itnode,vx,vy,lenb,bump,iord) enorm1=enorm1+e(i) call l2gmap(i,idof,ndof,itdof) call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + npts,gv,c,idof,iord,qxy) do j=1,npts uu(j)=gv(5,j) idof(j)=j enddo unorm1=unorm1+eh1nrm(i,itnode,vx,vy,uu,idof,iord) unorm2=unorm2+el2nrm(i,itnode,vx,vy,uu,idof,iord) enddo c enorm1=sqrt(enorm1) rp(37)=enorm1 unorm1=sqrt(unorm1) rp(38)=unorm1 rp(39)=sqrt(enorm2) rp(40)=sqrt(unorm2) relerr=1.0e0 if(unorm1.ne.0.0e0) relerr=enorm1/unorm1 if(unorm1+enorm1.le.0.0e0) relerr=0.0e0 rp(53)=relerr c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + deg,vx,vy,lenb,bump,e,isw,ksw,iord,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),deg(*),ibndry(6,*), 1 ibedge(2,*),iseed(3),itdof(ndof,*) real + vx(*),vy(*),bump(lenb,*),fract0(5),qmin0(5),e(*) save index,fract0,qmin0 data index/1,2,3,2,3,1,3,1,2/ data fract0/1.0e0, 1.0e0, 0.95e0, 0.9e0,1.0e0/ data qmin0 /1.0e0,0.95e0, 0.87e0, 0.6e0,0.95e0/ 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.0e0-cang(kb,kv,ka,vx,vy)*3.0e0 iq=max0(int(q+0.5e0)-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 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 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=amin1(q2,q3) qik=amin1(qi,qk) if(q23.lt.amin1(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 call eleswp(i,ied,itnode,itedge,ibedge, + iord,ndof,itdof,lenb,bump,e,iseed, 1 vx,vy,isw,0,ksw) 50 continue enddo if(ichng.le.0) go to 100 enddo 100 continue return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy,lenb,bump, + e,iseed,vtype,vlist,tlist,elist,blist,len,isw,ksw, 1 iord,ndof,itdof,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),index(3,3), 1 iseed(*),vtype(*),ibedge(2,*),itdof(ndof,*), 2 vlist(500),tlist(500),elist(500),blist(500) real + 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.0e0 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.0e0) 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.0e0) then iflag=1 return endif k=index(3,iabs(elist(jj))) it=tlist(jj) call eleswp(it,k,itnode,itedge,ibedge,iord,ndof,itdof, + lenb,bump,e,iseed,vx,vy,isw,1,ksw) 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.0e0 do 40 j=3,len qq=geom(i,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0e0) 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.0e0) then iflag=2 return endif k=index(3,iabs(elist(jj))) it=tlist(jj) call eleswp(it,k,itnode,itedge,ibedge,iord,ndof,itdof, + lenb,bump,e,iseed,vx,vy,isw,1,ksw) 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.0e0 do 60 j=ks1+1,len1 qq=geom(ii,vlist(j-1),vlist(j+1),vx,vy) if(qq.le.0.0e0) 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.0e0) then iflag=3 return endif k=index(3,iabs(elist(jj))) it=tlist(jj) call eleswp(it,k,itnode,itedge,ibedge,iord,ndof,itdof, + lenb,bump,e,iseed,vx,vy,isw,1,ksw) call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) go to 50 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eleswp(itri,iedge,itnode,itedge,ibedge, + iord,ndof,itdof,lenb,bump,e,iseed,vx,vy,isw,jsw,ksw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),iseed(*), 1 ibedge(2,*),itdof(ndof,*),idof(10),kdof(10) real + bump(lenb,*),e(*),vx(*),vy(*) save index data index/1,2,3,2,3,1,3,1,2/ c c elementary edge swap c ktri=itedge(iedge,itri)/4 kedge=itedge(iedge,itri)-4*ktri ie2=index(2,iedge) ie3=index(3,iedge) ke2=index(2,kedge) ke3=index(3,kedge) c if(itnode(4,itri).ne.itnode(4,ktri)) stop 6016 if(itnode(5,itri).ne.itnode(5,ktri)) stop 6006 c itnode(ie2,itri)=itnode(kedge,ktri) itnode(ke2,ktri)=itnode(iedge,itri) itedge(iedge,itri)=itedge(ke3,ktri) itedge(kedge,ktri)=itedge(ie3,itri) itedge(ie3,itri)=4*ktri+ke3 itedge(ke3,ktri)=4*itri+ie3 c c fixup neighboring elements c ltri=itedge(iedge,itri)/4 if(ltri.gt.0) then ledge=itedge(iedge,itri)-4*ltri itedge(ledge,ltri)=4*itri+iedge else ledge=-itedge(iedge,itri) if(ibedge(1,ledge)/4.eq.ktri) then ibedge(1,ledge)=4*itri+iedge else ibedge(2,ledge)=4*itri+iedge endif endif ltri=itedge(kedge,ktri)/4 if(ltri.gt.0) then ledge=itedge(kedge,ktri)-4*ltri itedge(ledge,ltri)=4*ktri+kedge else ledge=-itedge(kedge,ktri) if(ibedge(1,ledge)/4.eq.itri) then ibedge(1,ledge)=4*ktri+kedge else ibedge(2,ledge)=4*ktri+kedge endif endif c c fixup bump c if(isw.eq.1) then do m=1,lenb bump(m,itri)=(bump(m,itri)+bump(m,ktri))/2.0e0 bump(m,ktri)=bump(m,itri) enddo e(itri)=tqual(itri,itnode,vx,vy,lenb,bump,iord) e(ktri)=tqual(ktri,itnode,vx,vy,lenb,bump,iord) endif c c fixup iseed c if(jsw.eq.1) then iseed(itnode(ie3,itri))=4*itri+ie3 iseed(itnode(ke3,ktri))=4*ktri+ke3 endif c c fixup itdof c if(ksw.eq.1) then call l2gmap(itri,idof,ndof,itdof) call l2gmap(ktri,kdof,ndof,itdof) itdof(ie2,itri)=kdof(kedge) itdof(ke2,ktri)=idof(iedge) if(iord.eq.2) then itdof(iedge+3,itri)=kdof(ke3+3) itdof(ie3+3,itri)=kdof(kedge+3) itdof(kedge+3,ktri)=idof(ie3+3) itdof(ke3+3,ktri)=idof(iedge+3) else if(iord.eq.3) then itdof(2*iedge+2,itri)=kdof(2*ke3+2) itdof(2*iedge+3,itri)=kdof(2*ke3+3) itdof(2*ie3+2,itri)=idof(10) itdof(2*ie3+3,itri)=kdof(10) itdof(10,itri)=idof(2*iedge+3) itdof(2*kedge+2,ktri)=idof(2*ie3+2) itdof(2*kedge+3,ktri)=idof(2*ie3+3) itdof(2*ke3+2,ktri)=kdof(10) itdof(2*ke3+3,ktri)=idof(10) itdof(10,ktri)=idof(2*iedge+2) endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + list,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),list(*),index(3,3), 1 ibedge(2,*) 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 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cedge5(nbf,itedge,ibedge,isw) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,list,iflag) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tgen(ip,rp,vx,vy,xm,ym,itnode,ibndry,jb,hloc, + ipoly,itedge,irgn,itptr,ivptr,irptr,list,llist) c implicit real (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(*) real + vx(*),vy(*),xm(*),ym(*),rp(100),hloc(*) 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(83) maxv=ip(84) maxb=ip(86) 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.0e0.or.rp(15).gt.1.0e0) rp(15)=1.0e0 rp(16)=amax1(1.5e0,rp(16)) rp(16)=amin1(2.5e0,rp(16)) eps=8.0e0*ceps(ibit) rp(51)=eps rp(76)=sqrt(3.0e0)/2.0e0-eps rp(77)=1.0e0/4.0e0-eps call xybox(nbr,vx,vy,xm,ym,ibndry, + rp(87),rp(88),rp(89),rp(90),rp(78)) c c compute jb c ibdy=nvr+2*nbr+2 inum=ibdy+nvr iornt=inum+nbr call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,1, + jb,list,list(ibdy),list(inum),list(iornt),iflag) if(iflag.ne.0) return c c refine boundary edges c call lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,xm,ym,itnode, + ibndry,jb,ipoly,hloc,iflag) if(iflag.ne.0) go to 100 c c compute jb again c ibdy=nvr+2*nbr+2 inum=ibdy+nvr iornt=inum+nbr call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,1, + jb,list,list(ibdy),list(inum),list(iornt),iflag) if(iflag.ne.0) return c c compute local h c nlist=llist/2 call sethl(nvr,nbr,ntr,vx,vy,xm,ym,itnode,jb, + ibndry,ipoly,hloc,rp,list,nlist,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 compute jb a third time c ibdy=nvr+2*nbr+2 inum=ibdy+nvr iornt=inum+nbr call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,1, + jb,list,list(ibdy),list(inum),list(iornt),iflag) if(iflag.ne.0) return 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,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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tseg(ns,nvr,ntr,maxv,vx,vy,itnode, + ibndry,itedge,ipoly,irptr,rp,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),irptr(*), 1 ipoly(3,*),itedge(3,*),index(3,3) real + 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.0e0 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.0e0 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 c** if(jchop.eq.0) call drgrdx(vx,vy,nvr,1,ntr,itnode) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine csym(nsr,ns,nvr,ntr,maxv,vx,vy,itnode,itedge, + ipoly,irgn,itptr,ivptr,irptr,rp,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),irgn(5,*),itptr(*),ivptr(*),irptr(*), 1 ipoly(3,*),index(3,3),itedge(3,*) real + 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.0e0 else m1=1 m2=2 sn=1.0e0 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=84 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=83 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cequv(nvr,nbr,ntr,itnode,jb,ibndry,iequv,isw,iflag) c implicit real (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 if(isw.eq.0) return 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sethl(nvr,nbr,ntr,vx,vy,xm,ym,itnode,jb, + ibndry,iequv,hloc,rp,list,llist,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jb(*),ibndry(6,*),iequv(*),list(2,*) real + vx(*),vy(*),hloc(*),rp(100),xm(*),ym(*), 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.0e-3 iflag=0 eps=rp(51) grade=rp(16) hmax=rp(78)*rp(15) c c initialize iequv c call cequv(nvr,nbr,ntr,itnode,jb,ibndry,iequv,1,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=sqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+ + (vy(j1)-vy(j2))*(vy(j1)-vy(j2))) endif hloc(iequv(j1))=amin1(d,hloc(iequv(j1))) hloc(iequv(j2))=amin1(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.0e0 p(2)=(vy(iv)+vy(jv))/2.0e0 dp(1)=(vx(jv)-vx(iv))/2.0e0 dp(2)=(vy(jv)-vy(iv))/2.0e0 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(abs(al(1)).ge.1.0e0+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.0e0 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=sqrt(dp(1)*dp(1)+dp(2)*dp(2)) endif r=((grade-1.0e0)*d+hloc(iequv(iv)))/grade if(r.lt.hloc(iequv(jv))) then ratio=amax1(ratio,hloc(iequv(jv))/r) hloc(iequv(jv))=r endif enddo c c now check edge-vertex pairs c if(ratio-1.0e0.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.0e0 dp(2)=(vy(jv)-vy(iv))/2.0e0 dq(1)=dp(2) dq(2)=-dp(1) d=sqrt(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.0e0 p(2)=(vy(iv)+vy(jv))/2.0e0 dd=2.0e0*d endif c c check length of edge ie1 c r=((grade-1.0e0)*dd+hloc(iequv(iv)))/grade if(r.lt.hloc(iequv(jv))) then ratio=amax1(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*abs(al(1)) fr=(ang(1)-theta(1))/(theta(2)-theta(1)) if(iv.ne.ibndry(1,ie1)) fr=1.0e0-fr else call lil(p,dp,q,dq,al,jflag) z=d*abs(al(2)) fr=(al(1)+1.0e0)/2.0e0 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.0e0)*z+ht)/grade r=amin1(r,z) if(r.ge.hb) go to 170 c c nearer to iv c if(fr.lt.0.25e0) then rj=((grade-1.0e0)*fr*dd+r)/grade rj=amin1(rj,hloc(iequv(jv))) ri=rj+(r-rj)/(1.0e0-fr) ri=amax1(r/grade,ri) ri=amin1(ri,hloc(iequv(iv))) rj=((grade-1.0e0)*dd+ri)/grade rj=amin1(rj,hloc(iequv(jv))) c c nearer to jv c else if(fr.gt.0.75e0) then ri=((grade-1.0e0)*(1.0e0-fr)*dd+r)/grade ri=amin1(ri,hloc(iequv(iv))) rj=ri+(r-ri)/fr rj=amax1(r/grade,rj) rj=amin1(rj,hloc(iequv(jv))) ri=((grade-1.0e0)*dd+rj)/grade ri=amin1(ri,hloc(iequv(iv))) c c middle of interval c else ri=amin1(r,hloc(iequv(iv))) rj=ri+(r-ri)/fr rj=amin1(rj,z,hloc(iequv(jv))) endif c ratio=amax1(ratio,hloc(iequv(iv))/ri) hloc(iequv(iv))=amin1(ri,hloc(iequv(iv))) ratio=amax1(ratio,hloc(iequv(jv))/rj) hloc(iequv(jv))=amin1(rj,hloc(iequv(jv))) else c c the case where hloc at vertex kv is bigger c r=((grade-1.0e0)*z+hb)/grade r=amin1(r,z) if(r.lt.ht) then ratio=amax1(ratio,hloc(iequv(kv))/r) hloc(iequv(kv))=r endif endif 170 continue if(ratio-1.0e0.le.tol) go to 190 enddo 190 do i=1,nvr hloc(i)=hloc(iequv(i)) enddo return 200 iflag=82 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine invv(ntr,nvr,nbr,maxv,maxb,vx,vy,hloc,xm,ym,rp, + ibndry,itnode,list,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),list(*) real + vx(*),vy(*),hloc(*),xm(*),ym(*),rp(100) c c divide user specified edges c iflag=0 pi=3.141592653589793e0 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=84 return endif if(nbr+np.gt.maxb) then iflag=85 return endif c c add new points on circular arc c if(np.gt.0) then nvsave=nvr dt=theta2-theta1 q=0.0e0 do j=1,np q=q+h h=h*al arg=(theta1+q*dt)*pi nvr=nvr+1 vx(nvr)=xc+radius*cos(arg) vy(nvr)=yc+radius*sin(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=sqrt((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=84 return endif if(nbr+np.gt.maxb) then iflag=85 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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mktri0(ntr,nvr,nbr,ncr,vx,vy,xm,ym,ibndry,irptr,jb, + itnode,itedge,vindex,list,llist,maxt,irgn,iflag) c implicit real (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) real + vx(*),vy(*),xm(*),ym(*) 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 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine drgrdx(vx,vy,nv,nt1,nt2,itnode) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) real + vx(*),vy(*),x(4),y(4),z(4),red(6),green(6),blue(6) save red,green,blue data red/1.0e0,0.0e0,1.0e0,0.0e0,0.0e0,1.0e0/ data green/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,1.0e0/ data blue/1.0e0,0.0e0,0.0e0,1.0e0,0.0e0,0.0e0/ common /atest5/idevce c idevce=2 call pltutl(6,red,green,blue) call pframe(5) 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=amin1(ax,vx(itnode(j,i))) bx=amax1(bx,vx(itnode(j,i))) ay=amin1(ay,vy(itnode(j,i))) by=amax1(by,vy(itnode(j,i))) enddo enddo dx=bx-ax dy=by-ay dd=amax1(dx,dy) scale=0.9e0/dd xshift=0.5e0-scale*(ax+bx)/2.0e0 yshift=0.5e0-scale*(ay+by)/2.0e0 do i=1,4 z(i)=0.0e0 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 pframe(-5) call pltutl(-1,red,green,blue) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine drskx(vx,vy,nb1,nb2,ibndry) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*) real + vx(*),vy(*),x(4),y(4),z(4),red(6),green(6),blue(6) save red,green,blue data red/1.0e0,0.0e0,1.0e0,0.0e0,0.0e0,1.0e0/ data green/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,1.0e0/ data blue/1.0e0,0.0e0,0.0e0,1.0e0,0.0e0,0.0e0/ common /atest5/idevce c idevce=2 call pltutl(6,red,green,blue) call pframe(5) c write(6,*) 'nb',nb1,nb2 ax=vx(ibndry(1,nb1)) bx=ax ay=vy(ibndry(1,nb1)) by=ay do i=nb1,nb2 do j=1,2 ax=amin1(ax,vx(ibndry(j,i))) bx=amax1(bx,vx(ibndry(j,i))) ay=amin1(ay,vy(ibndry(j,i))) by=amax1(by,vy(ibndry(j,i))) enddo enddo dx=bx-ax dy=by-ay dd=amax1(dx,dy) scale=0.9e0/dd xshift=0.5e0-scale*(ax+bx)/2.0e0 yshift=0.5e0-scale*(ay+by)/2.0e0 do i=1,4 z(i)=0.0e0 enddo do i=nb1,nb2 do j=1,2 x(j)=vx(ibndry(j,i))*scale+xshift y(j)=vy(ibndry(j,i))*scale+yshift enddo call pline(x,y,z,2,2) enddo c call pframe(-5) call pltutl(-1,red,green,blue) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine drgrdz(ibegin,iend,index,vx,vy,nt1,nt2,itnode) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(*) real + vx(*),vy(*),x(5),y(5),z(5),red(6),green(6),blue(6) save red,green,blue data red/1.0e0,0.0e0,1.0e0,0.0e0,0.0e0,1.0e0/ data green/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,1.0e0/ data blue/1.0e0,0.0e0,0.0e0,1.0e0,0.0e0,0.0e0/ 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=amin1(ax,vx(index(i))) bx=amax1(bx,vx(index(i))) ay=amin1(ay,vy(index(i))) by=amax1(by,vy(index(i))) enddo dx=bx-ax dy=by-ay dd=amax1(dx,dy) scale=0.9e0/dd xshift=0.5e0-scale*(ax+bx)/2.0e0 yshift=0.5e0-scale*(ay+by)/2.0e0 j=iend h=.005e0 do i=1,5 z(i)=0.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tswap(it1,it2,itnode,itedge) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tchop(ichop,kv,vx,vy,rp,itedge,ibndry,ipoly) c implicit real (a-h,o-z) implicit integer (i-n) integer + itedge(3,*),ibndry(6,*),ipoly(3,*),index(3,3) real + 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=amin1(1.0e0,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.0e0) ichop=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cchop(kv,ntr,ns,irptr,itnode,itedge,ipoly) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tcnvx(icnvx,ns,irptr,itnode,vx,vy,rp,nvr,maxv,ipoly) c implicit real (a-h,o-z) implicit integer (i-n) integer + irptr(*),itnode(5,*),ipoly(3,*) real + 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.0e0 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.0e0 y=0.0e0 do i=1,num x=x+vx(kv) y=y+vy(kv) kv=ipoly(1,kv) enddo nvr1=nvr+1 vx(nvr1)=x/float(num) vy(nvr1)=y/float(num) c c check geometry c do i=1,num g=geom(kv,ipoly(1,kv),nvr1,vx,vy) currnt=amin1(currnt,g/qual) if(currnt.le.best) return kv=ipoly(1,kv) enddo if(currnt.le.0.0e0) return icnvx=1 if(currnt.lt.1.0e0) icnvx=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ccnvx(ns,nvr,ntr,maxv,vx,vy,itnode,irptr,ipoly,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + irptr(*),itnode(5,*),ipoly(3,*) real + 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=83 return endif if(nvr+1.gt.maxv) then iflag=84 return endif c c compute centroid c kv=itnode(1,it1) x=0.0e0 y=0.0e0 do i=1,num x=x+vx(kv) y=y+vy(kv) kv=ipoly(1,kv) enddo nvr=nvr+1 vx(nvr)=x/float(num) vy(nvr)=y/float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tlink(ilink,kv,kk,vx,vy,ipoly,rp,itnode,itedge) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipoly(3,*),itnode(5,*),itedge(3,*),index(3,3) real + 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.0e0/20.0e0 angmax=2.0e0-angmin ilink=0 c c kk=0 currnt=0.0e0 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=sqrt(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=amin1(a1,a2,a3,a4) aamax=amax1(a1,a2,a3,a4) if(aamin.lt.angmin.or.aamax.gt.angmax) go to 10 testkm=amin1(1.0e0,aamin/angmn) c if(ka.eq.kf.or.kb.eq.ks) testkm=testkm/2.0e0 if(testkm.gt.currnt) then c c km is the best point found so far c currnt=testkm kk=km if(currnt.eq.1.0e0) 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.0e0) ilink=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rlink(hl,hr,d,rp,xl,yl,xr,yr,vx,vy,nvr,maxv,iflag) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=84 return endif if(np.eq.0) return qq=0.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clink(kv,kk,ns,nvr,maxv,ntr, + vx,vy,ipoly,irptr,itnode,itedge,rp,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipoly(3,*),irptr(*),itnode(5,*),itedge(3,*),index(3,3) real + 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=sqrt((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.0e0)/grade theta=(hv-hk)/(2.0e0*ds) if(abs(theta).gt.0.4e0) go to 60 fv=0.5e0-theta fk=0.5e0+theta hm=(ds+hv+hk)/2.0e0 hmin=fv*hk+fk*hv hm=amin1(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.0e0) then al1=-al(1)/fv ht=hv else al1=al(1)/fk ht=hk endif if(al1.ge.1.0e0) go to 45 al2=abs(al(2))*ds if(al2.gt.hm*(1.0e0-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.0e0-al1) if(hz.le.0.0e0) go to 45 hm=amin1(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=84 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=83 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cedge2(nvr,nt1,nt2,nbf,itnode,itedge,list) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eswap(nt1,nt2,nvr,itnode,itedge,ipoly,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3),ipoly(3,*) real + vx(*),vy(*),qmin0(4),fract0(4) save index,fract0,qmin0 data index/1,2,3,2,3,1,3,1,2/ data fract0/1.0e0, 1.0e0, 0.8e0, 0.6e0/ data qmin0 /1.0e0, 1.0e0, 0.6e0, 0.3e0/ 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.0e0-cang(kb,kv,ka,vx,vy)*3.0e0 iq=max0(int(q+0.5e0)-1,0) ipoly(3,kv)=min0(5,iq) kv=ipoly(1,kv) enddo c*** if(kv.ne.j2) call drgrdx(vx,vy,len,nt1,nt2,itnode) 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=amin1(q2,q3) qik=amin1(qi,qk) if(q23.lt.amin1(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mfe0(nv1,nv2,nt1,nt2,itnode,itedge,vx,vy,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + vlist(50),itnode(5,*),itedge(3,*),list(*),index(3,3) real + 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.0e-3 s3=sqrt(3.0e0)/2.0e0 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.0e0 qmin2=1.0e0 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.0e0 ymk=(vy(kb)+vy(ka))/2.0e0 c dxk=dxk*s3 dyk=dyk*s3 xmax=xmk-dyk ymax=ymk+dxk rk=sqrt(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.0e0 yml=(vy(lb)+vy(la))/2.0e0 rl=sqrt(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.0e0 if(a.gt.0.0e0) beta=(b+sqrt(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*amax1(abs(xmin),abs(xmax), 1 abs(ymin),abs(ymax)) 85 zx=abs(xmin-xmax)/(abs(xmin)+abs(xmax)+eps) zy=abs(ymin-ymax)/(abs(ymin)+abs(ymax)+eps) if(amax1(zx,zy).lt.tol) then vx(i)=xmin vy(i)=ymin else vx(i)=(xmin+xmax)/2.0e0 vy(i)=(ymin+ymax)/2.0e0 qq=1.0e0 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=amin1(qq,q) enddo xmin=vx(i) ymin=vy(i) qmin=qq go to 85 endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine liarc(p,dp,q,t,r,npts,al,ang,eps) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.141592653589793e0 rr=abs(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.0e0 b=-(x*dx+y*dy) a=dx*dx+dy*dy disc=b*b-a*c c if(disc.gt.0.0e0) then d=sqrt(disc) npts=2 if(b.ge.0.0e0) 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.0e0) then npts=1 al(1)=b/a else npts=0 return endif c c compute theta values c tmin=amin1(t(1),t(2)) tmax=amax1(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=amin1(1.0e0,x) x=amax1(-1.0e0,x) th=acos(x)/pi if(y.lt.0.0e0) th=-th do j=1,5 theta=th+float(j-3)*2.0e0 if(abs(theta-tmin).le.tol) theta=tmin if(theta.ge.tmin) go to 60 enddo 60 if(abs(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lil(p,dp,q,dq,al,iflag) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0) 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.0e0 al(2)=0.0e0 iflag=1 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function chloc(kb,kv,ka,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.25e0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function geom(kv,kb,ka,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.464101616e0/dd return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function ch(kv,kb,ka,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=sqrt(abs(x2*y1-x1*y2)) d1=sqrt(x1**2+y1**2)/d0 d2=sqrt(x2**2+y2**2)/d0 d3=sqrt((x1-x2)**2+(y1-y2)**2)/d0 ch=d0*d1*d2*d3 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function cangmx(kb,kv,ka,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + vx(*),vy(*),h(3) save index,pi data index/1,2,3,2,3,1,3,1,2/ data pi/3.141592653589793e0/ 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.0e0)/(2.0e0*sqrt(h(j2)*h(j3))) q=amin1(1.0e0,q) q=amax1(-1.0e0,q) cangmx=acos(q)/pi return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function cangmn(kb,kv,ka,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + vx(*),vy(*),h(3) save index,pi data index/1,2,3,2,3,1,3,1,2/ data pi/3.141592653589793e0/ 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.0e0)/(2.0e0*sqrt(h(j2)*h(j3))) q=amin1(1.0e0,q) q=amax1(-1.0e0,q) cangmn=acos(q)/pi return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function cang(kb,kv,ka,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) real + vx(*),vy(*) save pi data pi/3.141592653589793e0/ 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/sqrt(xx**2+yy**2) s=amin1(1.0e0,s) s=amax1(-1.0e0,s) cang=acos(s)/pi if(yy.le.0.0e0) cang=2.0e0-cang return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function cang1(ibef,icom,iaft,ieb,iea, + vx,vy,xm,ym) c implicit real (a-h,o-z) implicit integer (i-n) real + 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(ieb.gt.0) then x(1)=vx(ibef) y(1)=vy(ibef) x(2)=vx(icom) y(2)=vy(icom) x(3)=xm(ieb) y(3)=ym(ieb) a1=cang(i1,i2,i3,x,y) if(a1.lt.1.0e0) then a0=a0+1.0e0/2.0e0-a1 else a0=a0+3.0e0/2.0e0-a1 endif endif if(iea.gt.0) then x(1)=xm(iea) y(1)=ym(iea) 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.0e0) then a0=a0+1.0e0/2.0e0-a1 else a0=a0+3.0e0/2.0e0-a1 endif endif cc if(a0.lt.0.0e0) a0=a0+2.0e0 cc if(a0.gt.2.0e0) a0=a0-2.0e0 cang1=a0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dvpram(hl,hr,d,rp,al,h,np) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0-rp(51) grade=rp(16) np=0 al=1.0e0 h=1.0e0 hmax=amax1(hl,hr)/d if(hmax.ge.epsm) return hmin=amin1(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=amin1(hmin*grade,hmax) q=q+hmin if(q.lt.epsm) go to 3 if(q.gt.1.0e0+hmax/2.0e0) 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(abs(r-1.0e0).lt.1.e-3) then h=1.0e0/float(np+1) else al=r**(1.0e0/float(np+1)) al=amin1(grade,al) al=amax1(1.0e0/grade,al) h=(al-1.0e0)/(al**(np+1)-1.0e0) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,xm,ym,itnode, + ibndry,jb,iequv,hloc,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + jb(*),itnode(5,*),ibndry(6,*),iequv(*) real + vx(*),vy(*),hloc(*),rp(100),xm(*),ym(*) c c look for long edges connected to only short edges and divide c hmax=rp(78)*rp(15) grade=rp(16) pi=3.141592653589793e0 factor=1.1e0 c c initialize iequv c call cequv(nvr,nbr,ntr,itnode,jb,ibndry,iequv,1,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=sqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+ + (vy(j1)-vy(j2))*(vy(j1)-vy(j2))) endif if(hloc(iequv(j1)).le.0.0e0) then hloc(iequv(j1))=d else hloc(iequv(j1))=amin1(d,hloc(iequv(j1))) endif if(hloc(iequv(j2)).le.0.0e0) then hloc(iequv(j2))=d else hloc(iequv(j2))=amin1(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=sqrt((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.0e0)/grade theta=(hloc(j1)-hloc(j2))/(2.0e0*ds) if(abs(theta).gt.0.4e0) go to 120 f1=0.5e0-theta f2=0.5e0+theta hmm=(ds+hloc(j1)+hloc(j2))/2.0e0 hmin=f1*hloc(j2)+f2*hloc(j1) hmm=amin1(hmm,hmax) if(hmm.lt.hmin*factor) go to 120 c c add new point, edge c if(nvr.ge.maxv) then iflag=84 return endif nvr=nvr+1 if(jc.gt.0) then theta=(f1*theta2+f2*theta1)*pi vx(nvr)=xm(jc)+radius*cos(theta) vy(nvr)=ym(jc)+radius*sin(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=86 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine makjb(nvf,nbf,ntf,vx,vy,xm,ym,ibndry,itnode,jbsw, + jb,list,ibdy,num,orient,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),list(*),ibdy(*),orient(*),num(*),jb(*), 1 itnode(5,*) real + vx(*),vy(*),xm(*),ym(*) c c compute jb 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 ibdy(i)=0 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 num(i)=2 else num(i)=1 ibdy(ibndry(1,i))=ibdy(ibndry(1,i))-1 ibdy(ibndry(2,i))=ibdy(ibndry(2,i))-1 endif enddo list(1)=nvf+2 do i=1,nvf list(i+1)=list(i)+list(i+1) if(ibdy(i).ne.0) then if(ibdy(i).ne.-2) then iflag=-48 return endif endif enddo c c order boundary edges first c do i=1,nbf if(ibndry(4,i).ne.0) then do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo endif enddo do i=1,nbf if(ibndry(4,i).eq.0) then do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo endif enddo do i=nvf,2,-1 list(i)=list(i-1) enddo list(1)=nvf+2 c c now we order the boundary edges as after/before c find lower left vertex from among the remaining vertices c (we need this in case there are disconnected regions) c nseg=0 10 left=0 do i=1,nvf if(ibdy(i).lt.0) then if(left.eq.0) then left=i else if(vx(i).lt.vx(left)) then left=i else if(vx(i).eq.vx(left).and.vy(i).lt.vy(left)) then left=i endif endif enddo if(left.eq.0) go to 30 nseg=nseg+1 ii=list(left) ibef=list(ii+1) iaft=list(ii) ivb=ibndry(1,ibef)+ibndry(2,ibef)-left iva=ibndry(1,iaft)+ibndry(2,iaft)-left qq=geom(ivb,left,iva,vx,vy) if(qq.lt.0.0e0) then itemp=list(ii) list(ii)=list(ii+1) list(ii+1)=itemp endif iv=left 20 ibdy(iv)=nseg ii=list(iv) iaft=list(ii) jv=ibndry(1,iaft)+ibndry(2,iaft)-iv jj=list(jv) if(list(jj).eq.iaft) then list(jj)=list(jj+1) list(jj+1)=iaft endif if(ibndry(4,list(jj)).eq.0) stop 5567 iv=jv if(iv.ne.left) go to 20 go to 10 c c compute jb based on lower left vertex c this loop is needed to compute orient correctly c 30 do i=1,nseg orient(i)=0 enddo jb(1)=nbf+2 c c find lower left vertex c 40 left=0 do i=1,nbf if(num(i).gt.0) then if(left.eq.0) left=ibndry(1,i) do k=1,2 j=ibndry(k,i) if(vx(j).lt.vx(left)) then left=j else if(vx(j).eq.vx(left).and. + vy(j).lt.vy(left)) then left=j endif enddo endif enddo c c find starting edge c if(left.eq.0) go to 70 i1=list(left) i2=list(left+1)-1 icur=0 jcur=0 do ii=i1,i2 i=list(ii) if(num(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,vx,vy) if(qq.lt.0.0e0) then jcur=icur icur=i endif endif endif enddo if(jcur.eq.0) then iflag=-43 return endif c c orient(i) = 1 if counterclockwise c orient(i) = -1 if clockwise (this happens for holes in inext) c if(ibndry(4,icur).ne.0) then iseg=ibdy(left) orient(iseg)=1 endif c ntf=ntf+1 ii=jb(ntf) istart=icur iv=left 50 if(num(icur).le.0) then iflag=-53 return endif num(icur)=num(icur)-1 jb(ii)=icur next=inext(iv,icur,list,ibndry,ibdy,orient,vx,vy,xm,ym) if(next.eq.istart) then jb(ntf+1)=ii+1 go to 40 else iv=ibndry(1,icur)+ibndry(2,icur)-iv icur=next ii=ii+1 go to 50 endif c c c 70 ishift=ntf-nbf do i=jb(1),jb(ntf+1)-1 jb(i+ishift)=jb(i) enddo do i=1,ntf+1 jb(i)=jb(i)+ishift enddo if(jbsw.eq.1) go to 80 c c make an itnode array from the given jb array c do i=1,ntf i1=jb(i) i2=jb(i+1)-1 ie1=jb(i1) ie2=jb(i2) iv=ibndry(1,ie1) jv=ibndry(2,ie1) if(iv.ne.ibndry(1,ie2).and.iv.ne.ibndry(2,ie2)) iv=jv itnode(1,i)=iv itnode(2,i)=ie1 itnode(3,i)=0 itnode(4,i)=1 itnode(5,i)=i enddo return c c make jb for the specified itnode array c 80 jb(1)=ntf+2 do i=1,nbf if(ibndry(4,i).eq.0) then num(i)=2 else num(i)=1 endif enddo do i=1,ntf ii=jb(i) iv=itnode(1,i) icur=itnode(2,i) istart=icur 90 if(num(icur).le.0) then iflag=-53 return endif num(icur)=num(icur)-1 jb(ii)=icur next=inext(iv,icur,list,ibndry,ibdy,orient,vx,vy,xm,ym) if(next.eq.istart) then jb(i+1)=ii+1 else iv=ibndry(1,icur)+ibndry(2,icur)-iv icur=next ii=ii+1 go to 90 endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function inext(iv,icur,list,ibndry,ibdy,orient, + vx,vy,xm,ym) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),list(*),ibdy(*),orient(*) real + vx(*),vy(*),xm(*),ym(*) c eps=1.0e-4 jv=ibndry(1,icur)+ibndry(2,icur)-iv j1=list(jv) j2=list(jv+1)-1 c c simple case c if(j2.eq.j1+1) then inext=list(j1) if(inext.eq.icur) inext=list(j2) return endif c c general case c inext=0 ang=3.0e0 do kk=j2,j1,-1 k=list(kk) if(k.ne.icur) then kv=ibndry(1,k)+ibndry(2,k)-jv ic3=ibndry(3,icur) kc3=ibndry(3,k) if(max0(ic3,kc3).gt.0) then aa=cang1(iv,jv,kv,ic3,kc3,vx,vy,xm,ym) else aa=cang(iv,jv,kv,vx,vy) endif c c this section handles roundoff error problems at cracks c if(ibndry(4,k).ne.0) then iseg=ibdy(kv) if(orient(iseg).eq.0) orient(iseg)=-1 if(ibndry(4,icur).ne.0) then if(aa.lt.eps) aa=2.0e0-eps else a0=abs(aa-ang) if(a0.lt.eps.and.kk.eq.j1) then if(orient(iseg).eq.1) then if(inext.eq.list(j1+1)) then aa=ang-eps endif else if(inext.eq.list(j1+1)) then aa=ang+eps endif endif endif endif endif c if(aa.lt.ang) then ang=aa inext=k endif endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rgen(ip,vx,vy,xm,ym,itnode,ibndry,itedge,ibc, + iequv,vz,jv,area,lenjv,rp,itag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),iequv(*), 1 itedge(3,*),jv(3,*),ibc(*),itag(*) real + 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) ncf=ip(3) nbf=ip(4) c maxt=ip(83) maxv=ip(84) maxc=ip(85) maxb=ip(86) c c construct the jv data structure c call cjv(nvf,ntf,nbf,itnode,itedge,ibndry,vx,vy,vz, + jv,area,maxv,lenjv,ibc,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,maxb,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+nvf.gt.lenjv) then ip(25)=82 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),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,vx,vy,xm,ym,jv,rp,ibndry,iequv) 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(min0(irgn,jrgn).gt.0) then iptr=j-1 call chkpth(n,iptr,jv(1,l0),jv(1,l1), + vx,vy,xm,ym,ncf,maxc,jv,rp, 1 ibndry,nbf,maxb,iflag) if(iflag.ne.0) then ip(25)=iflag return endif endif enddo endif enddo ip(1)=ntr ip(2)=nvf ip(3)=ncf ip(4)=nbf l3=l2+nvf/3+1 call cds(ip,jv,itnode,ibndry,jv(1,l1),vx,vy,xm,ym,itedge, + jv(1,l0),itag,jv(1,l2),jv(1,l3)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xybox(nbf,vx,vy,xm,ym,ibndry, + xmin,xmax,ymin,ymax,diam) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*) real + 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=amin1(xmin,vx(ibndry(1,i)),vx(ibndry(2,i))) ymin=amin1(ymin,vy(ibndry(1,i)),vy(ibndry(2,i))) xmax=amax1(xmax,vx(ibndry(1,i)),vx(ibndry(2,i))) ymax=amax1(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=sqrt(x1**2+y1**2) if(x1*x2.lt.0.0e0) then al=x1/(x1-x2) if(y1+al*(y2-y1).gt.0.0e0) then ymax=amax1(ymax,yc+rad) else ymin=amin1(ymin,yc-rad) endif endif if(y1*y2.lt.0.0e0) then al=y1/(y1-y2) if(x1+al*(x2-x1).gt.0.0e0) then xmax=amax1(xmax,xc+rad) else xmin=amin1(xmin,xc-rad) endif endif endif enddo c c compute diameter c diam=sqrt((xmax-xmin)**2+(ymax-ymin)**2) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,vz,xm,ym, + cx,cy,cz,zmin,zmax) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*), 1 index(3,3) real + 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=amin1(zmin,zz) zmax=amax1(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.0e0) go to 10 r=sqrt(((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(amax1(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=amin1(zmin,zz) zmax=amax1(zmax,zz) endif xx=xm(k)-zx*r yy=ym(k)-zy*r enddo 10 continue c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rinit(ip,rp,itnode,ibndry,vx,vy,vz,xm,ym,u,z, + itedge,ibedge,iequv,list,ndof,itdof,qxy) c implicit real (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(*),corner(9),tlist(500), 2 elist(500),vlist(500),blist(500),idof(10),itdof(ndof,*) real + vx(*),vy(*),vz(*),xm(*),ym(*),u(*),z(*),rp(100), 1 qv(5,3),c(3,3) save index,corner,c external qxy data index/1,2,3,2,3,1,3,1,2/ data corner/0,0,1,0,1,0,1,0,1/ data c/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,0.0e0, + 0.0e0,0.0e0,1.0e0/ c c tolerances for removing points c hmin=amax1(rp(51),rp(17)) hmin=amin1(0.1e0,hmin) rp(17)=hmin c c other tolerances c rp(81)= tola (tola for removing points in chkdg2) c rp(82)= arcmin (chkpth) c rp(83)= arcmax (chkpth) 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.0e-2 arcmin=1.0e0/64.0e0-1.0e-2 rp(82)=arcmin arcmax=1.0e0/4.0e0+1.0e-2 rp(83)=arcmax angmin=1.0e-3 tolz=1.e-5 rp(84)=tolz rp(85)=8.0e0 ip(25)=0 c c initialize vz c ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=ip(7) nrgn=max0(ip(23),0) iadapt=ip(20) maxv=ip(84) ngf=ip(77) ndf=ip(5) maxd=ip(89) iord=ip(26) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,list,iflag) if(iflag.ne.0) then ip(25)=iflag return endif call cequv1(nvf,nbf,ibndry,iequv,1) c if(iadapt.ge.0) then do i=1,ntf call l2gmap(i,idof,ndof,itdof) do j=1,3 ivj=itnode(j,i) vz(ivj)=u(idof(j)) enddo enddo else c c user supplied function c do i=1,nvf vz(i)=0.0e0 z(i)=0.0e0 enddo rl=rp(21) if(iprob.eq.6) rl=rp(46) do i=1,ntf call l2gmap(i,idof,ndof,itdof) call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + 3,qv,c,idof,iord,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=abs(x2*y3-x3*y2) do j=1,3 ivj=itnode(j,i) z(ivj)=z(ivj)+det vz(ivj)=vz(ivj)+det*qv(4,j) enddo enddo do i=1,nvf vz(i)=vz(i)/z(i) enddo endif c c find min and max function values c do i=1,nvf vz(i)=vz(iequv(i)) enddo cx=0.0e0 cy=0.0e0 cz=1.0e0 call zbox(nvf,nbf,itnode,ibndry,ibedge,vx,vy,vz,xm,ym, + cx,cy,cz,az,bz) c scale=0.0e0 nn=nrgn if(bz.gt.az) scale=1.0e0/(bz-az) c c adjust 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=int(sqrt(dx**2+dy**2)/fact) v2=(vz(itnode(index(2,j),i))-az)*scale v3=(vz(itnode(index(3,j),i))-az)*scale vmin=amin1(v2,v3) vmax=amin1(v2,v3) 10 cmin=vmin*float(nn) cmax=vmax*float(nn) minc=int(cmin)+1 if(abs(float(minc)-cmin).lt.tolz*float(minc)) + minc=minc+1 maxc=int(cmax) if(abs(float(maxc)-cmax).lt.tolz*float(maxc)) + maxc=maxc-1 if(maxc-minc.gt.ih) then nn=max0(nn-1,0) go to 10 endif enddo enddo endif scale=float(nn)*scale do i=1,nvf vz(i)=(vz(i)-az)*scale ivz=int(vz(i)+0.5e0) if(abs(float(ivz)-vz(i)).lt.tolz*float(ivz+1)) + vz(i)=float(ivz) enddo c c look for permanent edges attached to corner vertices c call cedge5(nbf,itedge,ibedge,0) call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,list,list(nvf+1),angmin,arcmax) itmax=3 do itnum=1,itmax ichng=0 do i=1,nvf if(corner(list(i)).eq.0) go to 40 call cirlst(i,itnode,itedge,ibndry,ibedge, + list(nvf+1),list,vlist,tlist,elist,blist,len) do j=1,len if(elist(j).ge.0) go to 30 c iv=vlist(j) if(vz(i).gt.vz(iv)) then cmax=vz(i) cmin=vz(iv) else cmax=vz(iv) cmin=vz(i) endif c minc=int(cmin)+1 if(abs(float(minc)-cmin).lt.tolz*float(minc+1)) + minc=minc+1 maxc=int(cmax) if(abs(float(maxc)-cmax).lt.tolz*float(maxc+1)) + maxc=maxc-1 if(minc.gt.maxc) go to 30 if(vz(i).gt.vz(iv)) then theta=(cmax-float(maxc))/(cmax-cmin) if(theta.lt.hmin) then ichng=ichng+1 vz(i)=float(maxc) endif else theta=(float(minc)-cmin)/(cmax-cmin) if(theta.lt.hmin) then ichng=ichng+1 vz(i)=float(minc) endif endif 30 enddo 40 enddo if(ichng.eq.0) go to 50 enddo 50 do i=1,nvf vz(iequv(i))=vz(i) enddo call cequv1(nvf,nbf,ibndry,iequv,0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cjv(nvf,ntf,nbf,itnode,itedge,ibndry,vx,vy,vz, + jv,area,maxv,lenjv,ibc,rp,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jv(3,*),ibc(*), 1 itedge(3,*),index(3,3) real + 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 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.0e0 do 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)=abs(x2*y3-x3*y2)/2.0e0 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=int(c(kmin))+1 if(abs(float(minc)-c(kmin)).lt.tolz*float(minc+1)) + minc=minc+1 maxc=int(c(kmax)) if(abs(float(maxc)-c(kmax)).lt.tolz*float(maxc+1)) + maxc=maxc-1 if(minc.gt.maxc) go to 20 maxm=int(c(kmid)) minm=maxm+1 if(abs(float(maxm)-c(kmid)).lt.tolz*float(maxm+1)) + maxm=maxm-1 if(abs(float(minm)-c(kmid)).lt.tolz*float(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 enddo 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=82 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 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) jv(3,ii)=0 jv(3,ii+1)=0 jv(3,ii-1)=0 enddo if(ibc(n).eq.1) then jv(1,i1-1)=0 jv(3,i1-1)=0 jv(1,i2+2)=0 jv(2,i2+2)=0 jv(3,i2+2)=0 else i=jv(1,i2) jv(1,i1-1)=i endif 80 enddo 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 add current edges in jv(3,*) c do ib=1,nbf do jj=1,2 i=ibndry(jj,ib) j=ibndry(3-jj,ib) i1=jv(1,i)+1 i2=i1+jv(2,i)-1 do k=i1,i2 if(jv(1,k).eq.j) go to 90 enddo stop 2424 90 jv(3,k)=ib if(ibc(i).eq.0) then if(k.eq.i1) jv(3,i2+1)=ib if(k.eq.i2) jv(3,i1-1)=ib endif enddo enddo 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 if(jv(3,i).gt.0) then jv(1,i)=-jv(1,i) else irgn=jv(2,i-1) jrgn=jv(2,i) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine adpt(nvf,nbf,maxb,ibndry,vx,vy,vz,xm,ym,jv,lenjv, + maxv,rp,iequv,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jv(3,*),iv(3),iequv(*) real + 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.0e-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=int(vz(n))+1 if(abs(float(minc)-vz(n)).lt.tolz*float(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=int(vz(i)) if(abs(float(maxc)-vz(i)).lt.tolz*float(maxc+1)) + maxc=maxc-1 if(minc.gt.maxc) go to 90 c iaft=jv(2,ii) ibef=jv(2,ii-1) ix=6 iedg=jv(3,ii) if(iedg.gt.0.and.min0(ibef,iaft).lt.0) then icen=ibndry(3,iedg) else icen=0 endif c c check for (curved) boundary edge c if(icen.gt.0) then if(iaft.lt.0) then iv(1)=iabs(jv(1,ii-1)) else iv(1)=iabs(jv(1,ii+1)) endif 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(icen), + ym(icen),theta(1),theta(2),radius,alen) q(1)=xm(icen) q(2)=ym(icen) gg=sqrt(gx*gx+gy*gy) dp(1)=-gx/gg dp(2)=gy/gg endif c c the main loop over contours for this edge c 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=84 return endif jv(1,nvf+1)=jv(1,nvf)+ix if(jv(1,nvf+1).gt.lenjv+1) then iflag=82 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 jv(3,l)=iedg jv(3,l+1)=iedg jv(3,l+2)=iedg jv(3,l+3)=iedg 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(3,l+3)=0 jv(1,l)=0 jv(3,l)=0 c 50 qq=(float(m)-vz(n))/dz vx(nvf)=vx(n)+qq*dx vy(nvf)=vy(n)+qq*dy vz(nvf)=float(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=float(minc-1) if(abs(qq-vz(n)).ge.tolz*(qq+1.0e0)) go to 120 if(abs(qq-vz(i)).ge.tolz*(qq+1.0e0)) 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=amax1(abs(qq-vz(ibef)),abs(qq-vz(iaft))) if(qq.le.tolz*(qq+1.0e0)) 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 ilast=iv1 jlast=jv2 do ii=i1,i2,inc iequv(ii)=j2 iequv(j2)=ii c c new edges c if(nbf+2.gt.maxb) then iflag=86 return endif do k=1,6 ibndry(k,nbf+1)=ibndry(k,i) ibndry(k,nbf+2)=ibndry(k,j) enddo ibndry(1,nbf+1)=ilast ibndry(2,nbf+1)=ii ibndry(4,nbf+1)=-(nbf+2) ibndry(1,nbf+2)=j2 ibndry(2,nbf+2)=jlast ibndry(4,nbf+2)=-(nbf+1) c c fixup jv c k1=iabs(jv(1,ilast))+1 k2=k1+iabs(jv(2,ilast))-1 if(iabs(jv(1,k1)).eq.ii) then jv(2,k1-1)=-(nbf+1) jv(3,k1)=nbf+1 else if(iabs(jv(1,k2)).ne.ii) stop 3321 jv(2,k2)=-(nbf+1) jv(3,k2)=nbf+1 endif c k1=iabs(jv(1,ii))+1 k2=k1+iabs(jv(2,ii))-1 if(iabs(jv(1,k1)).eq.ilast) then jv(2,k1-1)=-(nbf+1) jv(3,k1)=nbf+1 else if(iabs(jv(1,k2)).ne.ilast) stop 3320 jv(2,k2)=-(nbf+1) jv(3,k2)=nbf+1 endif c k1=iabs(jv(1,j2))+1 k2=k1+iabs(jv(2,j2))-1 if(iabs(jv(1,k1)).eq.jlast) then jv(2,k1-1)=-(nbf+2) jv(3,k1)=nbf+2 else if(iabs(jv(1,k2)).ne.jlast) stop 3319 jv(2,k2)=-(nbf+2) jv(3,k2)=nbf+2 endif c k1=iabs(jv(1,jlast))+1 k2=k1+iabs(jv(2,jlast))-1 if(iabs(jv(1,k1)).eq.j2) then jv(2,k1-1)=-(nbf+2) jv(3,k1)=nbf+2 else if(iabs(jv(1,k2)).ne.j2) stop 3318 jv(2,k2)=-(nbf+2) jv(3,k2)=nbf+2 endif c nbf=nbf+2 ilast=ii jlast=j2 j2=j2+jnc enddo 150 continue return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine aded(ntf,itnode,vx,vy,vz,jv,area,list, + ibc,ntr,maxt,rp,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jv(3,*),list(3,*),ibc(*), 1 loc(3),num(3),istart(3) real + 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=int(c(kmin))+1 if(abs(float(minc)-c(kmin)).lt.tolz*float(minc+1)) + minc=minc+1 maxc=int(c(kmax)) if(abs(float(maxc)-c(kmax)).lt.tolz*float(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=sqrt(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=83 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=83 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.0e0 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.0e0 q(2)=(vy(ii)+vy(j))/2.0e0 dx=vx(ii)-vx(j) dy=vy(ii)-vy(j) qd=sqrt(dx*dx+dy*dy) call lil(p,dp,q,dq,al,iflag) area(it)=abs(al(1))*(qd+pd)/2.0e0 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)=abs(al(1))*qd/2.0e0 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)+abs(x2*y3-x3*y2)/2.0e0 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.0e0) 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 do m=1,3 jv(m,kk+1)=jv(m,kk) enddo 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 jv(3,kk+1)=0 if(jv(2,k1-1).gt.0) then do m=1,3 jv(m,k1-1)=jv(m,k2) jv(m,k2+1)=jv(m,k1) enddo 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine areahp(i,len,itnode,area) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine chkrgn(itnode,jv,area,list,rp,nvf,ntr,mark,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + jv(3,*),list(3,*),itnode(5,*),mark(*),iv(10),ir(10), 1 itype(10) real + 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.0e0 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) kedg=jv(3,kk) ks=list(1,is) iv(ii)=ks ir(ii)=krgn d(ii)=sqrt((vx(is)-vx(ks))**2+(vy(is)-vy(ks))**2) if(kedg.gt.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(amax1(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.amin1(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.0e0.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.0e0.gt.d(iedge)) go to 10 mark(irgn)=-ir(iedge) else if(2.0e0*amax1(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) kedg=jv(3,kk) ks=list(1,is) iv(ii)=ks ir(ii)=krgn if(kedg.gt.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 do id=1,3 jv(id,k)=jv(id,k+1) enddo enddo if(jv(2,i1-1).gt.0) then do id=1,3 jv(id,i1-1)=jv(id,i2-1) jv(id,i2)=jv(id,i1) enddo 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tstrgn(itnode,jv,area,list,jlist,vmark, + rp,nvf,ntr,itag) c implicit real (a-h,o-z) implicit integer (i-n) integer + jv(3,*),list(3,*),itnode(5,*),itag(*),vmark(*), 1 jlist(3,*) real + 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 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 do ib=1,3 jv(ib,k)=jv(ib,k+1) enddo enddo if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2-1) jv(ib,i2)=jv(ib,i1) enddo 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine chkdg2(nvf,vx,vy,xm,ym,jv,rp,ibndry,iequv) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jv(3,*),iequv(*) real + 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.e-2 tolc=tola*4.0e0 hmin=amin1(1.0e-2,rp(17))*rp(78)/4.0e0 arcmax=rp(83) c 5 ichng=0 do 130 i=1,nvf i1=iabs(jv(1,i))+1 iv1=iabs(jv(1,i1)) iv2=iabs(jv(1,i1+1)) ideg=iabs(jv(2,i)) if(ideg.le.1) go to 120 if(ideg.gt.2) go to 130 c c figure out edges c iedg1=jv(3,i1) iedg2=jv(3,i1+1) if(iedg1.eq.0.and.iedg2.ne.0) go to 130 if(iedg2.eq.0.and.iedg1.ne.0) go to 130 ibdy=0 if(iedg1.gt.0) then if(ibndry(6,iedg1).ne.ibndry(6,iedg2)) go to 130 if(ibndry(4,iedg1).ge.0) then if(ibndry(4,iedg1).ne.ibndry(4,iedg2)) go to 130 if(ibndry(4,iedg1).gt.0) ibdy=1 else if(ibndry(4,iedg2).ge.0) go to 130 ibdy=-1 endif c c do this for i only --- iequv(i) should be the same c icen1=ibndry(3,iedg1) icen2=ibndry(3,iedg2) if(icen1.gt.0.and.icen2.le.0) go to 130 if(icen1.le.0.and.icen2.gt.0) go to 130 if(icen1.gt.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)) go to 130 call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xm(icen1),ym(icen1),theta1,theta2,r2,alen) if(abs(theta1-theta2).ge.arcmax) go to 130 endif endif c c make sure there are not just three points in this region c m1=iabs(jv(1,iv1))+1 m2=m1+iabs(jv(2,iv1))-1 do m=m1,m2 if(iabs(jv(1,m)).eq.iv2) go to 130 enddo c gg=abs(geom(iv1,i,iv2,vx,vy)) d1=sqrt((vx(iv1)-vx(i))**2+(vy(iv1)-vy(i))**2) d2=sqrt((vx(iv2)-vx(i))**2+(vy(iv2)-vy(i))**2) dmn=amin1(d1,d2) c if(iequv(i).eq.i) go to 10 j=iequv(i) if(iequv(j).ne.i) go to 130 jdeg=iabs(jv(2,j)) if(jdeg.le.1) stop 6535 if(jdeg.gt.2) go to 130 j1=iabs(jv(1,j))+1 jv1=iabs(jv(1,j1)) jv2=iabs(jv(1,j1+1)) 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 c jedg1=jv(3,j1) jedg2=jv(3,j1+1) if(jedg1.eq.0.and.jedg2.ne.0) go to 130 if(jedg2.eq.0.and.jedg1.ne.0) go to 130 jbdy=0 if(jedg1.gt.0) then if(ibndry(6,jedg1).ne.ibndry(6,jedg2)) go to 130 if(ibndry(4,jedg1).ge.0) then if(ibndry(4,jedg1).ne.ibndry(4,jedg2)) go to 130 if(ibndry(4,jedg1).gt.0) jbdy=1 else if(ibndry(4,jedg2).ge.0) go to 130 jbdy=-1 endif endif if(ibdy.eq.-1.and.jbdy.ne.-1) go to 130 if(jbdy.eq.-1.and.ibdy.ne.-1) go to 130 c m1=iabs(jv(1,jv1))+1 m2=m1+iabs(jv(2,jv1))-1 do m=m1,m2 if(iabs(jv(1,m)).eq.jv2) go to 130 enddo c c 10 if(jv(2,i1-1).gt.0.and.ibdy.eq.0) then if(dmn.gt.hmin) then if(gg.gt.tola) go to 130 else if(gg.gt.tolc) go to 130 endif else if(gg.gt.tolb) go to 130 endif c c delete this point c ichng=ichng+1 do ll=1,2 i1=iabs(jv(1,iv1))+1 i2=i1+iabs(jv(2,iv1))-1 do m=i1,i2 if(iabs(jv(1,m)).eq.i) go to 30 enddo stop 5468 30 k=jv(1,m) jv(1,m)=iv2 jv(3,m)=iedg2 if(k.lt.0) jv(1,m)=-iv2 if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo else if(ll.eq.1.and.ibdy.ne.0) then jv(2,i2)=-iedg2 jv(3,i2)=iedg2 endif endif ii=iv1 iv1=iv2 iv2=ii enddo c if(iequv(i).eq.i) go to 120 do ll=1,2 i1=iabs(jv(1,jv1))+1 i2=i1+iabs(jv(2,jv1))-1 do m=i1,i2 if(iabs(jv(1,m)).eq.j) go to 40 enddo stop 5568 40 k=jv(1,m) jv(1,m)=jv2 jv(3,m)=jedg1 if(k.lt.0) jv(1,m)=-jv2 if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo else if(ll.eq.2.and.jbdy.ne.1) then jv(3,i1-1)=-jedg1 jv(3,i1)=jedg1 endif endif ii=jv1 jv1=jv2 jv2=ii enddo c jv(2,j)=0 120 jv(2,i)=0 130 continue if(ichng.gt.0) go to 5 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine chkpth(iseed,iptr,ilist,jlist,vx,vy,xm,ym,ncf,maxc, + jv,rp,ibndry,nbf,maxb,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + jv(3,*),ilist(3,*),jlist(3,*),ibndry(6,*) real + vx(*),vy(*),p(2),dp(2),q(2),dq(3),al(2),ang(2), 1 c(2),t(2),rp(100),xm(*),ym(*) c c ckeck vertices along a path c iflag=0 if(jv(2,iptr).le.0) then irgn=jv(2,iptr) jrgn=jv(2,iptr+1) else irgn=jv(2,iptr+1) jrgn=jv(2,iptr) endif if(jrgn.le.irgn) return c arcmax=rp(83) arcmin=rp(82) tolf=rp(85) eps=1.e-3 epsa=rp(51) hmin=amin1(1.0e-1,rp(17))*rp(78)/2.0e0 ctol=1.0e-4*rp(78) c c compute ilist, determine length of this path c call getbdy(irgn,iseed,ilen,ilist,jv) last=iseed llen=0 10 last=ilist(1,last) llen=llen+1 if(ilist(2,last).gt.0) go to 10 if(llen.le.1) return c c compute jlist c call getbdy(jrgn,iseed,jlen,jlist,jv) minmrk=0 if(min0(ilen,jlen).le.llen+1) minmrk=1 c c the main loop c ileft=iseed c c find iright c 20 iright=ileft do lrlen=1,llen iright=ilist(1,iright) if(ilist(2,iright).lt.0) go to 40 enddo 40 if(lrlen.le.1) go to 300 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) pp=sqrt(dp(1)**2+dp(2)**2) 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.0e0 msave=0 lsave=0 m=ileft xx=(vx(ileft)+vx(iright))/2.0e0 yy=(vy(ileft)+vy(iright))/2.0e0 dd=(dq(1)**2+dq(2)**2)/4.0e0 r=0.0e0 rr=0.0e0 do lz=1,lrlen-1 m=ilist(1,m) c rr=rr+((vx(m)-xx)**2+(vy(m)-yy)**2-dd) r=r+dq(1)*(vx(m)-xx)+dq(2)*(vy(m)-yy) c q(1)=vx(m) q(2)=vy(m) call lil(p,dp,q,dq,al,iflag) if(abs(al(2)).ge.dmln) then dmln=abs(al(2)) msave=m lsave=lz endif enddo ibleft=ilist(3,ileft) if(ibleft.gt.0) then icen=ibndry(3,ibleft) else icen=0 endif if(minmrk.gt.0) go to 290 if(icen.gt.0) go to 160 if(dmln*pp.gt.hmin) go to 160 c c ckeck the rest of the region for straight line c do 150 iz=1,2 istart=ileft istop=iright if(iz.eq.1) then ll=ilen-lrlen-1 i1=ilist(1,istop) ibef1=iabs(ilist(2,istart)) iaft1=iabs(ilist(1,istart)) ibed1=ilist(3,ibef1) iaed1=ilist(3,istart) ibef2=iabs(ilist(2,istop)) iaft2=iabs(ilist(1,istop)) ibed2=ilist(3,ibef2) iaed2=ilist(3,istop) else if(ilist(1,istart).ne.jlist(1,istart)) then istart=iright istop=ileft endif ll=jlen-lrlen-1 i1=jlist(1,istop) ibef1=iabs(jlist(2,istart)) iaft1=iabs(jlist(1,istart)) ibed1=jlist(3,ibef1) iaed1=jlist(3,istart) ibef2=iabs(jlist(2,istop)) iaft2=iabs(jlist(1,istop)) ibed2=jlist(3,ibef2) iaed2=jlist(3,istop) endif if(ll.lt.1) go to 150 c c check angles c if(ibed1.gt.0) then ibed=ibndry(3,ibed1) else ibed=0 endif aa=cang1(ibef1,istart,istop,ibed,0,vx,vy,xm,ym) a0=cang1(ibef1,istart,iaft1,ibed,0,vx,vy,xm,ym) if(aa.lt.amin1(a0,eps)) go to 290 if(aa.gt.amax1(a0,2.0e0-eps)) go to 290 c if(iaed2.gt.0) then iaed=ibndry(3,iaed2) else iaed=0 endif aa=cang1(istart,istop,iaft2,0,iaed,vx,vy,xm,ym) a0=cang1(ibef2,istop,iaft2,0,iaed,vx,vy,xm,ym) if(aa.lt.amin1(a0,eps)) go to 290 if(aa.gt.amax1(a0,2.0e0-eps)) go to 290 c c check rest of region/boundary c 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.0e0-eps.and.al(1).ge.eps) then if(abs(al(2)).lt.dmln*tolf) go to 290 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(amax1(al(1),al(2)).le.1.0e0+eps.and. + amin1(al(1),al(2)).ge.-eps) go to 290 endif endif i1=i2 enddo 150 continue c c accept straight line c icen=0 go to 250 c c compute parameterization in terms of (r,theta) c 160 if(icen.gt.0) then xcen=xm(icen) ycen=ym(icen) isw=1 else if(r.eq.0.0e0) go to 290 r=rr/(2.0e0*r) xcen=xx-r*dp(2) ycen=yy+r*dp(1) do icen=1,ncf rr=sqrt((xcen-xm(icen))**2+(ycen-ym(icen))**2) if(rr.lt.ctol) go to 170 enddo icen=ncf+1 if(icen.ge.maxc) then iflag=85 return endif xm(icen)=xcen ym(icen)=ycen isw=0 endif 170 call arc(vx(ileft),vy(ileft),vx(iright),vy(iright), + xcen,ycen,theta1,theta2,rad,alen) if(abs(theta1-theta2).le.arcmin) go to 290 if(abs(theta1-theta2).ge.arcmax) go to 290 if(isw.eq.1) go to 250 c c check deviation from proposed arc c dmarc=0.0e0 m=ileft do lz=1,lrlen ms=m m=ilist(1,m) rr=(vx(m)-xcen)**2+(vy(m)-ycen)**2 rr=sqrt(rr)/rad if(abs(rr-1.0e0).ge.dmarc.and.lz.lt.lrlen) then dmarc=abs(rr-1.0e0) endif xx=(vx(m)+vx(ms))/2.0e0 yy=(vy(m)+vy(ms))/2.0e0 rr=(xx-xcen)**2+(yy-ycen)**2 rr=sqrt(rr)/rad if(abs(rr-1.0e0).ge.dmarc) then dmarc=abs(rr-1.0e0) endif enddo if(dmarc*rad.gt.hmin) go to 290 c c ckeck the rest of the region c c(1)=xcen c(2)=ycen t(1)=amin1(theta1,theta2) t(2)=amax1(theta1,theta2) tm=(theta1+theta2)/2.0e0 xx=xcen+rad*cos(tm) yy=xcen+rad*sin(tm) do 220 iz=1,2 istart=ileft istop=iright if(iz.eq.1) then ll=ilen-lrlen-1 i1=ilist(1,istop) ibef1=iabs(ilist(2,istart)) iaft1=iabs(ilist(1,istart)) ibed1=ilist(3,ibef1) iaed1=ilist(3,istart) ibef2=iabs(ilist(2,istop)) iaft2=iabs(ilist(1,istop)) ibed2=ilist(3,ibef2) iaed2=ilist(3,istop) else if(ilist(1,istart).ne.jlist(1,istart)) then istart=iright istop=ileft endif ll=jlen-lrlen-1 i1=jlist(1,istop) ibef1=iabs(jlist(2,istart)) iaft1=iabs(jlist(1,istart)) ibed1=jlist(3,ibef1) iaed1=jlist(3,istart) ibef2=iabs(jlist(2,istop)) iaft2=iabs(jlist(1,istop)) ibed2=jlist(3,ibef2) iaed2=jlist(3,istop) endif if(ll.lt.1) go to 220 c c check angles c if(ibed1.gt.0) then ibed=ibndry(3,ibed1) else ibed=0 endif if(iaed1.gt.0) then iaed=ibndry(3,iaed1) else iaed=0 endif aa=cang1(ibef1,istart,istop,ibed,icen,vx,vy,xm,ym) a0=cang1(ibef1,istart,iaft1,ibed,iaed,vx,vy,xm,ym) if(aa.lt.amin1(a0,eps)) go to 290 if(aa.gt.amax1(a0,2.0e0-eps)) go to 290 c if(ibed2.gt.0) then ibed=ibndry(3,ibed2) else ibed=0 endif if(iaed2.gt.0) then iaed=ibndry(3,iaed2) else iaed=0 endif aa=cang1(istart,istop,iaft2,icen,iaed,vx,vy,xm,ym) a0=cang1(ibef2,istop,iaft2,ibed,iaed,vx,vy,xm,ym) if(aa.lt.amin1(a0,eps)) go to 290 if(aa.gt.amax1(a0,2.0e0-eps)) go to 290 c c check rest of region/boundary c 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=sqrt((q(1)-xcen)**2+(q(2)-ycen)**2)/rad if(abs(rr-1.0e0).lt.dmarc*tolf) then dq(1)=-dp(2) dq(2)=dp(1) call liarc(q,dq,c,t,rad,npts,al,ang,epsa) if(npts.eq.2) go to 290 if(npts.eq.1) then qq=abs(al(1))*sqrt(dq(1)**2+dq(2)**2)/rad if(qq.lt.dmarc*tolf) go to 290 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.0e0+eps.and.al(1).ge.-eps + .and.ang(1).lt.t(2)+eps) go to 290 endif if(npts.eq.2) then if(al(2).le.1.0e0+eps.and.al(2).ge.-eps + .and.ang(2).lt.t(2)+eps) go to 290 endif endif i1=i2 enddo 220 continue c c accept the circle c ncf=max0(icen,ncf) c c c create new edge if needed c 250 if(icen.gt.0) then if(ibleft.eq.0) then if(nbf.ge.maxb) then iflag=86 return endif nbf=nbf+1 ibndry(1,nbf)=ileft ibndry(2,nbf)=iright ibndry(3,nbf)=icen ibndry(4,nbf)=0 ibndry(5,nbf)=0 ibndry(6,nbf)=0 ibleft=nbf else if(ibndry(3,ibleft).ne.icen) then if(nbf.ge.maxb) then iflag=86 return endif nbf=nbf+1 ibndry(1,nbf)=ileft ibndry(2,nbf)=iright ibndry(3,nbf)=icen ibndry(4,nbf)=ibndry(4,ibleft) ibndry(5,nbf)=ibndry(5,ibleft) ibndry(6,nbf)=ibndry(6,ibleft) ibleft=nbf endif endif c c fixup jv for ileft, iright c i1=iabs(jv(1,ileft))+1 i2=i1+iabs(jv(2,ileft))-1 jv(2,ileft)=-iabs(jv(2,ileft)) do j=i1,i2 k=jv(1,j) if(iabs(k).eq.iabs(ilist(1,ileft))) go to 270 enddo 270 jv(1,j)=iright if(k.lt.0) jv(1,j)=-iright jv(3,j)=ibleft if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo endif c i1=iabs(jv(1,iright))+1 i2=i1+iabs(jv(2,iright))-1 jv(2,iright)=-iabs(jv(2,iright)) do j=i1,i2 k=jv(1,j) if(iabs(k).eq.iabs(ilist(2,iright))) go to 280 enddo 280 jv(1,j)=ileft if(k.lt.0) jv(1,j)=-ileft jv(3,j)=ibleft if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo endif c c set deleted vertex degree to zero c m=ileft do lz=1,lrlen-1 m=ilist(1,m) jv(2,m)=0 enddo c c fixup ilist, jlist c if(ilist(1,ileft).eq.jlist(1,ileft)) then jlist(1,ileft)=iright jlist(2,iright)=-ileft jlist(3,ileft)=ibleft else jlist(1,iright)=ileft jlist(2,ileft)=-iright jlist(3,iright)=ibleft endif jlen=jlen-lrlen+1 c ilist(1,ileft)=iright ilist(2,iright)=-ileft ilist(3,ileft)=ibleft ilen=ilen-lrlen+1 c go to 300 c c c 290 ilist(2,msave)=-ilist(2,msave) lrlen=lsave iright=msave minmrk=minmrk-1 if(lrlen.gt.1) go to 50 300 ileft=iright llen=llen-lrlen if(llen.gt.1) go to 20 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine chkpt0(irgn,jrgn,iseed,ilist,jlist,vx,vy,jv) c implicit real (a-h,o-z) implicit integer (i-n) integer + jv(3,*),ilist(3,*),jlist(3,*), 1 mlen(4),mseed(4),mvert(4),mrgn(4) real + 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.95e0 angmin=0.15e0 c call getbdy(irgn,iseed,ilen,ilist,jv) jseed=iseed length=0 10 jseed=ilist(1,jseed) length=length+1 if(ilist(2,jseed).gt.0) go to 10 call getbdy(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=amin1(bi,bj,ti,tj) angmx=amax1(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.eq.1) go to 300 i1=iabs(jv(1,iseed))+1 i2=i1+iabs(jv(2,iseed))-1 do j=i1,i2 k=jv(1,j) if(iabs(k).eq.iabs(ilist(1,iseed))) go to 270 enddo stop 201 270 jv(1,j)=jseed if(k.lt.0) jv(1,j)=-jseed jv(3,j)=0 if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo endif c i1=iabs(jv(1,jseed))+1 i2=i1+iabs(jv(2,jseed))-1 do j=i1,i2 k=jv(1,j) if(iabs(k).eq.iabs(ilist(2,jseed))) go to 280 enddo stop 202 280 jv(1,j)=iseed if(k.lt.0) jv(1,j)=-iseed jv(3,j)=0 if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo endif c c set deleted vertex degree to zero c m=iseed do lz=1,length-1 m=ilist(1,m) jv(2,m)=0 enddo c 300 if(icase.eq.0) return 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 do ib=1,3 jv(ib,k)=jv(ib,k+1) enddo enddo if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2-1) jv(ib,i2)=jv(ib,i1) enddo 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 do ib=1,3 jv(ib,i2)=jv(ib,i2-1) enddo jv(1,i2-1)=mi jv(2,i2-1)=jr jv(3,i2-1)=0 else jv(1,i2)=mi jv(2,i2)=jr jv(3,i2)=0 endif else if(jv(2,i1).eq.jr) then do ib=1,3 jv(ib,i2)=jv(ib,i2-1) enddo jv(1,i2-1)=mi jv(2,i2-1)=jr jv(3,i2-1)=0 jv(2,i1)=ir else jv(1,i2)=mi jv(2,i2)=jr jv(3,i2)=0 jv(2,i2-1)=ir endif endif if(jv(2,i1-1).gt.0) then do ib=1,3 jv(ib,i1-1)=jv(ib,i2) jv(ib,i2+1)=jv(ib,i1) enddo 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine getrgn(irgn,iseed,length,list,jv) c implicit real (a-h,o-z) implicit integer (i-n) integer + list(3,*),jv(3,*) c c compute boundary for region irgn c length=0 i=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 list(1,i)=iabs(jv(1,j)) list(2,i)=j length=length+1 i=list(1,i) if(i.ne.iseed) go to 10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine getbdy(irgn,iseed,length,list,jv) c implicit real (a-h,o-z) implicit integer (i-n) integer + list(3,*),jv(3,*) c c compute boundary for region irgn c length=0 i=iseed 10 i1=jv(1,i)+1 i2=i1+iabs(jv(2,i))-1 c c follow interior region c if(irgn.gt.0) then do j=i1,i2 if(jv(2,j).eq.irgn) go to 20 enddo 20 list(1,i)=iabs(jv(1,j)) list(2,i)=iabs(jv(1,j+1)) list(3,i)=iabs(jv(3,j)) c c follow boundary c else list(1,i)=iabs(jv(1,i1)) list(2,i)=iabs(jv(1,i2)) list(3,i)=iabs(jv(3,i1)) endif if(iabs(jv(2,i)).gt.2.or.jv(2,i).lt.0) list(2,i)=-list(2,i) i=list(1,i) length=length+1 if(i.ne.iseed) go to 10 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cds(ip,jv,itnode,ibndry,jb,vx,vy,xm,ym,jbndry, + list,itag,mapv,mapb) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),jv(3,*),jbndry(6,*), 1 list(3,*),ip(100),itag(*),mapv(*),mapb(*) real + vx(*),vy(*),xm(*),ym(*) c c compute skeleton data structures from the jv array c ntr=ip(1) nvr=ip(2) ncr=ip(3) nbr=ip(4) maxt=ip(83) maxv=ip(84) maxb=ip(86) c c find largest label value c imark=0 do i=1,ntr imark=max0(imark,iabs(itag(i))) enddo imark=imark+1 c do i=1,nbr do j=1,6 jbndry(j,i)=ibndry(j,i) enddo mapb(i)=0 enddo iflag=0 c c new vertices c nvr0=nvr nvr=0 do i=1,nvr0 mapv(i)=0 if(iabs(jv(2,i)).gt.1) then nvr=nvr+1 mapv(i)=nvr vx(nvr)=vx(i) vy(nvr)=vy(i) endif enddo c c new edges c nbr=0 ncr=0 do i=1,nvr0 if(mapv(i).eq.0) go to 70 i1=iabs(jv(1,i))+1 i2=i1+iabs(jv(2,i))-1 do j=i1,i2 k=iabs(jv(1,j)) if(k.lt.i) then c if(nbr.ge.maxb) then iflag=86 go to 200 endif nbr=nbr+1 ibndry(1,nbr)=mapv(i) ibndry(2,nbr)=mapv(k) kk=jv(3,j) if(kk.gt.0) then ibndry(3,nbr)=jbndry(3,kk) ibndry(4,nbr)=jbndry(4,kk) ibndry(5,nbr)=kk ibndry(6,nbr)=jbndry(6,kk) mapb(kk)=nbr else ibndry(3,nbr)=0 ibndry(4,nbr)=0 ibndry(5,nbr)=0 ibndry(6,nbr)=0 endif ncr=max0(ncr,ibndry(3,nbr)) c c jv(3,*) now has new edge numbers c jv(3,j)=nbr k1=iabs(jv(1,k))+1 k2=k1+iabs(jv(2,k))-1 do l=k1,k2 if(iabs(jv(1,l)).eq.i) go to 50 enddo stop 4196 50 jv(3,l)=nbr endif enddo 70 enddo c c fixup for periodic bc c do i=1,nbr if(ibndry(4,i).lt.0) then ii=ibndry(5,i) kk=-jbndry(4,ii) if(mapb(kk).eq.0) stop 4367 ibndry(4,i)=-mapb(kk) ibndry(4,mapb(kk))=-i endif enddo c c now find regions c ntr=0 do i=1,nvr0 if(mapv(i).eq.0) go to 100 i1=iabs(jv(1,i))+1 i2=i1+iabs(jv(2,i))-1 do j=i1,i2 irgn=jv(2,j) if(irgn.le.0) go to 90 if(itag(irgn).eq.imark) go to 90 call getbdy(irgn,i,length,list,jv) if(ntr.ge.maxt) then iflag=83 go to 200 endif ntr=ntr+1 itnode(1,ntr)=mapv(i) itnode(2,ntr)=list(3,i) itnode(3,ntr)=irgn itnode(4,ntr)=i itnode(5,ntr)=itag(irgn) itag(irgn)=imark 90 enddo 100 enddo c c compute jb c jb(1)=ntr+2 do i=1,ntr irgn=itnode(3,i) iseed=itnode(4,i) itnode(3,i)=0 itnode(4,i)=0 call getbdy(irgn,iseed,length,list,jv) k=jb(i) m=iseed do jj=1,length jb(k)=list(3,m) k=k+1 m=list(1,m) enddo jb(i+1)=k enddo call tstjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,jb,jv) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sgen(ip,vx,vy,xm,ym,itnode,ibndry,jb, + iequv,jv,lenjv,rp,jw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),iequv(*), 1 jv(3,*),jb(*),jw(*) real + vx(*),vy(*),xm(*),ym(*),rp(100) c c compute skeleton from current triangle data c and set up input data for trigen c c lenjv=7*max0(nvf,nbf) c lenjw=14*max0(nvf,nbf) c iflag=0 ntf=ip(1) nvf=ip(2) ncf=ip(3) nbf=ip(4) maxc=ip(85) maxb=ip(86) c hmin=amax1(rp(51),rp(17)) hmin=amin1(0.1e0,hmin) rp(17)=hmin c c rp(82)= arcmin (chkpth) c rp(83)= arcmax (chkpth) c rp(85)= tolf (relative tolerance for arc/lines in chkpth) c rp(82)=1.0e0/64.0e0-1.0e-2 rp(83)=1.0e0/4.0e0+1.0e-2 rp(85)=8.0e0 c c construct the jb data structure c ibdy=nvf+2*nbf+2 inum=ibdy+nvf iornt=inum+nbf c call makjb(nvf,nbf,ntf,vx,vy,xm,ym,ibndry,itnode,1, + jb,jw,jw(ibdy),jw(inum),jw(iornt),iflag) if(iflag.ne.0) then ip(25)=iflag return endif c l1=1 l2=l1+2*max0(nvf,nbf,ntf) l3=l2+2*max0(nvf,nbf,ntf) l4=l3+2*max0(nvf,nbf,ntf) c call cequv(nvf,nbf,ntf,itnode,jb,ibndry,iequv,0,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c c construct the jv data structure c call cjv1(nvf,ntf,nbf,ibndry,jb,jv,lenjv,iequv, + jw(l4),jw(l1),jw(l2),jw(l3),vx,vy,iflag) if(iflag.ne.0) then ip(25)=iflag return endif c c look at all degree 2 vertices and eliminate c those with angle approximately equal to pi c call chkdg2(nvf,vx,vy,xm,ym,jv,rp,ibndry,iequv) c c interior and boundary paths c do n=1,nvf isw=0 if(jv(2,n).le.-2) isw=-1 if(jv(2,n).ge.3) isw=1 if(isw.eq.0) go to 10 c i1=jv(1,n)+1 i2=i1+iabs(jv(2,n))-1 if(isw.lt.0) i2=i2-1 do j=i1,i2 iptr=j-1 call chkpth(n,iptr,jw(l1),jw(l3),vx,vy,xm,ym, + ncf,maxc,jv,rp,ibndry,nbf,maxb,iflag) if(iflag.ne.0) then ip(25)=iflag return endif enddo 10 enddo c c save user labels c ip(2)=nvf c l1=1 l2=l1+6*nbf l3=l2+3*max0(nvf,nbf,ntf) l4=l3+max0(nvf,nbf,ntf) l5=l4+max0(nvf,nbf,ntf) c isymsw=0 do i=1,ntf if(itnode(3,i).ne.0) isymsw=1 jw(l3+i-1)=itnode(5,i) enddo ip(3)=ncf ip(4)=nbf call cds(ip,jv,itnode,ibndry,jb,vx,vy,xm,ym,jw(l1), + jw(l2),jw(l3),jw(l4),jw(l5)) c c look for symmetry if present in input c if(isymsw.eq.0) return ntf=ip(1) nvf=ip(2) nbf=ip(4) c call fndsym(ntf,nvf,nbf,vx,vy,xm,ym,ibndry,jb, + itnode,jw,iflag) if(iflag.ne.0) ip(25)=iflag c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cjv1(nvf,ntf,nbf,ibndry,jb,jv,lenjv,iequv,ibc, + irgn,ibef,iaft,vx,vy,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jv(3,*),ibc(*),iequv(*), 1 irgn(2,*),ibef(2,*),iaft(2,*),jb(*) real + vx(*),vy(*) c c make list of triangles as a function of vertex c iflag=0 c c mark boundary vertices c do i=1,nvf jv(1,i)=2 jv(2,i)=0 jv(3,i)=0 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 do i=1,nbf do j=1,2 ii=ibndry(j,i) jv(1,ii)=jv(1,ii)+1 irgn(j,i)=0 enddo if(ibndry(4,i).ne.0) then irgn(1,i)=-i ibef(1,i)=-i iaft(1,i)=-i endif enddo c c make list of regions for each edge c do i=1,ntf do j=jb(i),jb(i+1)-1 ib=jb(j) if(irgn(1,ib).eq.0) then irgn(1,ib)=i if(j.eq.jb(i)) then ibef(1,ib)=jb(jb(i+1)-1) else ibef(1,ib)=jb(j-1) endif if(j.eq.jb(i+1)-1) then iaft(1,ib)=jb(jb(i)) else iaft(1,ib)=jb(j+1) endif else if(irgn(2,ib).ne.0) stop 7324 irgn(2,ib)=i if(j.eq.jb(i)) then ibef(2,ib)=jb(jb(i+1)-1) else ibef(2,ib)=jb(j-1) endif if(j.eq.jb(i+1)-1) then iaft(2,ib)=jb(jb(i)) else iaft(2,ib)=jb(j+1) endif endif enddo enddo c c initailize pointers c nn=nvf+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=82 return endif c c this make a list of edges for each vertex c do i=1,nbf do j=1,2 ii=ibndry(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 regions (jv(2,*)) c in counter clockwise order (first and last c vertices are the same for interior points) c do 30 n=1,nvf i1=jv(1,n)+1 i2=jv(2,n)-1 if(i1.gt.i2) go to 30 if(ibc(n).ne.0) then c c starting element for a boundary point c do ii=i1,i2 jed=jv(1,ii) if(irgn(1,jed).lt.0) then ked=ibef(2,jed) if(ibndry(1,ked).eq.n) go to 10 if(ibndry(2,ked).eq.n) go to 10 endif enddo stop 6533 10 i2=i2-1 else jed=jv(1,i1) endif c c compute list for knot n c do ii=i1,i2 c c find predecessor edge c k1=1 if(irgn(1,jed).lt.0) k1=2 do kk=k1,2 ked=ibef(kk,jed) if(ibndry(1,ked).eq.n) go to 20 if(ibndry(2,ked).eq.n) go to 20 enddo stop 6533 20 jv(1,ii)=ibndry(1,jed)+ibndry(2,jed)-n jv(1,ii+1)=ibndry(1,ked)+ibndry(2,ked)-n jv(2,ii)=irgn(kk,jed) jv(2,ii-1)=irgn(3-kk,jed) jv(2,ii+1)=irgn(1,ked)+irgn(2,ked)-irgn(kk,jed) jv(3,ii)=jed jv(3,ii+1)=ked jed=ked enddo if(ibc(n).eq.1) then jv(1,i1-1)=0 jv(3,i1-1)=0 jv(1,i2+2)=0 jv(2,i2+2)=0 jv(3,i2+2)=0 else jv(1,i1-1)=jv(1,i2) jv(3,i1-1)=jv(3,i2) endif 30 continue c c compute degrees c do i=1,nvf jv(2,i)=jv(2,i)-jv(1,i)-1 enddo c c mark important boundary vertices (make sure at least two paths) c do i=1,nvf irgn(1,i)=0 irgn(2,i)=0 enddo c do i=1,nvf if(ibc(i).eq.0) go to 40 i1=jv(1,i)+1 i2=i1+jv(2,i)-1 ib1=-jv(2,i1-1) ib2=-jv(2,i2) ibc(i)=-1 irgn(1,i)=jv(1,i1) irgn(2,i)=jv(1,i2) if(jv(2,i).gt.2) ibc(i)=1 if(ibndry(3,ib1).ne.ibndry(3,ib2)) ibc(i)=1 if(ibndry(4,ib1).ne.ibndry(4,ib2)) ibc(i)=1 if(ibndry(6,ib1).ne.ibndry(6,ib2)) ibc(i)=1 40 enddo c c scan irgn array looking for different regions c lower left/upper right get mark=1 c do i=1,nvf if(irgn(1,i).le.0) go to 60 ill=i iur=i k=i 50 irgn(1,k)=-irgn(1,k) k=-irgn(1,k) if(k.lt.1.or.k.gt.nvf) stop 9433 if(ibc(k).eq.0) stop 9434 if(k.ne.i) then if(vx(ill).gt.vx(k)) then ill=k else if(vx(ill).eq.vx(k)) then if(vy(ill).gt.vy(k)) ill=k endif if(vx(iur).lt.vx(k)) then iur=k else if(vx(iur).eq.vx(k)) then if(vy(iur).lt.vy(k)) iur=k endif go to 50 endif if(iur.eq.ill) stop 9435 ibc(ill)=1 ibc(iur)=1 60 enddo c c mark important boundary vertices c do i=1,nvf if(ibc(i).eq.1) jv(2,i)=-jv(2,i) ibc(i)=0 enddo c c make sure equivalent vertices are marked the same c do i=1,nvf if(jv(2,i).le.-2.or.jv(2,i).ge.3) then it=i 70 ibc(it)=1 it=iequv(it) if(it.ne.i) go to 70 endif enddo do i=1,nvf if(jv(2,i).eq.2.and.ibc(i).eq.1) jv(2,i)=-jv(2,i) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tstjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,jb,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),jb(*),list(*) real + 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.0e0 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 enddo list(1)=nvr+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+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=jb(i) i2=jb(i+1)-1 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 ie13=ibndry(3,ie1) ie23=ibndry(3,ie2) if(max0(ie13,ie23).gt.0) then a0=cang1(ibef,icom,iaft,ie23,ie13,vx,vy,xm,ym) 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.0e0) then dx1=vx(iaft)-vx(icom) dy1=vy(iaft)-vy(icom) dd1=sqrt(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 ik3=ibndry(3,k) ie23=ibndry(3,ie2) if(max0(ik3,ie23).gt.0) then aa=cang1(ibef,icom,next,ie23,ik3, + vx,vy,xm,ym) 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=sqrt(dx1**2+dy1**2) dx2=vx(next)-vx(icom) dy2=vy(next)-vy(icom) dd2=sqrt(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine triplt(vx,vy,xm,ym,itnode,ibndry, + ip,rp,sp,w,qxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),jp(25), 1 kdist(22),ia(4) real + 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 ndf worst worst c 25 average average c c c storage allocation c if(ip(6).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(82) iuu=ip(90) itdof=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 ntf=ip(1) nvf=ip(2) nbf=ip(4) iprob=iabs(ip(7)) itask=ip(9) maxv=ip(84) 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 iord=ip(26) ndof=(iord+1)*(iord+2)/2 ndf=ip(5) maxd=ip(89) c call gfptr(iprob,itask,maxd,iuu,iu0,iudot,iu0dot, + ievr,ievl,ivx0,ivy0,ium,iuc,ngf,nef) ngf=ip(77) c c temporary storage space c ibegin=iz iend=lenw c c initialize data structures c if(mpisw.eq.1) then call exflag(ip(24)) if(ip(24).ne.0) then iflag=24 go to 10 endif if(icrsn.eq.1) then ia(1)=max0(4*itrgt,ntf) ia(2)=max0(2*itrgt,nbf) ia(3)=max0(2*itrgt,nvf) ia(4)=max0(2*iord**2*itrgt,ndf) else ia(1)=ntf*nproc ia(2)=nbf*nproc ia(3)=nvf*nproc ia(4)=ndf*nproc endif call exsze(ia,0) lent=ia(1) lenb=ia(2) lenv=ia(3) lend=ia(4) lend=lenv else lent=ntf lenb=nbf lenv=nvf lend=ndf endif call memptr(jtnode,5*lent,'head',ibegin,iend,iflag) call memptr(itedge,3*lent,'head',ibegin,iend,iflag) call memptr(iut,ndof*lent,'head',ibegin,iend,iflag) call memptr(ivt,ndof*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,ndf,'head',ibegin,iend,iflag) call memptr(iva,ndf,'head',ibegin,iend,iflag) call memptr(jtdof,ndof*lent,'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=iuu iv2=iuu ierrsw=0 icont=0 itype=0 if(ifun.eq.1) then itype=1 if(ip(57).eq.1) icont=1 else if(ifun.eq.2) then itype=2 if(ip(57).eq.1) icont=1 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=ium else if(ifun.eq.10) then ivu=iuc else if(ifun.eq.11) then ivu=iuu+(ngf-1)*maxd endif call setfun(ntf,nvf,nbf,ndf,maxd,ngf,itype,icont,icplt,w(ivu), + w(iv1),w(iv2),w(iee),vx,vy,xm,ym,iord,ndof,w(iut),w(ivt), 1 itnode,ibndry,w(ibedge),w(itedge),w(iua),w(iva), 2 w(jzz),rl,w(itdof),qxy) call plinit(ip,rp,w(jtnode),w(jbndry),w(jtdof),w(itedge), + w(ibedge),w(ivx0),w(ivy0),iord,ndof,w(iut),w(ivt), 1 xm,ym,icplt,ierrsw,w(iee),kdist,q,t,tl,jp,w(jzz),itnode, 2 ibndry,w(itdof),vx,vy,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) ia(4)=jp(24) call exsze(ia,1) ntf=ia(1) nvf=ia(2) nbf=ia(3) ndf=ia(4) iflag=0 if(ntf.gt.lent) iflag=82 if(nvf.gt.lenv) iflag=82 if(nbf.gt.lenb) iflag=82 if(iflag.ne.0) go to 10 llen=(5+2*ndof)*ntf+2*nvf+6*nbf+4 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,ndof,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(ibuff),iflag) endif call memptr(isv,0,'free',ibegin,iend,iflag) if(irgn.ne.1) return endif c c ordering c call memptr(jord,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(jord),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(jord), + w(ivx0),w(ivy0),iord,ndof,w(iut),xm,ym,q,t) else call vplot(jp,w(jtnode),w(jbndry),w(itedge),w(jord), + w(ivx0),w(ivy0),iord,ndof,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.0e-3 arcmax=0.26e0 call cvtype(jp(1),jp(3),jp(2),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.0e0) jp(22)=0 if(icplt.eq.1) then jp(16)=0 call cplot(jp,w(jtnode),w(jbndry),w(itedge),w(jord), + w(ivx0),w(ivy0),iord,ndof,w(iut),xm,ym,q,tl) else call vplot(jp,w(jtnode),w(jbndry),w(itedge),w(jord), + w(ivx0),w(ivy0),iord,ndof,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.24) then write(unit=sp(11),fmt='(a12,i3,a8,i4)') + 'triplt error',iflag,': region',ip(24) else if(iflag.eq.25) then write(unit=sp(11),fmt='(a12,i3,a23)') + 'triplt error',iflag,': wrong data structure' else write(unit=sp(11),fmt='(a12,i3,a22)') + 'triplt error',iflag,': insufficient storage' iflag=82 endif c ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine inplt(vx,vy,xm,ym,itnode,ibndry,ip,rp,sp,w) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ip(100),jp(25),kdist(22),ia(4) real + 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) ndf=ip(5) iord=ip(26) lenw=ip(82) inplsw=ip(53) icrsn=ip(68) itrgt=ip(69) mpisw=ip(48) nproc=ip(49) irgn=ip(50) c ibegin=max0(ip(99),ip(84),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,3*nbf,'head',ibegin,iend,iflag) call memptr(jtt,ntf+1,'head',ibegin,iend,iflag) call memptr(isv,0,'mark',ibegin,iend,iflag) llist=max0(nvv+nbf+3*ntt+1,4*nbf+2*nvf+1) call memptr(list,llist,'head',ibegin,iend,iflag) call memptr(indx,nvv,'head',ibegin,iend,iflag) if(iflag.ne.0) then iflag=82 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) 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 call exflag(ip(24)) if(ip(24).ne.0) then iflag=24 go to 10 endif if(icrsn.eq.1) then ia(1)=max0(4*itrgt,ntf) ia(2)=max0(2*itrgt,nbf) ia(3)=max0(2*itrgt,nvf) ia(4)=max0(2*iord**2*itrgt,ndf) else ia(1)=ntf*nproc ia(2)=nbf*nproc ia(3)=nvf*nproc ia(4)=ndf*nproc endif call exsze(ia,0) lent=ia(1) lenb=ia(2) lenv=ia(3) lend=ia(4) else lent=ntf lenb=nbf lenv=nvf lend=ndf 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(6).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=82 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) ia(4)=jp(24) call exsze(ia,1) ntf=ia(1) nvf=ia(2) nbf=ia(3) ndf=ia(4) iflag=0 if(ntf.gt.lent) iflag=82 if(nvf.gt.lenv) iflag=82 if(nbf.gt.lenb) iflag=82 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=82 go to 10 endif ndof=1 call glbpix(w(ivx0),w(ivy0),w(jbndry),w(jtnode), + w(iclr),ndof,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(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),vx,vy,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.0e-3 arcmax=0.26e0 call cvtype(jp(1),jp(3),jp(2),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 write(unit=sp(11),fmt='(a11,i3,a22)') + 'inplt error',iflag,': insufficient storage' else if(iflag.eq.24) then write(unit=sp(11),fmt='(a11,i3,a8,i4)') + 'inplt error',iflag,': region',ip(24) else write(unit=sp(11),fmt='(a11,i3,a16)') + 'inplt error',iflag,': bad input data' endif c ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine setfun(ntf,nvf,nbf,ndf,maxd,ngf,itype,icont,icplt, + u,v1,v2,e,vx,vy,xm,ym,iord,ndof,ut,vt,itnode,ibndry,ibedge, 1 icurv,ua,va,z,rl,itdof,qxy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),idof(10),icurv(3,*), 1 ibndry(6,*),ibedge(2,*) real + vx(*),vy(*),xm(*),ym(*),u(*),v1(*),v2(*),ut(ndof,*), 1 vt(ndof,*),z(*),ua(*),va(*),qv(5,15),c(3,15),gv(10), 2 gx(10),gy(10),e(*),tx(3),ty(3),x(3),y(3),xp(10),yp(10), 3 xn(3),yn(3) external qxy c c do i=1,ntf do j=1,ndof ut(j,i)=0.0e0 vt(j,i)=0.0e0 enddo enddo c c scalar function defined at vertices c if(itype.lt.1.or.itype.gt.6) then icplt=1 do i=1,ntf call l2gmap(i,idof,ndof,itdof) do j=1,ndof ut(j,i)=u(idof(j)) enddo enddo c c scalar function defined at vertices, plot grad u c else if(itype.eq.1.or.itype.eq.2) then icplt=0 if(itype.eq.1) icplt=1 call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,icurv,iflag) call ccurv(ntf,nbf,ibndry,ibedge,icurv) call cnodes(c,iord) do i=1,ntf call l2gmap(i,idof,ndof,itdof) call afmap(i,itnode,vx,vy,tx,ty,x,y,det) call cnodec(i,iord,itnode,icurv,vx,vy,xm,ym,xp,yp,isw) do j=1,ndof call beval(c(1,j),x,y,gv,gx,gy,iord) c c isoparamtric map for elements with curved edges c if(isw.ne.0) then p11=0.0e0 p12=0.0e0 p21=0.0e0 p22=0.0e0 do m=1,ndof p11=p11+xp(m)*gx(m) p12=p12+xp(m)*gy(m) p21=p21+yp(m)*gx(m) p22=p22+yp(m)*gy(m) enddo detn=p11*p22-p12*p21 do m=1,3 xn(m)=(p22*x(m)-p21*y(m))/detn yn(m)=(p11*y(m)-p12*x(m))/detn enddo call beval(c(1,j),xn,yn,gv,gx,gy,iord) endif ux=0.0e0 uy=0.0e0 do k=1,ndof ux=ux+u(idof(k))*gx(k) uy=uy+u(idof(k))*gy(k) enddo if(itype.eq.2) then ut(j,i)=ux vt(j,i)=uy else ut(j,i)=sqrt(ux**2+uy**2) endif enddo enddo c c user function qxy c else if(itype.eq.3.or.itype.eq.4) then icplt=0 if(itype.eq.3) icplt=1 call cnodes(c,iord) do i=1,ntf call l2gmap(i,idof,ndof,itdof) call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + ndof,qv,c,idof,iord,qxy) if(itype.eq.3) then do j=1,ndof ut(j,i)=qv(1,j) enddo else do j=1,ndof ut(j,i)=qv(2,j) vt(j,i)=qv(3,j) enddo endif enddo c c piecewise constant function defined on elements c else if(itype.eq.5) then icplt=1 do i=1,ntf do j=1,ndof ut(j,i)=e(i) enddo enddo c c vector function c else if(itype.eq.6) then icplt=0 do i=1,ntf call l2gmap(i,idof,ndof,itdof) do j=1,ndof ut(j,i)=v1(idof(j)) vt(j,i)=v2(idof(j)) enddo enddo endif c c average discontinuous function c if(icont.eq.0) return if(icplt.eq.1) then do i=1,ndf ua(i)=0.0e0 z(i)=0.0e0 enddo do i=1,ntf call l2gmap(i,idof,ndof,itdof) area=abs((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,ndof z(idof(j))=z(idof(j))+area ua(idof(j))=ua(idof(j))+area*ut(j,i) enddo enddo do i=1,ndf ua(i)=ua(i)/z(i) enddo do i=1,ntf call l2gmap(i,idof,ndof,itdof) do j=1,ndof ut(j,i)=ua(idof(j)) enddo enddo else do i=1,ndf ua(i)=0.0e0 va(i)=0.0e0 z(i)=0.0e0 enddo do i=1,ntf call l2gmap(i,idof,ndof,itdof) area=abs((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,ndof z(idof(j))=z(idof(j))+area ua(idof(j))=ua(idof(j))+area*ut(j,i) va(idof(j))=va(idof(j))+area*vt(j,i) enddo enddo do i=1,ndf ua(i)=ua(i)/z(i) va(i)=va(i)/z(i) enddo do i=1,ntf call l2gmap(i,idof,ndof,itdof) do j=1,ndof ut(j,i)=ua(idof(j)) vt(j,i)=va(idof(j)) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function fqual(iv,itnode,itedge,ibndry, + iord,ndof,itdof,vx,vy,xm,ym,ua,va,icplt,vtype, 1 tlist,vlist,elist,len,qmax) c implicit real (a-h,o-z) implicit integer (i-n) integer + vtype(*),corner(9),tlist(500),itnode(5,*),elist(500), 1 itedge(3,*),ibndry(6,*),itdof(ndof,*),vlist(500) real + vx(*),vy(*),ua(*),va(*),uvalues(11,10),vvalues(11,10), 1 xm(*),ym(*),uave(11),vave(11) save corner data corner/0,0,1,0,1,0,1,0,1/ c c c fqual=-qmax if(corner(vtype(iv)).eq.1) return c c test geometry c qmin=0.6e0 qq=qtst(iv,vx,vy,vtype,vlist,elist,len,qmin) if(qq.lt.qmin) return c i1=1 if(vtype(iv).gt.5) i1=2 xx=vx(iv) yy=vy(iv) do i=1,ndof+1 uave(i)=0.0e0 enddo do i=i1,len itri=tlist(i) call ptevl(itri,itnode,itedge,ibndry,iord,ndof,itdof, + vx,vy,xm,ym,ua,xx,yy,1,uvalues(1,i)) do j=1,ndof+1 uave(j)=uave(j)+uvalues(j,i) enddo enddo do j=1,ndof uave(j)=uave(j)/float(len+1-i1) enddo dx=0.0e0 dy=0.0e0 do i=i1,len ss=uvalues(ndof+1,i) dx=dx+ss*(uvalues(2,i)-uave(2))**2 dy=dy+ss*(uvalues(3,i)-uave(3))**2 enddo sum=dx+dy if(iord.ge.2) then dxx=0.0e0 dxy=0.0e0 dyy=0.0e0 do i=i1,len ss=uvalues(ndof+1,i)**2 dxx=dxx+ss*(uvalues(4,i)-uave(4))**2 dxy=dxy+ss*(uvalues(5,i)-uave(5))**2 dyy=dyy+ss*(uvalues(6,i)-uave(6))**2 enddo sum=sum+dxx+dxy+dyy endif if(iord.ge.3) then dxxx=0.0e0 dxxy=0.0e0 dxyy=0.0e0 dyyy=0.0e0 do i=i1,len ss=uvalues(ndof+1,i)**3 dxxx=dxxx+ss*(uvalues(7,i)-uave(7))**2 dxxy=dxxy+ss*(uvalues(8,i)-uave(8))**2 dxyy=dxyy+ss*(uvalues(9,i)-uave(9))**2 dyyy=dyyy+ss*(uvalues(10,i)-uave(10))**2 enddo sum=sum+dxxx+dxxy+dxyy+dyyy endif if(icplt.eq.1) then fqual=-sqrt(sum) return endif c c vector plot c do i=1,ndof+1 vave(i)=0.0e0 enddo do i=i1,len itri=tlist(i) call ptevl(itri,itnode,itedge,ibndry,iord,ndof,itdof, + vx,vy,xm,ym,va,xx,yy,1,vvalues(1,i)) do j=1,ndof+1 vave(j)=vave(j)+vvalues(j,i) enddo enddo do j=1,ndof vave(j)=vave(j)/float(len+1-i1) enddo dx=0.0e0 dy=0.0e0 do i=i1,len ss=vvalues(ndof+1,i) dx=dx+ss*(vvalues(2,i)-vave(2))**2 dy=dy+ss*(vvalues(3,i)-vave(3))**2 enddo sum=sum+dx+dy if(iord.ge.2) then dxx=0.0e0 dxy=0.0e0 dyy=0.0e0 do i=i1,len ss=vvalues(ndof+1,i)**2 dxx=dxx+ss*(vvalues(4,i)-vave(4))**2 dxy=dxy+ss*(vvalues(5,i)-vave(5))**2 dyy=dyy+ss*(vvalues(6,i)-vave(6))**2 enddo sum=sum+dxx+dxy+dyy endif if(iord.ge.3) then dxxx=0.0e0 dxxy=0.0e0 dxyy=0.0e0 dyyy=0.0e0 do i=i1,len ss=vvalues(ndof+1,i)**3 dxxx=dxxx+ss*(vvalues(7,i)-vave(7))**2 dxxy=dxxy+ss*(vvalues(8,i)-vave(8))**2 dxyy=dxyy+ss*(vvalues(9,i)-vave(9))**2 dyyy=dyyy+ss*(vvalues(10,i)-vave(10))**2 enddo sum=sum+dxxx+dxxy+dxyy+dyyy endif fqual=-sqrt(sum) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ptevl(itri,itnode,itedge,ibndry,iord,ndof,itdof, + vx,vy,xm,ym,u,xx,yy,itype,values) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),icurv(3),itedge(3,*), 1 ibndry(6,*),idof(10),iv(3) real + vx(*),vy(*),xm(*),ym(*),u(*),values(11),g(10,10),tx(3), 1 c(3),ty(3),x(3),y(3),xp(10),yp(10),gv(10),gx(10),gy(10) c c values( 1) = u c values( 2) = du / dx c values( 3) = du / dy c values( 4) = d2u / dx2 c values( 5) = d2u / dx dy c values( 6) = d2u / dy2 c values( 7) = d3u / dx3 c values( 8) = d3u / dx2 dy c values( 9) = d3u / dx dy2 c values(10) = d3u / dy3 c values(ndof+1) = area of straight edged element c call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) call l2gmap(itri,idof,ndof,itdof) call bari(xx,yy,vx,vy,itnode(1,itri),c) c c fixup isoparametric elements c if(iord.gt.1) then isw=0 do j=1,3 iv(j)=itnode(j,itri) icurv(j)=0 if(itedge(j,itri).lt.0) then iedge=-itedge(j,itri) if(ibndry(3,iedge).gt.0) then icurv(j)=ibndry(3,iedge) isw=1 endif endif enddo c if(isw.ne.0) then call cnodec(1,iord,iv,icurv,vx,vy,xm,ym,xp,yp,jsw) call barinl(c,xp,yp,iord,gv) call beval(c,x,y,gv,gx,gy,iord) p11=0.0e0 p12=0.0e0 p21=0.0e0 p22=0.0e0 do j=1,ndof p11=p11+xp(j)*gx(j) p12=p12+xp(j)*gy(j) p21=p21+yp(j)*gx(j) p22=p22+yp(j)*gy(j) enddo detn=p11*p22-p12*p21 do j=1,3 xn=(p22*x(j)-p21*y(j))/detn y(j)=(p11*y(j)-p12*x(j))/detn x(j)=xn enddo endif endif c c evaluate basis functions, and compute values c if(itype.eq.1) then call beval3(c,x,y,g,iord) do i=1,ndof values(i)=0.0e0 do j=1,ndof values(i)=values(i)+u(idof(j))*g(i,j) enddo enddo else call beval(c,x,y,gv,gx,gy,iord) values(1)=0.0e0 values(2)=0.0e0 values(3)=0.0e0 do j=1,ndof values(1)=values(1)+u(idof(j))*gv(j) values(2)=values(2)+u(idof(j))*gx(j) values(3)=values(3)+u(idof(j))*gy(j) enddo endif values(ndof+1)=abs(det)/2.0e0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine crsn1(ntf,nvf,nbf,ndf,nvtrgt,icplt,itnode,ibndry, + iord,ndof,itdof,vx,vy,xm,ym,ut,vt,vz,va,itedge,ibedge, 1 vtype,p,q,qual,iseed,ibase) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),ibedge(2,*), 1 vtype(*),iseed(*),p(*),q(*),corner(9),itdof(ndof,*), 2 elist(500),tlist(500),vlist(500),blist(500),vsv(500) real + vz(*),xm(*),ym(*),vx(*),vy(*),bump(3),e(3),qual(*), 1 ut(ndof,*),vt(ndof,*),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 lenb=3 angmin=1.0e-3 arcmax=0.26e0 c c initialize iseed, vtype c call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,iseed,angmin,arcmax) c call cedge5(nbf,itedge,ibedge,1) qmax=0.0e0 do i=1,nvf call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) qq=fqual(i,itnode,itedge,ibndry,iord,ndof,itdof,vx,vy, + xm,ym,vz,va,icplt,vtype,tlist,vlist,elist,len,qmax) qmax=amax1(qmax,abs(qq)) enddo qmax=100.0e0*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,itnode,itedge,ibndry,iord,ndof,itdof,vx,vy, + xm,ym,vz,va,icplt,vtype,tlist,vlist,elist,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 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 eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,0,1,iord,ndof,itdof,iflag) c c if(corner(vtype(i)).eq.1) stop 6235 if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,ndof, + itdof,vx,vy,lenb,bump,e,iseed,vtype, 1 vlist,tlist,elist,len,iord,ibase,-1) 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,itnode,itedge,ibndry,iord,ndof,itdof, + vx,vy,xm,ym,vz,va,icplt,vtype,tlist,vlist,elist, 1 len,qmax) kk=q(j) call updhp(kk,last,p,q,qual,1) enddo enddo 60 call clnup1(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,vz,va,icplt,iseed,ndof,itdof) c c improve geometry c call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,e,0,1,iord,ndof,itdof) call cedge5(nbf,itedge,ibedge,0) c do i=1,ntf do j=1,ndof ut(j,i)=vz(itdof(j,i)) enddo enddo if(icplt.ne.1) then do i=1,ntf do j=1,ndof vt(j,i)=va(itdof(j,i)) enddo enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clnup1(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,vz,va,icplt,mark,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),mark(*), 1 ibedge(2,*),itdof(ndof,*) real + 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 do j=1,ndof itdof(j,ntnew)=itdof(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) 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 now fix dofs c do i=1,ndf mark(i)=0 enddo do i=1,ntf do j=1,ndof mark(itdof(j,i))=1 enddo enddo ndnew=0 do i=1,ndf if(mark(i).ne.0) then ndnew=ndnew+1 mark(i)=ndnew vz(ndnew)=vz(i) if(icplt.ne.1) va(ndnew)=va(i) endif enddo ndf=ndnew do i=1,ntf do j=1,ndof itdof(j,i)=mark(itdof(j,i)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cvz(ntf,ndf,ndof,icplt,vx,vy,ut,vt,itnode,itdof, + vz,va,z) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itdof(ndof,*),idof(10) real + vx(*),vy(*),ut(ndof,*),vt(ndof,*),z(*),vz(*),va(*) c if(icplt.eq.1) then do i=1,ndf vz(i)=0.0e0 z(i)=0.0e0 enddo do i=1,ntf area=abs((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)))) call l2gmap(i,idof,ndof,itdof) do j=1,ndof ivj=idof(j) z(ivj)=z(ivj)+area vz(ivj)=vz(ivj)+area*ut(j,i) enddo enddo do i=1,ndf vz(i)=vz(i)/z(i) enddo else do i=1,ndf vz(i)=0.0e0 va(i)=0.0e0 z(i)=0.0e0 enddo do i=1,ntf area=abs((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)))) call l2gmap(i,idof,ndof,itdof) do j=1,ndof ivj=idof(j) 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,ndf vz(i)=vz(i)/z(i) va(i)=va(i)/z(i) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cplot(jp,itnode,ibndry,itedge,order, + vx,vy,iord,ndof,ut,xm,ym,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),jp(25),ibndry(6,*), 1 ibdy(243),order(*),ccolor,index(3,3) real + vx(*),vy(*),ut(ndof,*),q(3,3),t(25),xm(*),ym(*),x(9), 1 y(9),z(9),f(9),bx(3),by(3),bz(3),bf(3), 2 x0(9),y0(9),z0(9),f0(9),xt(3),yt(3),zt(3), 3 xp(243),yp(243),up(243),vp(243) 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.141592653589793e0 xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) if(i3d.eq.0) then zratio=0.0e0 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-abs(smin)*eps smax=smax+abs(smax)*eps if(zmax.gt.zmin) then zscale=(1.0e0-eps)*float(ncolor)/(zmax-zmin) else zscale=0.0e0 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=sqrt(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 c c compute triangle boundary c it=order(ii) call tbdy(xp,yp,up,vp,ibdy,ntri,it,itnode,ibndry,itedge, + vx,vy,xm,ym,q,i3d,iord,1,ndof,ut,ut) 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 xt(mm)=xp(m) yt(mm)=yp(m) zt(mm)=up(m) bf(mm)=(fscale(zt(mm),iscale,0)-zmin)*zscale bf(mm)=amax1(bf(mm),-1.0e0) bf(mm)=amin1(bf(mm),float(ncolor+1)) zt(mm)=zt(mm)*zratio xxm=q(1,1)*xt(mm)+q(2,1)*yt(mm) yym=q(1,2)*xt(mm)+q(2,2)*yt(mm)+q(3,2)*zt(mm) zzm=q(1,3)*xt(mm)+q(2,3)*yt(mm)+q(3,3)*zt(mm) bx(mm)=xxm*scale+xshift by(mm)=yym*scale+yshift bz(mm)=zzm*scale+zshift enddo c c compute the shade c if(nshade.gt.0) then x2=xt(2)-xt(1) y2=yt(2)-yt(1) z2=zt(2)-zt(1) x3=xt(3)-xt(1) y3=yt(3)-yt(1) z3=zt(3)-zt(1) xx=y2*z3-y3*z2 yy=z2*x3-z3*x2 zz=x2*y3-x3*y2 qq=sqrt(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.0e0) then ishade=-nshade else aa=amin1(1.0e0,abs(aa)) aa=(1.0e0-4.0e0*acos(aa)/pi)*float(nshade+1) ishade=min0(int(abs(aa)),nshade) if(aa.lt.0.0e0) ishade=-ishade endif endif 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=int(bf(kmin))+1 maxc=int(bf(kmax))+1 if(bf(kmax).eq.float(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.0e0 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)-float(j))*cc if(sm.ge.0.0e0) 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)-float(j))*cc if(sk.gt.0.0e0) then len=len+1 s=sk/(sk-sm) x(len)=x0(m)*s+x0(k)*(1.0e0-s) y(len)=y0(m)*s+y0(k)*(1.0e0-s) z(len)=z0(m)*s+z0(k)*(1.0e0-s) f(len)=f0(m)*s+f0(k)*(1.0e0-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=int(bf(kmin))+1 if(bf(kmin).gt.float(minc-1)) minc=minc+1 maxc=min0(ncolor,int(bf(kmax)))+1 c c move boundary edges slightly into the interior... c do m=minc,maxc s=(bf(kmax)-float(m-1))/(bf(kmax)-bf(kmin)) s=amax1(0.02e0,s) s=amin1(0.98e0,s) x(1)=bx(kmin)*s+bx(kmax)*(1.0e0-s) y(1)=by(kmin)*s+by(kmax)*(1.0e0-s) z(1)=bz(kmin)*s+bz(kmax)*(1.0e0-s) if(bf(kmid).gt.amax1(bf(kmin),float(m-1)))then s=(bf(kmid)-float(m-1))/(bf(kmid)-bf(kmin)) s=amax1(0.02e0,s) s=amin1(0.98e0,s) x(2)=bx(kmin)*s+bx(kmid)*(1.0e0-s) y(2)=by(kmin)*s+by(kmid)*(1.0e0-s) z(2)=bz(kmin)*s+bz(kmid)*(1.0e0-s) else if(bf(kmid).lt.bf(kmax)) then s=(bf(kmax)-float(m-1))/(bf(kmax)-bf(kmid)) s=amax1(0.02e0,s) s=amin1(0.98e0,s) x(2)=bx(kmid)*s+bx(kmax)*(1.0e0-s) y(2)=by(kmid)*s+by(kmax)*(1.0e0-s) z(2)=bz(kmid)*s+bz(kmax)*(1.0e0-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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine vplot(jp,itnode,ibndry,itedge,order, + vx,vy,iord,ndof,ut,vt,xm,ym,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),itedge(3,*), 1 ccolor,ibdy(243),ibndry(6,*),order(*),index(3,3) real + vx(*),vy(*),ut(ndof,*),vt(ndof,*),xm(*),ym(*),q(3,3), 1 x(10),y(10),t(25),z1(3),z2(3),rl(3), 2 bu(8),bv(8),b(3,8),bx(8),by(8),bz(8),z(10), 3 xp(243),yp(243),up(243),vp(243) 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.0e0 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.141592653589793e0 pi2=2.0e0*pi if(nshade.gt.0.and.zmin.ne.zmax) then zscale=(1.0e0-eps)*float(2*nshade+1)/(zmax-zmin) else zscale=0.0e0 endif zs=(zmax-zmin)/float(2*nshade+1) if(ncolor.gt.0) then nr=max0(64/ncolor,1) nnr=ncolor*nr dtheta=pi2/float(nnr) else dtheta=2.0e0*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(xp,yp,up,vp,ibdy,ntri,i,itnode,ibndry,itedge, + vx,vy,xm,ym,q,i3d,iord,0,ndof,ut,vt) call trnk(irank,i,ut,vt,rmax,eps) c do itri=1,3*ntri,3 do mm=1,3 m=mm+itri-1 x(mm)=xp(m) y(mm)=yp(m) z1(mm)=up(m) z2(mm)=vp(m) rl(mm)=sqrt(up(m)**2+vp(m)**2)*zratio enddo c call gbx(z1,z2,gmin,gmax,tmin,tmax,eps,irank) irmin=int((fscale(gmin,iscale,0)-zmin)*zscale)+1 irmax=int((fscale(gmax,iscale,0)-zmin)*zscale)+1 itmin=int(tmin/dtheta)+1 itmax=int(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.0e0 enddo b(j,j)=1.0e0 enddo else c c set up box c t1=float(it-1)*dtheta t2=float(it)*dtheta c1=cos(t1) c2=cos(t2) s1=sin(t1) s2=sin(t2) rr1=zmin+float(ir-1)*zs r1=amax1(fscale(rr1,iscale,1),gmin*0.99e0) rr2=zmin+float(ir)*zs r2=amin1(fscale(rr2,iscale,1),gmax*1.05e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine torder(jp,itnode,itedge,order,nblock,ilen,list, + tlist,vx,vy,cen,q,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),itedge(3,*),order(*), 1 nblock(*),list(*),tlist(2,*),tblock real + vx(*),vy(*),q(3,3),cen(*) data ibit/0/ c c color surface plot c iflag=0 eps=ceps(ibit) eps1=amax1(1.0e-4,eps*8.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine plinit(ip,rp,itnode,ibndry,itdof,itedge,ibedge,vx,vy, + iord,ndof,ut,vt,xm,ym,icplt,ierrsw,e,kdist,q,t,tl,jp,z, 1 jtnode,jbndry,jtdof,vx0,vy0,ua,va) c implicit real (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,*), 2 itdof(ndof,*),jtdof(ndof,*) real + vx(*),vy(*),ut(ndof,*),vt(ndof,*),xm(*),ym(*), 1 vx0(*),vy0(*),q(3,3),t(25),tl(25),rp(100),e(*), 2 bmin(5),bmax(5),z(*),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) ndf=ip(5) 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,z,iflag) call cedge5(nbf,itedge,ibedge,1) call cutr1(ntf,nvf,nbf,irgn,itnode,ibndry,vx,vy, + bmin,ndof,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 ibndry(5,newnbf)=0 endif enddo nbf=newnbf endif call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,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 do i=1,ntf do j=1,ndof itdof(j,i)=jtdof(j,i) enddo enddo c call cvz(ntf,ndf,ndof,icplt,vx,vy,ut,vt,itnode,itdof, + ua,va,z) ivtype=1 iseed=ivtype+nvf ipp=iseed+nvf iqq=ipp+nvf iqual=iqq+nvf c call crsn1(ntf,nvf,nbf,ndf,nvtrgt,icplt,itnode,ibndry, + iord,ndof,itdof,vx,vy,xm,ym,ut,vt,ua,va,itedge,ibedge, 1 z(ivtype),z(ipp),z(iqq),z(iqual),z(iseed),ibase) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,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 jp(24)=ndf c c find a box containing the solution c do i=1,3 do j=1,3 q(i,j)=0.0e0 enddo q(i,i)=1.0e0 enddo zratio=1.0e0 call pbox(ntf,itnode,ibndry,itedge,vx,vy,iord,ndof,icplt, + ut,vt,xm,ym,q,zratio,bmin,bmax,rp) 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)=amax1(bmax(1)-bmin(1),bmax(2)-bmin(2))/ + amax1(t(20)-t(19),bmax(3)-bmin(3)) else t(4)=0.0e0 endif if(amin1(bmin(3),t(19)).le.0.0e0.and.iscale.eq.1) iscale=2 jp(19)=iscale c c if(t(4).eq.0.0e0) i3d=0 if(i3d.eq.0) then zratio=0.0e0 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.0e0) nshade=0 else nshade=min0(nshade,5) if(amax1(abs(t(19)),abs(t(20))).eq.0.0e0) 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) call pbox(ntf,itnode,ibndry,itedge,vx,vy,iord,ndof,icplt, + ut,vt,xm,ym,q,zratio,bmin,bmax,rp) 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/amax1(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmax(1)+bmin(1))/2.0e0 t(2)=ys-scale*(bmax(2)+bmin(2))/2.0e0 t(5)=zs-scale*(bmax(3)+bmin(3))/2.0e0 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.0e0.or.jp(22).eq.0) then tl(2)=ys-scale*(bmax(4)+bmin(4))/2.0e0 tl(5)=zs-scale*(bmax(5)+bmin(5))/2.0e0 endif tl(12)=1.0e0 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pbox(ntf,itnode,ibndry,itedge,vx,vy,iord,ndof,icplt, + ut,vt,xm,ym,q,zratio,bmin,bmax,rp) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibdy(243),itedge(3,*), 1 index(3,3) real + vx(*),vy(*),ut(ndof,*),vt(ndof,*),xm(*),ym(*), 1 q(3,3),bmin(5),bmax(5),rp(100), 2 x(3),y(3),zu(3),zv(3),cc(3),z(3), 3 xp(243),yp(243),up(243),vp(243) save index data index/1,2,3,2,3,1,3,1,2/ c c find min and max function values for cplot/vplot c c initialize in case called with mpi on and ntf=0 c xx=(rp(87)+rp(88))/2.0e0 yy=(rp(89)+rp(90))/2.0e0 rr=q(1,1)*xx+q(2,1)*yy bmin(1)=rr bmax(1)=rr rr=q(1,2)*xx+q(2,2)*yy bmin(4)=rr bmax(4)=rr bmin(2)=rr bmax(2)=rr rr=q(1,3)*xx+q(2,3)*yy bmin(5)=rr bmax(5)=rr bmin(3)=rr bmax(3)=rr c ifirst=1 do i=1,ntf call tbdy(xp,yp,up,vp,ibdy,ntri,i,itnode,ibndry,itedge, + vx,vy,xm,ym,q,0,iord,icplt,ndof,ut,vt) do itri=1,3*ntri,3 do j=1,3 m=j+itri-1 x(j)=xp(m) y(j)=yp(m) if(icplt.eq.1) then z(j)=up(m)*zratio else zu(j)=up(m) zv(j)=vp(m) z(j)=sqrt(up(m)**2+vp(m)**2)*zratio endif if(ifirst.eq.1) then rr=q(1,1)*x(j)+q(2,1)*y(j) bmin(1)=rr bmax(1)=rr rr=q(1,2)*x(j)+q(2,2)*y(j) bmin(4)=rr bmax(4)=rr rr=rr+q(3,2)*z(j) bmin(2)=rr bmax(2)=rr rr=q(1,3)*x(j)+q(2,3)*y(j) bmin(5)=rr bmax(5)=rr rr=rr+q(3,3)*z(j) bmin(3)=rr bmax(3)=rr ifirst=0 else rr=q(1,1)*x(j)+q(2,1)*y(j) bmin(1)=amin1(rr,bmin(1)) bmax(1)=amax1(rr,bmax(1)) rr=q(1,2)*x(j)+q(2,2)*y(j) bmin(4)=amin1(rr,bmin(4)) bmax(4)=amax1(rr,bmax(4)) rr=rr+q(3,2)*z(j) bmin(2)=amin1(rr,bmin(2)) bmax(2)=amax1(rr,bmax(2)) rr=q(1,3)*x(j)+q(2,3)*y(j) bmin(5)=amin1(rr,bmin(5)) bmax(5)=amax1(rr,bmax(5)) rr=rr+q(3,3)*z(j) bmin(3)=amin1(rr,bmin(3)) bmax(3)=amax1(rr,bmax(3)) endif enddo if(icplt.eq.1) go to 10 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.0e0) then do j=1,3 cc(j)=cc(j)/det enddo if(amax1(cc(1),cc(2),cc(3)).le.1.0e0.and. + amin1(cc(1),cc(2),cc(3)).ge.0.0e0) 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) rr=q(1,2)*xx+q(2,2)*yy bmin(2)=amin1(rr,bmin(2)) rr=q(1,3)*xx+q(2,3)*yy bmin(3)=amin1(rr,bmin(3)) 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.0e0) then c2=-(u2*zu(j3)+v2*zv(j3))/aa if(c2.ge.0.0e0.and.c2.le.1.0e0) 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=sqrt(uu**2+vv**2)*zratio rr=q(1,2)*xx+q(2,2)*yy+q(3,2)*zz bmin(2)=amin1(rr,bmin(2)) rr=q(1,3)*xx+q(2,3)*yy+q(3,3)*zz bmin(3)=amin1(rr,bmin(3)) endif endif enddo 10 enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tribx3(c,len,bu,bv,ut,vt) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0-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.0e0) 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.0e0) 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.0e0-s) enddo endif m=kaft enddo endif enddo if(len.le.2) then len=0 return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tribx2(c,len,bu,bv,ut,vt) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.amax1(d23,d13)) then kmin=1 kmid=3 kmax=2 endif if(d23.ge.amax1(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=amax1(abs(at(1)),abs(at(2)),abs(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) if(f(j).eq.0.0e0) f(j)=1.0e-7 enddo c c compute kernal of a c au=(ut(1)+ut(2)+ut(3))/3.0e0 av=(vt(1)+vt(2)+vt(3))/3.0e0 qu=sqrt((ut(1)-au)**2+(ut(2)-au)**2+(ut(3)-au)**2) qv=sqrt((vt(1)-av)**2+(vt(2)-av)**2+(vt(3)-av)**2) tol=1.0e-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.0e0) 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.0e0) then len=len+1 s=f(k)/(f(k)-f(kbef)) bbu=bu(kbef)*s+bu(k)*(1.0e0-s) bbv=bv(kbef)*s+bv(k)*(1.0e0-s) c c solve 2 x 2 system based on kmax,kmin c if(abs(x2).gt.abs(y2)) then c(kmax,len)=(bbu-ut(kmin))/x2 else c(kmax,len)=(bbv-vt(kmin))/y2 endif c(kmin,len)=1.0e0-c(kmax,len) c(kmid,len)=0.0e0 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.0e0) 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.0e0) 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.0e0-s) enddo endif m=kaft enddo endif enddo if(len.le.2) then len=0 return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine gbx(wu,wv,gmin,gmax,tmin,tmax,eps,irank) c implicit real (a-h,o-z) implicit integer (i-n) integer + index(3,3) real + 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.141592653589793e0*2.0e0 c c check vertices c do j=1,3 tu(j)=wu(j) tv(j)=wv(j) rr(j)=sqrt(tu(j)**2+tv(j)**2) enddo gmax=rr(1) gmin=gmax tmin=pi2 tmax=0.0e0 do j=1,3 gmax=amax1(gmax,rr(j)) gmin=amin1(gmin,rr(j)) ang(j)=0.0e0 if(rr(j).gt.0.0e0) then arg=amin1(tu(j)/rr(j),1.0e0) arg=amax1(-1.0e0,arg) theta=acos(arg) if(tv(j).lt.0.0e0) theta=pi2-theta tmin=amin1(tmin,theta) tmax=amax1(tmax,theta) ang(j)=theta endif enddo if(gmax.le.0.0e0) then tmin=0.0e0 tmax=0.0e0 return endif if(irank.eq.1) then gmin=gmax tmin=tmax 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.0e0) then do j=1,3 cc(j)=cc(j)/det enddo if(amax1(cc(1),cc(2),cc(3)).le.1.0e0+eps.and. + amin1(cc(1),cc(2),cc(3)).gt.-eps) then gmin=0.0e0 tmin=0.0e0 tmax=pi2 return endif endif c c look on edges c umax=0.0e0 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.0e0) then c1=-(u1*tu(j3)+v1*tv(j3))/a1 if(c1.ge.0.0e0.and.c1.le.1.0e0) then ut=tu(j3)+c1*u1 vt=tv(j3)+c1*v1 s=sqrt(ut*ut+vt*vt) gmin=amin1(gmin,s) endif endif c c check for crossing of positive x axis c if(v1.ne.0.0e0) then c1=-tv(j3)/v1 if(c1.ge.0.0e0.and.c1.le.1.0e0) + umax=amax1(umax,tu(j3)+c1*u1) endif c enddo if(umax.gt.eps*gmax) then do j=1,3 if(tv(j).ge.0.0e0) ang(j)=ang(j)+pi2 enddo tmin=amin1(ang(1),ang(2),ang(3)) tmax=amax1(ang(1),ang(2),ang(3)) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine trnk(irank,i,ut,vt,rmax,eps) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=amax1(1.0e-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.0e0 av=(vv(1)+vv(2)+vv(3))/3.0e0 do j=1,3 ua(j)=uu(j)-au va(j)=vv(j)-av enddo qu=sqrt(ua(1)**2+ua(2)**2+ua(3)**2) qv=sqrt(va(1)**2+va(2)**2+va(3)**2) uv=abs(ua(1)*va(1)+ua(2)*va(2)+ua(3)*va(3)) if(qu*qv.gt.0.0e0) then dp=amax1(0.0e0,1.0e0-uv/(qu*qv)) else dp=0.0e0 endif c c test for rank 1 c if(amax1(qu,qv).lt.tol) then irank=1 c c test for rank 3 c else if(amin1(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tinit(jp,itnode,iclr,vx,vy,num,val) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),iclr(*),mcic(3,6),num(4) real + 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.141592653589793e0 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=sqrt(3.0e0)/2.0e0-1.0e-4 qpoor=0.6e0+1.0e-4 qmin=1.0e0 qave=0.0e0 do i=1,ntf r=abs(geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)) qmin=amin1(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.0e0/2.0e0+1.0e-4 apoor=2.0e0/3.0e0-1.0e-4 angmx=0.0e0 amxave=0.0e0 do i=1,ntf r=cangmx(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) angmx=amax1(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.0e0*angmx qave=180.0e0*amxave c else if(inplsw.eq.4) then bgood=acos(4.0e0/5.0e0)/pi-1.0e-4 bpoor=acos(13.0e0/14.0e0)/pi+1.0e-4 angmn=1.0e0 amnave=0.0e0 do i=1,ntf r=cangmn(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) angmn=amin1(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.0e0*angmn qave=180.0e0*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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clrmap(red,green,blue,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25) real + red(*),green(*),blue(*),r(7),g(7),b(7) save r,g,b data r/1.0e0,1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,1.0e0/ data g/0.0e0,0.0e0,1.0e0,1.0e0,1.0e0,0.0e0,0.0e0/ data b/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,1.0e0,1.0e0/ c c set up a color map c ncolor=jp(5) icplt=jp(4) nshade=jp(16) mxcolr=jp(17) maplen=jp(18) gamma=0.7e0 theta=1.0e0 c c background color (white) c red(1)=1.0e0 green(1)=1.0e0 blue(1)=1.0e0 c c line-drawing color (black) c red(2)=0.0e0 green(2)=0.0e0 blue(2)=0.0e0 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.0e0/float(jcolor-1) else h=6.0e0/float(jcolor) endif do ii=2,jcolor i=ii+2 x=6.0e0-h*float(ii-1) k=1+int(x) dl=float(k)-x dr=1.0e0-dl red(i)=dl*r(k)+dr*r(k+1) red(i)=amax1(0.0e0,red(i))**gamma red(i)=amin1(1.0e0,red(i)) green(i)=dl*g(k)+dr*g(k+1) green(i)=amax1(0.0e0,green(i))**gamma green(i)=amin1(1.0e0,green(i)) blue(i)=dl*b(k)+dr*b(k+1) blue(i)=amax1(0.0e0,blue(i))**gamma blue(i)=amin1(1.0e0,blue(i)) enddo c c shading c 20 if(nshade.eq.0) return if(icplt.ne.0) then bmax=0.5e0/float(nshade) wmax=0.5e0/float(nshade) else bmax=0.45e0/float(nshade) wmax=0.75e0/float(nshade) endif do j=1,nshade jplus=j*ncolor+2 jminus=jplus+nshade*ncolor fb=(1.0e0-float(j)*bmax)**theta fw=(1.0e0-float(j)*wmax)**theta w=1.0e0-fw do i=1,ncolor k=i+jplus red(k)=red(i+2)*fw+w red(k)=amax1(red(k),0.0e0) red(k)=amin1(red(k),1.0e0) green(k)=green(i+2)*fw+w green(k)=amax1(green(k),0.0e0) green(k)=amin1(green(k),1.0e0) blue(k)=blue(i+2)*fw+w blue(k)=amax1(blue(k),0.0e0) blue(k)=amin1(blue(k),1.0e0) k=i+jminus red(k)=red(i+2)*fb red(k)=amax1(red(k),0.0e0) red(k)=amin1(red(k),1.0e0) green(k)=green(i+2)*fb green(k)=amax1(green(k),0.0e0) green(k)=amin1(green(k),1.0e0) blue(k)=blue(i+2)*fb blue(k)=amax1(blue(k),0.0e0) blue(k)=amin1(blue(k),1.0e0) enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function ccolor(icolor,ishade,jp) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine incirc(x1,y1,x2,y2,x3,y3,xc,yc,r) c implicit real (a-h,o-z) implicit integer (i-n) c c compute center of inscribed circle c h1=sqrt((x2-x3)**2+(y2-y3)**2) h2=sqrt((x3-x1)**2+(y3-y1)**2) h3=sqrt((x1-x2)**2+(y1-y2)**2) h=(h1+h2+h3)/2.0e0 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=sqrt((xc-s1)**2+(yc-t1)**2) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine arc(x1,y1,x2,y2,xc,yc,theta1,theta2,r,alen) c implicit real (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.141592653589793e0 v1=x1-xc w1=y1-yc r1=sqrt(v1**2+w1**2) v1=v1/r1 w1=w1/r1 c v2=x2-xc w2=y2-yc r2=sqrt(v2**2+w2**2) v2=v2/r2 w2=w2/r2 c vm=(v1+v2)/2.0e0 wm=(w1+w2)/2.0e0 dd=sqrt(vm**2+wm**2) vm=vm/dd wm=wm/dd c r=sqrt(r1*r2) theta=amax1(-1.0e0,vm) theta=amin1(1.0e0,theta) theta=acos(theta) if(wm.lt.0.0e0) theta=-theta c dtheta=amin1(1.0e0,dd) dtheta=acos(dtheta) if(v1*wm-w1*vm.gt.0.0e0) dtheta=-dtheta theta1=(theta+dtheta)/pi theta2=(theta-dtheta)/pi alen=abs(dtheta*r*2.0e0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tbdy(xp,yp,up,vp,ibdy,ntri,it,itnode,ibndry,itedge, + vx,vy,xm,ym,q,i3d,iord,icplt,ndof,ut,vt) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibdy(*),itnode(5,*),itedge(3,*),ibndry(6,*), 1 iadj(3),index(3,3),icurv(3) real + vx(*),vy(*),xm(*),ym(*),c1(10,10),c2(10,10), 1 c3(10,10),q(3,3),xr(3),dr(3),rad(3),theta1(3),theta2(3), 2 ut(ndof,*),vt(ndof,*),xp(*),yp(*),up(*),vp(*),gx(10), 3 gy(10),b1(10,10),b2(10,10),b3(10,10),c(3),gv(10), 4 x(10,10),y(10,10),u(10,10),v(10,10) 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.141592653589793e0 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=abs(theta2(j)-theta1(j))*32.0e0 mm=min0(int(aa+0.5e0),8) irefn=max0(irefn,mm) endif endif enddo if(icplt.ge.0) then if(iord.eq.2) then irefn=max0(4,irefn) irefn=((irefn+1)/2)*2 else if(iord.eq.3) then irefn=max0(6,irefn) irefn=((irefn+2)/3)*3 endif endif c c set up initial baricentric coodinates c do k=1,irefn+1 do j=1,irefn+2-k c2(k,j)=float(k-1)/float(irefn) c3(k,j)=float(j-1)/float(irefn) c1(k,j)=1.0e0-c2(k,j)-c3(k,j) b1(k,j)=c1(k,j) b2(k,j)=c2(k,j) b3(k,j)=c3(k,j) x(k,j)=0.0e0 y(k,j)=0.0e0 u(k,j)=0.0e0 v(k,j)=0.0e0 enddo enddo c c simple case c if(irefn.eq.1) then x(1,1)=vx(itnode(1,it)) x(2,1)=vx(itnode(2,it)) x(1,2)=vx(itnode(3,it)) y(1,1)=vy(itnode(1,it)) y(2,1)=vy(itnode(2,it)) y(1,2)=vy(itnode(3,it)) if(icplt.ge.0) then u(1,1)=ut(1,it) u(2,1)=ut(2,it) u(1,2)=ut(3,it) endif if(icplt.eq.0) then v(1,1)=vt(1,it) v(2,1)=vt(2,it) v(1,2)=vt(3,it) endif go to 30 endif c c modify barycentric coordinates for curved edges c 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))/float(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*float(m-1))*pi xx=xm(kt)+rad(j)*cos(tt)-vx(iv3) yy=ym(kt)+rad(j)*sin(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.0e0-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.0e0-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.0e0-c1(m,1)-c2(m,1) endif enddo 10 continue c c smoothing c if(iord.eq.1) then itmax=100 tol=1.e-2 do i=1,itmax cc=0.0e0 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.0e0 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.0e0 cc=amax1(cc,abs(cc2-c2(k,j)),abs(cc3-c3(k,j))) c2(k,j)=cc2 c3(k,j)=cc3 c1(k,j)=1.0e0-cc2-cc3 enddo enddo if(cc.le.tol) go to 20 enddo 20 iv1=itnode(1,it) iv2=itnode(2,it) iv3=itnode(3,it) do k=1,irefn+1 do j=1,irefn+2-k x(k,j)=c1(k,j)*vx(iv1)+c2(k,j)*vx(iv2) + +c3(k,j)*vx(iv3) y(k,j)=c1(k,j)*vy(iv1)+c2(k,j)*vy(iv2) + +c3(k,j)*vy(iv3) if(icplt.ge.0) u(k,j)=c1(k,j)*ut(1,it)+ 1 c2(k,j)*ut(2,it)+c3(k,j)*ut(3,it) if(icplt.eq.0) v(k,j)=c1(k,j)*vt(1,it)+ 1 c2(k,j)*vt(2,it)+c3(k,j)*vt(3,it) enddo enddo c c isoparametric map for quadratics c else gx(1)=vx(itnode(1,it)) gy(1)=vy(itnode(1,it)) gx(2)=vx(itnode(2,it)) gy(2)=vy(itnode(2,it)) gx(3)=vx(itnode(3,it)) gy(3)=vy(itnode(3,it)) if(iord.eq.2) then jm=irefn/2+1 gx(4)=c1(jm,jm)*gx(1)+c2(jm,jm)*gx(2)+c3(jm,jm)*gx(3) gy(4)=c1(jm,jm)*gy(1)+c2(jm,jm)*gy(2)+c3(jm,jm)*gy(3) gx(5)=c1(1,jm)*gx(1)+c2(1,jm)*gx(2)+c3(1,jm)*gx(3) gy(5)=c1(1,jm)*gy(1)+c2(1,jm)*gy(2)+c3(1,jm)*gy(3) gx(6)=c1(jm,1)*gx(1)+c2(jm,1)*gx(2)+c3(jm,1)*gx(3) gy(6)=c1(jm,1)*gy(1)+c2(jm,1)*gy(2)+c3(jm,1)*gy(3) else c c isoparametric map for cubics c j2=irefn/3+1 j3=2*irefn/3+1 gx(4)=c1(j3,j2)*gx(1)+c2(j3,j2)*gx(2)+c3(j3,j2)*gx(3) gy(4)=c1(j3,j2)*gy(1)+c2(j3,j2)*gy(2)+c3(j3,j2)*gy(3) gx(5)=c1(j2,j3)*gx(1)+c2(j2,j3)*gx(2)+c3(j2,j3)*gx(3) gy(5)=c1(j2,j3)*gy(1)+c2(j2,j3)*gy(2)+c3(j2,j3)*gy(3) gx(6)=c1(1,j3)*gx(1)+c2(1,j3)*gx(2)+c3(1,j3)*gx(3) gy(6)=c1(1,j3)*gy(1)+c2(1,j3)*gy(2)+c3(1,j3)*gy(3) gx(7)=c1(1,j2)*gx(1)+c2(1,j2)*gx(2)+c3(1,j2)*gx(3) gy(7)=c1(1,j2)*gy(1)+c2(1,j2)*gy(2)+c3(1,j2)*gy(3) gx(8)=c1(j2,1)*gx(1)+c2(j2,1)*gx(2)+c3(j2,1)*gx(3) gy(8)=c1(j2,1)*gy(1)+c2(j2,1)*gy(2)+c3(j2,1)*gy(3) gx(9)=c1(j3,1)*gx(1)+c2(j3,1)*gx(2)+c3(j3,1)*gx(3) gy(9)=c1(j3,1)*gy(1)+c2(j3,1)*gy(2)+c3(j3,1)*gy(3) gx(10)=(gx(1)+gx(2)+gx(3)+gx(4)+gx(5)+gx(6)+ + gx(7)+gx(8)+gx(9))/9.0e0 gy(10)=(gy(1)+gy(2)+gy(3)+gy(4)+gy(5)+gy(6)+ + gy(7)+gy(8)+gy(9))/9.0e0 endif do k=1,irefn+1 do j=1,irefn+2-k c(1)=b1(k,j) c(2)=b2(k,j) c(3)=b3(k,j) call beval1(c,gv,iord) x(k,j)=0.0e0 y(k,j)=0.0e0 u(k,j)=0.0e0 v(k,j)=0.0e0 do m=1,ndof x(k,j)=x(k,j)+gv(m)*gx(m) y(k,j)=y(k,j)+gv(m)*gy(m) if(icplt.ge.0) u(k,j)=u(k,j)+gv(m)*ut(m,it) if(icplt.eq.0) v(k,j)=v(k,j)+gv(m)*vt(m,it) enddo enddo enddo endif c c do orientation c 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 xx=x(k,j) x(k,j)=x(jj+1-k,j) x(jj+1-k,j)=xx yy=y(k,j) y(k,j)=y(jj+1-k,j) y(jj+1-k,j)=yy uu=u(k,j) u(k,j)=u(jj+1-k,j) u(jj+1-k,j)=uu vv=v(k,j) v(k,j)=v(jj+1-k,j) v(jj+1-k,j)=vv 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 xx=x(k,j) x(k,j)=x(k,kk+1-j) x(k,kk+1-j)=xx yy=y(k,j) y(k,j)=y(k,kk+1-j) y(k,kk+1-j)=yy uu=u(k,j) u(k,j)=u(k,kk+1-j) u(k,kk+1-j)=uu vv=v(k,j) v(k,j)=v(k,kk+1-j) v(k,kk+1-j)=vv 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 xx=x(k+1-j,j) x(k+1-j,j)=x(j,k+1-j) x(j,k+1-j)=xx yy=y(k+1-j,j) y(k+1-j,j)=y(j,k+1-j) y(j,k+1-j)=yy uu=u(k+1-j,j) u(k+1-j,j)=u(j,k+1-j) u(j,k+1-j)=uu vv=v(k+1-j,j) v(k+1-j,j)=v(j,k+1-j) v(j,k+1-j)=vv 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 xp(k+1)=x(i,j) yp(k+1)=y(i,j) up(k+1)=u(i,j) vp(k+1)=v(i,j) xp(k+2)=x(i+1,j) yp(k+2)=y(i+1,j) up(k+2)=u(i+1,j) vp(k+2)=v(i+1,j) xp(k+3)=x(i,j+1) yp(k+3)=y(i,j+1) up(k+3)=u(i,j+1) vp(k+3)=v(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 xp(k+1)=x(i+1,j) yp(k+1)=y(i+1,j) up(k+1)=u(i+1,j) vp(k+1)=v(i+1,j) xp(k+2)=x(i+1,j+1) yp(k+2)=y(i+1,j+1) up(k+2)=u(i+1,j+1) vp(k+2)=v(i+1,j+1) xp(k+3)=x(i,j+1) yp(k+3)=y(i,j+1) up(k+3)=u(i,j+1) vp(k+3)=v(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- integer function tblock(itnode,it,iside,vx,vy,q,eps) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),index(3,3) real + 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))/sqrt(c**2+s**2) tblock=0 if(qq.gt.eps) tblock=1 if(qq.lt.-eps) tblock=-1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bblock(ntf,itnode,itedge,ilen,list,tlist,vx,vy,q, + cen,eps,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),list(*),tlist(2,*), 1 tblock,endin,endout,index(3,3) real + 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=amax1(1.0e-4,eps*8.0e0) 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.0e0 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.0e0 hmax=amax1(hmax,abs(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=amax1(x1i,x2i) yimax=amax1(y1i,y2i) ximin=amin1(x1i,x2i) yimin=amin1(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.0e0) go to 70 if(ximax.le.cen(jj)-hmax/2.0e0) 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=amax1(x1j,x2j) xjmin=amin1(x1j,x2j) yjmax=amax1(y1j,y2j) yjmin=amin1(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=(amax1(ximin,xjmin)+amin1(ximax,xjmax))/2.0e0 yi=(y1i*(x2i-xx)+y2i*(xx-x1i))/(x2i-x1i) yj=(y1j*(x2j-xx)+y2j*(xx-x1j))/(x2j-x1j) if(yi-8.0e0*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=82 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkheap(i,llen,d,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + list(*) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd0(t) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 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.0e0) then xl=amax1(x0,t(8)) xr=amin1(x1,t(9)) yb=amax1(y0,t(10)) yt=amin1(y1,t(11)) c c mark the box in the window c x(1)=(xl+xr)/2.0e0 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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine linit(t,q) c implicit real (a-h,o-z) implicit integer (i-n) real + t(25),q(3,3) data ibit/0/ c c initial for legends and graphs c size=0.9e0 do i=1,25 t(i)=0.0e0 enddo t(3)=1.0e0 t(5)=0.5e0 t(7)=ceps(ibit) t(12)=1.0e0 t(14)=size t(15)=0.5e0 t(16)=0.5e0 t(17)=0.5e0 do i=1,3 do j=1,3 q(i,j)=0.0e0 enddo q(i,i)=1.0e0 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine zoombx(rp,t) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=amax1(1.0e0,rp(10)) cenx=amax1(0.0e0,rp(11)) cenx=amin1(1.0e0,cenx) ceny=amax1(0.0e0,rp(12)) ceny=amin1(1.0e0,ceny) h=1.0e0/(2.0e0*rmag) hx=xs-size/2.0e0 hy=ys-size/2.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkrot(nx,ny,nz,q) c implicit real (a-h,o-z) implicit integer (i-n) real + q(3,3),d(3) c c compute rotation matrix c d(1)=float(nx) d(2)=float(ny) d(3)=float(nz) do i=1,3 do j=1,3 q(j,i)=0.0e0 enddo q(i,i)=1.0e0 enddo dl=sqrt(d(1)*d(1)+d(2)*d(2)+d(3)*d(3)) if(dl.gt.0.0e0) then do i=1,3 q(i,3)=d(i)/dl enddo endif dl=sqrt(q(1,3)*q(1,3)+q(2,3)*q(2,3)) if(dl.gt.0.0e0) 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.0e0) q(1,1)=-q(1,1) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd1(jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor real + 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.0e0 xr=xs+size/2.0e0 yb=ys-size/2.0e0 yt=ys+size/2.0e0 s3=sqrt(3.0e0)/2.0e0 c c compute ncol and nrow c s=sqrt(float(ncolor)/3.0e0) is=int(s) if(s-float(is).gt.1.e-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)/float(ncol) dy=(yt-yb)/float(nrow) if(dx.gt.3.0e0*dy) dx=3.0e0*dy if(dx.lt.3.0e0*dy) dy=dx/3.0e0 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+float(nc-1)*dx x2=xl+float(nc)*dx xm=(2.0e0*x2+x1)/3.0e0 y1=yt-float(nr)*dy y2=yt-float(nr-1)*dy ym=(y1+y2)/2.0e0 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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd2(jp,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,mcic(3,6) real + 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.0e0 xr=xs+size/2.0e0 yb=ys-size/2.0e0 yt=ys+size/2.0e0 s3=2.0e0/sqrt(3.0e0) dx=(xr-xl)/14.5e0 dy=(yt-yb)/6.0e0 h=amin1(0.9e0*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.25e0*dx xxr=xxl+15.0e0*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-float(i+1)*dy c c triangle icon c if(i.le.3) then x(1)=xl+0.25e0*dx x(2)=x(1)+s3*h x(3)=(x(1)+x(2))/2.0e0 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.25e0*dx xxr=xxl+7.0e0*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.25e0*dx xxr=xxl+5.0e0*dx call htext(xxl,yyl,xxr,yyr,nchr,ichr(ii:ii),1,qq,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd3(jp,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,nchr(15) real + 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)/float(2*nshade+1) do i=1,2*nshade+2 zz=funmin+df*float(i-1) f(i)=fscale(zz,iscale,1) enddo c xm=xs+0.15e0*size ym=ys rmax=0.35e0*size pi=3.141592653589793e0 c if(t(19).gt.0.0e0) then rmin=rmax*0.15e0 else rmin=0.0e0 endif dr=(rmax-rmin)/float(2*nshade+1) dt=2.0e0*pi/float(ncolor) nn=max0(64/ncolor,2) nn=min0(nn,48) dq=dt/float(nn-1) n2=2*nn n3=n2+1 c c draw regions c do i=1,ncolor do j=1,2*nshade+1 theta=float(i-1)*dt r1=rmin+float(j-1)*dr r2=rmin+float(j)*dr k=j-nshade-1 ic=ccolor(i,k,jp) do k=1,nn ang=theta+float(k-1)*dq c=cos(ang) s=sin(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.45e0 yt=ys+size*0.45e0 xl=xs-size*0.5e0 xr=xl+size*0.05e0 xc=xr+0.02e0*size xf=xc+0.2e0*size c dy=(yt-yb)/float(2*nshade+1) do i=1,2*nshade+1 k=i-nshade-1 ic=ccolor(1,k,jp) x(1)=xl y(1)=yb+float(i-1)*dy z(1)=zshift x(2)=xr y(2)=y(1) z(2)=zshift x(3)=x(2) y(3)=yb+float(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.0e0) 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*float(i-1)-dy/2.0e0 yf=yc+dy call htext(xc,yc,xf,yf,mxchr,ichr(i),-1,qq,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd4(jp,t,kdist) c implicit real (a-h,o-z) implicit integer (i-n) integer + nchr(20),jp(25),ccolor,kdist(22) real + 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)/float(ncolor) do i=1,ncolor+1 zz=zmin+df*float(i-1) f(i)=fscale(zz,iscale,1) enddo c c make boxes for each color c xf=xs xi=xf-size*0.45e0 xc=xf+0.04e0*size xx=xc+0.4e0*size yi=ys-size*0.45e0 yf=ys+size*0.45e0 yinc=0.04e0*size tic=0.02e0*size if(icolor.eq.ncolor) yf=yi+(yf-yi)*ncolor/11.0e0 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)/float(icolor) do i=1,icolor y(1)=yi+dy*float(i) y(2)=y(1) y(3)=yi+dy*float(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)/float(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.0e0) then num=2*ncolor kdm=0 do i=1,num kdm=max0(kdm,kdist(i)) enddo ddy=(yf-yi)/float(num) xxi=xi+0.05e0*(xf-xi) ddx=0.9e0*(xf-xi) do i=1,num j=2*i-1 x(j)=xxi+ddx*(float(kdist(i))/float(kdm)) x(j+1)=x(j) y(j+1)=yi+ddy*float(i) y(j)=yi+ddy*float(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.0e0) 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*float(i-1)-yinc/2.0e0 yf=yc+yinc call htext(xc,yc,xx,yf,mxchr,ichr(i),-1,qq,tt,2) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cdist(jp,t,e,kdist) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),kdist(22) real + 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=float(num)/(zmax-zmin) else dd=0.0e0 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,int(ff)+1) iq=min0(num,iq) kdist(iq)=kdist(iq)+1 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd5(jp,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,mcic(4) real + 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.0e0 xr=xs+size/2.0e0 yb=ys-size/2.0e0 yt=ys+size/2.0e0 dx=(xr-xl)/14.5e0 dy=(yt-yb)/7.0e0 h=amin1(0.9e0*dy,dx) c call fstr(ichr,nchr,title,0) xxl=xl+2.25e0*dx xxr=xxl+15.0e0*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-float(i+1)*dy c c square icon c x(1)=xl+0.25e0*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.25e0*dx xxr=xxl+15.0e0*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-float(i+5)*dy c c label c call fstr(ichr,nchr,mnmx(i),0) xxl=xl+0.25e0*dx xxr=xxl+3.0e0*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.25e0*dx xxr=xr call htext(xxl,yyl,xxr,yyr,nchr,ichr(ii:ii),1,q,tt,2) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd6(jp,iptr) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,mcic(50),jc(6) real + 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.0e0 xr=xs+size/2.0e0 yb=ys-size/2.0e0 yt=ys+size/2.0e0 dx=(xr-xl)/20.5e0 dy=(yt-yb)/9.0e0 h=amin1(0.9e0*dy,dx) c call fstr(ichr,nchr,title(iptr),0) xxl=xl+2.25e0*dx xxr=xxl+17.0e0*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-float(i-i1+2)*dy c c square icon c x(1)=xl+0.25e0*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.25e0*dx xxr=xxl+20.0e0*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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine legnd7(jp,pstat) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor real + t(25),q(3,3),sfact(4),x(10),y(10),z(10),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.0e0 smn=0.0e0 s2=alog(2.0e0) do j=jbeg,jend sr(j)=0.0e0 do i=1,nproc sr(j)=sr(j)+pstat(j,i) if(pstat(j,i).le.0) return enddo sr(j)=float(nproc)/sr(j) do i=1,nproc ss=alog(pstat(j,i)*sr(j))/s2 smx=amax1(smx,ss) smn=amin1(smn,ss) enddo enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0e0 yshift=t(16)-size/2.0e0 zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8e0/sqrt(2.0e0) sfact(2)=0.8e0 sfact(3)=0.6e0 sfact(4)=0.6e0 c c set up input arrays c h=0.025e0 h2=h/2.0e0 xl=3.0e0*h xr=1.0e0-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=int(smn) if(smn.lt.float(imin)) imin=imin-1 imax=int(smx) if(smx.gt.float(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.2e0*h yyr=yyl+h ym=yyl+h2 hx=(xr-xl)/2.0e0 do j=1,2 call fstr(ichr,nchr,label(j),0) ichr(nchr+1:nchr+1)=' ' xxl=xl+float(j-1)*hx xxr=xxl+float(nchr)*h xxm=xxr+h dxm=h*1.5e0 dym=h*1.5e0 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)/float(jmax-jmin) dy=(yr-yl)/float(imax-imin) do j=jbeg,jend itype=j-jbeg+3 hh=h*sfact(itype)*2.0e0 do i=1,nproc xs=xl+dx*float(i) ss=alog(pstat(j,i)*sr(j))/s2 ys=yl+dy*(ss-float(imin)) xx=xs*size+xshift yy=ys*size+yshift icolor=ccolor(i,0,jp) call symbl(xs,ys,hh,hh,itype,icolor,t) c x(2)=xx y(2)=yy z(2)=zshift if(i.gt.1) call pline(x,y,z,2,2) x(1)=xx y(1)=yy z(1)=zshift enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function fscale(f,iscale,invrse) c implicit real (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=alog(f) return else fscale=exp(f) return endif else c c arcsinh scale c if(invrse.eq.0) then af=abs(f) if(af.lt.1.0e0) then q=sqrt(1.0e0+f*f)+af fx=alog(q) fscale=fx+(af-sinh(fx))/cosh(fx) else q=1.0e0/f q=sqrt(1.0e0+q*q)+1.0e0 fscale=alog(q)+alog(af) endif if(f.lt.0.0e0) fscale=-fscale return else fscale=sinh(f) return endif endif end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dgrid c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 size=tt(14) x0=tt(15)-size/2.0e0 x1=tt(15)+size/2.0e0 y0=tt(16)-size/2.0e0 y1=tt(16)+size/2.0e0 c c mark magnified area c icolor=1 z(1)=zshift z(2)=zshift h=size/20.0e0 do i=1,10 x(1)=x0+float(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+float(2*i-1)*h y(2)=y(1) call pline(x,y,z,2,icolor) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine vlabel(jp,itnode,vx,vy,rad,vtype,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),index(3,3),vtype(*) real + 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) numbrs=jp(21) scale=t(3) c rmax=0.05e0/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=sqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2)/2.1e0 rad(j1)=amin1(h,rad(j1)) rad(j2)=amin1(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=float(nchr)*20.0e0/21.0e0 delta=r/sqrt(1.0e0+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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine blabel(jp,itnode,ibndry,ibedge,vx,vy,xm,ym,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ibndry(6,*),itnode(5,*),ibedge(2,*),index(3,3) real + 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.05e0/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=sqrt((x2-x3)**2+(y2-y3)**2)/2.5e0 d2=sqrt((x2+x3)**2+(y2+y3)**2)/5.0e0 r=amin1(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.0e0 yc=(vy(j1)+vy(j2))/2.0e0 endif c call sint(ichr,nchr,i) ratio=float(nchr)*20.0e0/21.0e0 delta=r/sqrt(1.0e0+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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tlabel(jp,itnode,vx,vy,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jp(25) real + vx(*),vy(*),q(3,3),t(25) character*80 + ichr c ntf=jp(1) scale=t(3) c rmax=0.05e0/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=amin1(rmax,r) c c compute number width (max 10 digits) c call sint(ichr,nchr,it) ratio=float(nchr)*20.0e0/21.0e0 delta=r/sqrt(1.0e0+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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rlabel(jp,itnode,jt,vx,vy,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jp(25),jt(*) real + vx(*),vy(*),q(3,3),t(25) character*80 + ichr c ntf=jp(8) scale=t(3) c rmax=0.05e0/scale c do irgn=1,ntf c c compute center of inscribed circle c xc=0.0e0 yc=0.0e0 r=0.0e0 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=amin1(rmax,r) c c compute number width (max 10 digits) c call sint(ichr,nchr,irgn) ratio=float(nchr)*20.0e0/21.0e0 delta=r/sqrt(1.0e0+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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dlabel(jp,itnode,xc,yc,r,vx,vy,q,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),jp(25) real + 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.05e0/scale c do i=1,nproc r(i)=-1.0e0 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)=amin1(rmax,r(irgn)) c c compute number width (max 10 digits) c call sint(ichr,nchr,irgn) ratio=float(nchr)*20.0e0/21.0e0 delta=r(irgn)/sqrt(1.0e0+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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine title0(title,isw) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 xr=t(15)+size/2.0e0 if(isw.eq.1) xr=xr+0.5e0 yb=t(16)+size/2.0e0 yt=t(16)+t(3)/2.0e0 yl=yb+(yt-yb)*0.25e0 yr=yb+(yt-yb)*0.75e0 call fstr(ichr,nchr,title,0) call htext(xl,yl,xr,yr,nchr,ichr,0,q,t,2) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine gphplt(ip,rp,sp,w) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),jp(25) real + w(*),red(10),green(10),blue(10),rp(100) character*80 + sp(100) c c storage allocation c if(ip(6).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(90) itdof=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(82) iprob=iabs(ip(7)) mxcolr=max0(2,ip(51)) igrsw=ip(54) if(igrsw.gt.6.or.igrsw.lt.-5) igrsw=0 c mpisw=ip(48) nproc=ip(49) irgn=ip(50) jp(1)=ip(1) jp(2)=nproc jp(3)=irgn 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pgraph(jp,hist,time,path,pstat,ka,ip,rp,sp, + atime,ptime) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ip(100),ka(*) real + 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 history, 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) c*** if(igrsw.eq.0) call nwtprt(hist(1,11)) 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) c*** call aveprt(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) call pframe(-1) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine prtip(ip,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),jp(25),ccolor,icolor(3),ic(100) real + 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.0e0 dx=(size+0.5e0)/4.0e0 h=amin1(dy*0.9e0,dx/20.0e0) c do i=1,25 do j=1,4 k=(j-1)*25+i xl=float(j-1)*dx+.05e0+dx/10.0e0 xr=xl+dx/2.0e0 yl=0.95e0-(float(i)*dy) yr=yl+h call htext(xl,yl,xr,yr,10,name(k),-1,q,t,ic(k)) xl=xl+dx/2.0e0 xr=xl+3.0e0*dx/10.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine prtrp(rp,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,icolor(3),ic(100) real + 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.0e0 dx=(size+0.5e0)/4.0e0 h=amin1(dy*0.9e0,dx/20.0e0) c do i=1,25 do j=1,4 k=(j-1)*25+i xl=float(j-1)*dx+.05e0+dx/22.0e0 xr=xl+10.0e0*dx/22.0e0 yl=0.95e0-(float(i)*dy) yr=yl+h call htext(xl,yl,xr,yr,10,name(k),-1,q,t,ic(k)) xl=xr+dx/22.0e0 xr=xl+9.0e0*dx/22.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine prtsp(sp,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor,icolor(3),ic(100) real + 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.0e0 dx=(size+0.5e0)/4.0e0 h=amin1(dy*0.9e0,dx/20.0e0) c do i=1,25 do j=1,2 k=(j-1)*25+i xl=float(j-1)*dx*2.0e0+.05e0+dx/10.0e0 xr=xl+dx/2.0e0 yl=0.95e0-(float(i)*dy) yr=yl+h call htext(xl,yl,xr,yr,10,name(k),-1,q,t,ic(k)) xl=xl+dx/2.0e0 xr=xl+1.5e0*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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lbplt(jp,pstat,ipix) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(8),ccolor real + t(25),q(3,3),sfact(4),x(10),y(10),z(10),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.0e0 smn=0.0e0 s2=alog(2.0e0) do j=jbeg,jend sr(j)=0.0e0 do i=1,nproc sr(j)=sr(j)+pstat(j,i) if(pstat(j,i).le.0) return enddo sr(j)=float(nproc)/sr(j) do i=1,nproc ss=alog(pstat(j,i)*sr(j))/s2 smx=amax1(smx,ss) smn=amin1(smn,ss) enddo enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0e0 yshift=t(16)-size/2.0e0 zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8e0/sqrt(2.0e0) sfact(2)=0.8e0 sfact(3)=0.6e0 sfact(4)=0.6e0 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.025e0 h2=h/2.0e0 xl=3.0e0*h xr=1.0e0-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=int(smn) if(smn.lt.float(imin)) imin=imin-1 imax=int(smx) if(smx.gt.float(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.2e0*h yyr=yyl+h ym=yyl+h2 hx=(xr-xl)/3.5e0 do j=1,2 call fstr(ichr,nchr,label(j),0) ichr(nchr+1:nchr+1)=' ' xxl=xl+float(j-1)*hx xxr=xxl+float(nchr)*h xxm=(xxl+xxr)/2.0e0 dxm=xxr-xxl dym=2.0e0*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)/float(jmax-jmin) dy=(yr-yl)/float(imax-imin) do j=jbeg,jend itype=1 hh=h*sfact(itype) do i=1,nproc xs=xl+dx*float(i) ss=alog(pstat(j,i)*sr(j))/s2 ys=yl+dy*(ss-float(imin)) xx=xs*size+xshift yy=ys*size+yshift call symbl(xs,ys,hh,hh,itype,icolor(j),t) c x(2)=xx y(2)=yy z(2)=zshift if(i.gt.1) call pline(x,y,z,2,2) x(1)=xx y(1)=yy z(1)=zshift enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine timplt(time,jp) c implicit real (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) real + 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.0e0 yy=t(16)-size/2.0e0 c do i=1,ll+1 iptr(i)=0 enddo do i=1,num0 if(time(2,i).gt.0.0e0) 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.0e0 s2=0.0e0 do i=1,num0-1 if(time(2,i).gt.0.0e0) 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.0e0) return ss=1.0e0/abs(s2) c xxl=xx xxr=xx+size yyb=yy yyt=yy+size dx=(xxr-xxl)/4.3e0 dy=(yyt-yyb)/(float(num)+3.75e0) h=size/43.0e0 h2=h/2.0e0 c c banner c yl=yyt-dy yr=yl+h ym=yl+h2 hx=(xxr-xxl)/4.0e0 do j=1,2 call fstr(ichr,nchr,label(j),0) xl=xxl+float(j-1)*hx xr=xl+float(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.2e0*dx x(2)=xxr x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=yyt-(float(num)+1.75e0)*dy y(2)=y(1) y(3)=yyt-1.75e0*dy y(4)=y(3) y(5)=y(1) call pline(x,y,z,5,2) dd=(xxr-xxl-2.2e0*dx)/5.0e0 do i=1,6 k=(i-1)*20 call sint(ichr,nchr,k) x(1)=xxl+2.2e0*dx+float(i-1)*dd x(2)=x(1) y(1)=yyt-(float(num)+1.75e0)*dy y(2)=y(1)-0.02e0*size call pline(x,y,z,2,2) xl=x(1)-float(nchr)*h/2.0e0 xr=x(1)+float(nchr)*h/2.0e0 yl=y(2)-2.0e0*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.6e0*dx yl=yyt-float(i+1)*dy-0.75e0*dy yr=yl+h call htext(xl,yl,xr,yr,6,ichr,-1,q,t,2) if(amax1(t0(1,i),t0(2,i)).le.0.0e0) go to 10 c c times c do 5 k=1,2 xl=xr+0.05e0*dx xr=xl+0.7e0*dx if(t0(k,i).le.0.0e0) go to 5 ichr=' ' if(t0(k,i).gt.10.0e0) then ii=int(alog10(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.0e0) then xp=xr+0.1e0*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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine timpl0(time,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(50),ccolor,map(50),mcic(10),iptr(8), 1 order(7) real + 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.0e0 yshift=t(16)-size/2.0e0 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.0e0) 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.0e0 tot1=0.0e0 do i=1,len0 if(time(2,i).gt.0.0e0) 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.0e0) return c xl=t(15)-size/2.0e0 yt=t(16)+size/2.0e0 hf=amax1(24.0e0,float(len+10)) h=size/hf ss=amin1(hf/float(len+1),4.0e0) dx=(size-4.0e0*h)/5.0e0 do i=1,len yyl=yt-h*float(i)*ss yyr=yyl+h xm=xl+h/2.0e0 ym=yyl+h/2.0e0 call symbl(xm,ym,h,h,1,icolor(i),t) call fstr(ichr,nchr,name(i),0) xxl=xl+h*1.5e0 xxr=xxl+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) c tm=tim1(i) if(tm.gt.0.0e0) then k=2 if(tm.gt.10.0e0) k=int(alog10(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.0e0 k=1 if(fr.ge.10.0e0) 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.0e0*dx endif c tm=tim2(i) k=2 if(tm.gt.10.0e0) k=int(alog10(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.0e0 k=1 if(fr.ge.10.0e0) 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.5e0 ym=yyl+h/2.0e0 call symbl(xm,ym,h,h,1,icolor(i),t) c enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pieplt(time,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(20),ccolor,map(50),mcic(10) real + 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.0e0 yshift=t(16)-size/2.0e0 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.0e0 enddo do i=1,len tim(map(i))=tim(map(i))+time(2,i) enddo tot=0.0e0 do i=1,num tot=tot+tim(i) enddo if(tot.le.0.0e0) return pi=3.141592653589793e0 th(1)=pi/2.0e0 do i=1,num fr=tim(i)/tot dt(i)=fr*2.0e0*pi th(i+1)=th(i)+dt(i) enddo c c make pie chart c xcen=0.5e0 ycen=0.4e0 rad=0.35e0 dd=pi/32.0e0 do i=1,num m=int(dt(i)/dd) x(1)=xcen*scale+xshift y(1)=ycen*scale+yshift z(1)=zshift dtheta=dt(i)/float(m+1) theta=th(i) do j=1,m+2 ang=theta+dtheta*float(j-1) xx=xcen+rad*cos(ang) yy=ycen+rad*sin(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.0e0 yt=t(16)+size/2.0e0 h=size/30.0e0 h=size/27.0e0 mm=num/2 do i=1,mm yyl=yt-h*float(i)*1.5e0 yyr=yyl+h xs=xl xr=t(15) ii=i do j=1,2 xm=xs ym=yyl+h/2.0e0 call symbl(xm,ym,h,h,1,icolor(ii),t) call fstr(ichr,nchr,label(ii),0) xxl=xs+h xxr=xxl+float(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) fr=tim(ii)/tot*100.0e0 k=1 if(fr.ge.10.0e0) k=2 call sfix(ichr,nchr,fr,k) xxr=xr-h if(j.eq.2) xxr=xr xxl=xxr-float(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) xs=t(15)+h xr=t(15)+size/2.0e0 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+float(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.0e0) k=int(alog10(tot))+2 call sfix(ichr,nchr,tot,k) ichr(nchr+1:nchr+8)=' seconds' xxl=t(15) xxr=xxl+float(nchr+8)*h call htext(xxl,yyl,xxr,yyr,nchr+8,ichr,-1,q,t,2) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine subplt(time,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(50),ccolor,map(50),mcic(10),iptr(7) real + 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.0e0 yshift=t(16)-size/2.0e0 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.0e0) 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.0e0 do i=1,len0 if(time(2,i).gt.0.0e0) 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.0e0) 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.0e0 yt=t(16)+size/2.0e0 hf=24.0e0 h=size/hf mrt=iptr(mm+1)-iptr(1) mlt=iptr(num+1)-iptr(mm+1) mx=max0(mrt,mlt) ss=amin1(hf/float(mx+1),4.0e0) do i=1,mx yyl=yt-h*float(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.0e0 call symbl(xm,ym,h,h,1,icolor(ii),t) call fstr(ichr,nchr,name(ii),0) xxl=xs+h xxr=xxl+float(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) fr=tim(ii)/tot*100.0e0 k=1 if(fr.ge.10.0e0) k=2 call sfix(ichr,nchr,fr,k) xxr=xr-h if(j.eq.2) xxr=xr xxl=xxr-float(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) endif xs=t(15)+h xr=t(15)+size/2.0e0 ii=iptr(num+1)-i if(ii.lt.iptr(mm+1)) ii=0 enddo c enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine aveplt(ptime,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor real + t(25),q(3,3),sfact(4),x(10),y(10),z(10),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.0e0 do i=1,nproc tmx=amax1(tmx,ptime(i)) tmn=amin1(tmn,ptime(i)) ave=ave+ptime(i) enddo if(ave.le.0.0e0) return ave=float(nproc)/ave smx=0.0e0 smn=0.0e0 s2=alog(2.0e0) do i=1,nproc ss=alog(ptime(i)*ave)/s2 smx=amax1(smx,ss) smn=amin1(smn,ss) enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0e0 yshift=t(16)-size/2.0e0 zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8e0/sqrt(2.0e0) sfact(2)=0.8e0 sfact(3)=0.6e0 sfact(4)=0.6e0 icolor=ccolor(6,0,jp) c c set up input arrays c h=0.025e0 xl=3.0e0*h xr=1.0e0-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=int(smn) if(smn.lt.float(imin)) imin=imin-1 imax=int(smx) if(smx.gt.float(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.2e0*h yyr=yyl+h xxl=xl ichr(1:4)='min ' val=tmn do j=1,2 if(val.gt.10.0e0) then ii=int(alog10(val))+2 else ii=2 endif call sfix(ichr(5:5),nchr,val,ii) nchr=nchr+4 xxr=xxl+float(nchr)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) xxl=(xl+xr)/2.0e0 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)/float(jmax-jmin) dy=(yr-yl)/float(imax-imin) itype=2 hh=h*sfact(itype) do i=1,nproc xs=xl+dx*float(i) ss=alog(ptime(i)*ave)/s2 ys=yl+dy*(ss-float(imin)) xx=xs*size+xshift yy=ys*size+yshift call symbl(xs,ys,hh,hh,itype,icolor,t) c x(2)=xx y(2)=yy z(2)=zshift if(i.gt.1) call pline(x,y,z,2,2) x(1)=xx y(1)=yy z(1)=zshift enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine timdat(num0,name0,jcat,len0,label0,color0) c implicit real (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/34/ 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)/'mvemsh',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)/'sgen ',2/ data name(10),icat(10)/'ldbal ',3/ data name(11),icat(11)/'lbev ',3/ data name(12),icat(12)/'cutr ',3/ data name(13),icat(13)/'paste ',3/ data name(14),icat(14)/'paste1',3/ data name(15),icat(15)/'bcast ',3/ data name(16),icat(16)/'collct',3/ data name(17),icat(17)/'expth ',3/ data name(18),icat(18)/'recovr',1/ data name(19),icat(19)/'trigen',2/ data name(20),icat(20)/'mginit',5/ data name(21),icat(21)/'mg ',5/ data name(22),icat(22)/'mgilu ',5/ data name(23),icat(23)/'cev ',4/ data name(24),icat(24)/'linsys',6/ data name(25),icat(25)/'predct',4/ data name(26),icat(26)/'blk3 ',5/ data name(27),icat(27)/'blk4 ',5/ data name(28),icat(28)/'blk5 ',5/ data name(29),icat(29)/'swbrch',4/ data name(30),icat(30)/'tpick ',4/ data name(31),icat(31)/'tpickd',4/ data name(32),icat(32)/'rgnsys',6/ data name(33),icat(33)/'pltmg ',4/ data name(34),icat(34)/'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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine errplt(hist,igraph,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ic(22),icc(6),ccolor real + 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.0e0 yy=t(16)-size/2.0e0 t(1)=xx t(2)=yy t(3)=size mpisw=jp(12) ishift=0 if(mpisw.eq.1) ishift=18 c num=int(hist(mxhist+2,ishift+1)) if(num.le.0) return c c set up input arrays c e1=abs(hist(mxhist+2,ishift+igraph+2)) if(e1.gt.0.0e0) e1=1.0e0/e1 do i=1,num rn(i)=alog10(hist(i,ishift+1)) e(i)=0.0e0 qq=abs(hist(i,ishift+igraph+2))*e1 if(qq.gt.0.0e0) e(i)=alog10(qq) ii=int(hist(i,ishift+2))+2 if(ii.lt.1) ii=1 if(ii.gt.6) ii=6 if(mpisw.eq.1) ii=2 ic(i)=ccolor(icc(ii),0,jp) enddo c rmx=rn(1) emx=e(1) emn=emx do i=1,num rmx=amax1(rn(i),rmx) emx=amax1(e(i),emx) emn=amin1(e(i),emn) enddo c numx=max0(5,int(rmx)+2) numy=6 iminz=int(emn) if(emn.lt.float(iminz)) iminz=iminz-1 imaxz=int(emx) if(emx.gt.float(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.025e0 xl=3.0e0*h xr=1.0e0-xl yl=xl yr=xr zl=xl zr=xr c c banners c call fstr(ichr,nchr,label(igraph),0) xxl=0.0e0 xxr=1.0e0 yyl=1.0e0-h yyr=1.0e0 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=amin1(0.0e0,q(1,1))+amin1(0.0e0,q(2,1)) xmax=amax1(0.0e0,q(1,1))+amax1(0.0e0,q(2,1)) ymin=amin1(0.0e0,q(1,2))+amin1(0.0e0,q(2,2)) ymax=amax1(0.0e0,q(1,2))+amax1(0.0e0,q(2,2))+q(3,2) zmin=amin1(0.0e0,q(1,3))+amin1(0.0e0,q(2,3))+amin1(0.0e0,q(3,3)) zmax=amax1(0.0e0,q(1,3))+amax1(0.0e0,q(2,3))+amax1(0.0e0,q(3,3)) c scale=size/amax1(xmax-xmin,ymax-ymin) xshift=xx+(size-scale*(xmax+xmin))/2.0e0 yshift=yy+(size-scale*(ymax+ymin))/2.0e0 zshift= (size-scale*(zmax+zmin))/2.0e0 t(1)=xshift t(2)=yshift t(5)=zshift t(3)=scale c dx=(xr-xl)/float(numx-1) dz=(zr-zl)/float(numz-1) dy=(yr-yl)/float(4*numy-4) do i=1,num x(i)=xl+dx*rn(i) y(i)=yl+dy*float(i) z(i)=zl+dz*(e(i)-float(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.0e0) 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.0e0) 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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine nwtplt(hist,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(2),ccolor real + 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.0e0 yshift=t(16)-size/2.0e0 mxhist=20 t(1)=xshift t(2)=yshift t(3)=size c lab1=int(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=int(hist(mxhist+1,1)) num=min0(num1,mxhist) if(num.le.0) return do j=1,2 e1=abs(hist(mxhist+2,j)) if(e1.gt.0.0e0) e1=1.0e0/e1 do i=1,num qq=abs(hist(i,j))*e1 e(i,j)=0.0e0 if(qq.gt.0.0e0) e(i,j)=alog10(qq) enddo enddo c h=0.025e0 h2=h/2.0e0 xl=3.0e0*h xr=1.0e0-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=amax1(e(i,1),e(i,2),emx) emn=amin1(e(i,1),e(i,2),emn) enddo imin=int(emn) if(emn.lt.float(imin)) imin=imin-1 imax=int(emx) if(emx.gt.float(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.8e0*h yyr=yyl+h ym=yyl+h2 xxl=xl-2.0e0*h do j=1,2 call fstr(ichr,nchr,label(lab+j-1),0) xxr=xxl+float(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.0e0 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)/float(jmax-jmin) hx=dx/4.0e0 dy=(yr-yl)/float(numy-1) do i=1,num xs=xl+dx*float(i)-hx/2.0e0 do j=1,2 xm=xs+float(j-1)*hx hy=dy*(e(i,j)-float(imin)) ym=yl+hy/2.0e0 call symbl(xm,ym,hx,hy,1,icolor(j),t) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine kaplt(ka,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),icolor(5),ccolor,ka(*) real + t(25),q(3,3),wt(3,100),ratio(6) character*80 + ichr,label(3) save label,q data q/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,0.0e0, + 0.0e0,0.0e0,1.0e0/ data label/'matrix','ilu','error'/ c c graph storage c n=ka(1) lvl=ka(2) if(lvl.le.0) return call linit(t,q) size=t(14) xshift=t(15)-size/2.0e0 yshift=t(16)-size/2.0e0 t(1)=xshift t(2)=yshift t(3)=size c num=3 icolor(1)=ccolor(5,0,jp) icolor(2)=ccolor(3,0,jp) icolor(3)=ccolor(1,0,jp) icolor(4)=1 c c set up input arrays c lenja=(ka(9)-n-1)*2+n lenju=(ka(11)-n-1)*2+n lenje=ka(12)*2 lenge=(ka(13)-n-1)*2+n ratio(1)=1.0e0 ratio(2)=float(lenju)/float(lenja) ratio(3)=float(lenje)/float(lenja) ratio(4)=float(lenja)/float(lenge) ratio(5)=float(lenju)/float(lenge) ratio(6)=float(lenje)/float(lenge) c do i=1,lvl nn=ka(21+i)-ka(20+i) wt(1,i)=float(ka(40+i))/float(nn) wt(2,i)=float(ka(60+i))/float(nn) wt(3,i)=float(ka(80+i))/float(nn) enddo c xl=t(15)-size/2.0e0 yt=t(16)+size/2.0e0 h=1.0e0/20.0e0 h2=h/2.0e0 do i=1,num xxl=xl yyl=yt-h*float(i)*2.0e0 xm=xxl+h ym=yyl+h2 call symbl(xm,ym,h,h,1,icolor(i),t) c call fstr(ichr,nchr,label(i),0) xxl=xl+3.0e0*h xxr=xxl+float(nchr)*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1,q,t,2) ii=3 if(ratio(i).ge.10.0e0) ii=4 if(ratio(i).ge.100.0e0) ii=5 call sreal(ichr,nchr,ratio(i),ii,0) xxl=xl+8.0e0*h xxr=xl+14.0e0*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) fr=ratio(i+num)*100.0e0 call sreal(ichr,nchr,fr,3,0) xxl=xl+15.0e0*h xxr=xl+19.0e0*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1,q,t,2) enddo c c h=0.025e0 xl=3.0e0*h xr=1.0e0-xl yl=xl yr=xl+size/2.0e0 jmin=0 jmax=lvl+1 numx=jmax+1 wmx=wt(1,1) do i=1,lvl wmx=amax1(wt(1,i),wt(2,i),wt(3,i),wmx) enddo imin=0 imax=int(wmx) if(wmx.gt.float(imax)) imax=imax+1 if(imax-imin.lt.2) then imax=imin+2 endif if(imax-imin.le.6) then numy=imax-imin+1 iy=1 else if(imax-imin.le.20) then imax=imin+((imax-imin-1)/4)*4+4 numy=(imax-imin)/4+1 iy=4 else if(imax-imin.le.40) then imax=imin+((imax-imin-1)/8)*8+8 numy=(imax-imin)/8+1 iy=8 else iy=((imax-imin-1)/100+1)*10 imax=imin+((imax-imin-1)/iy)*iy+iy numy=(imax-imin)/iy+1 endif 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)/float(jmax-jmin) hx=dx/6.0e0 dy=(yr-yl)/float(imax-imin) do i=1,lvl xs=xl+dx*float(i)-hx do j=1,3 xm=xs+float(j-1)*hx hy=dy*(wt(j,i)-float(imin)) ym=yl+hy/2.0e0 call symbl(xm,ym,hx,hy,1,icolor(j),t) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine hbplt(hist,numhst,lab,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + icolor(22,4),jp(25),num1(4),num(4),jc(2,4),ccolor real + 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.0e0 yshift=t(16)-size/2.0e0 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.8e0/sqrt(2.0e0) sfact(2)=0.8e0 sfact(3)=0.6e0 sfact(4)=0.6e0 do j=1,4 num(j)=0 num1(j)=0 enddo c do j=1,numhst num1(j)=int(hist(mxhist+1,j)) num(j)=min0(num1(j),mxhist) if(num(j).gt.0) then e1=abs(hist(mxhist+2,j)) if(e1.gt.0.0e0) e1=1.0e0/e1 do i=1,num(j) qq=abs(hist(i,j))*e1 e(i,j)=0.0e0 if(qq.gt.0.0e0) e(i,j)=alog10(qq) ee=e(i,j) if(hist(i,j).ge.0.0e0) then icolor(i,j)=jc(1,j) else icolor(i,j)=jc(2,j) endif enddo ave(j)=10.0e0**(e(num(j),j)/float(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.025e0 h2=h/2.0e0 xl=3.0e0*h xr=1.0e0-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=amax1(e(i,j),emx) emn=amin1(e(i,j),emn) enddo endif enddo imin=int(emn) if(emn.lt.float(imin)) imin=imin-1 imax=int(emx) if(emx.gt.float(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.8e0*h yyr=yyl+h ym=yyl+h2 call fstr(ichr,nchr,rate(lab),0) xxl=h xxr=xxl+10.0e0*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=float(6+7*j)*h xxr=xxl+5.0e0*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)/float(numy-1) dx=(xr-xl)/float(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*float(i+ishift) ys=yl+dy*(e(i,j)-float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pthplt(jp,path) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor real + 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.0e0 yy=t(16)-size/2.0e0 num=int(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=amax1(rlmax,path(i,1)) rlmin=amin1(rlmin,path(i,1)) rmax=amax1(rmax,path(i,2)) rmin=amin1(rmin,path(i,2)) enddo dr=(rlmax-rlmin)/20.0e0 if(dr.eq.0.0e0) dr=abs(rlmax)/20.0e0 if(dr.eq.0.0e0) dr=1.0e0 rlmax=rlmax+dr rlmin=rlmin-dr dr=(rmax-rmin)/20.0e0 if(dr.eq.0.0e0) dr=abs(rmax)/20.0e0 if(dr.eq.0.0e0) dr=1.0e0 rmax=rmax+dr rmin=rmin-dr c h=0.025e0*size xl=xx+7.0e0*h xr=xx+size-h yb=yy+2.5e0*h yt=yb+size-5.5e0*h c srl=(xr-xl)/(rlmax-rlmin) sr=(yt-yb)/(rmax-rmin) xshift=(xr+xl)/2.0e0-srl*(rlmax+rlmin)/2.0e0 yshift=(yb+yt)/2.0e0-sr*(rmax+rmin)/2.0e0 c c banners c call fstr(ichr,nchr,label,0) xxl=xx xxr=xx+size yyl=yy+size-1.25e0*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.0e0 dr=(rlmax-rlmin)/10.0e0 do 25 i=1,11 x(1)=xl+float(i-1)*dx x(2)=x(1) y(1)=yb y(2)=yb-0.5e0*h call pline(x,y,z,2,2) if(i-(i/2)*2.eq.0) go to 25 xk=rlmin+float(i-1)*dr call sreal(ichr,nchr,xk,3,0) xxl=x(1)-float(nchr)*h/4.0e0 xxr=x(1)+float(nchr)*h/4.0e0 yyl=y(2)-1.75e0*h/2.0e0 yyr=yyl+h/2.0e0 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.0e0 dr=(rmax-rmin)/10.0e0 do i=1,11 xk=rmin+float(i-1)*dr call sreal(ichr,nchr,xk,3,0) x(1)=xl x(2)=x(1)-0.5e0*h y(1)=yb+float(i-1)*dy y(2)=y(1) call pline(x,y,z,2,2) xxl=amax1(x(1)-float(nchr+3)*h/2.0e0,xx) xxr=x(1)-h yyl=y(1)-h/4.0e0 yyr=y(1)+h/4.0e0 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.0e0 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.0e0 y(2)=y(1) y(3)=y(1)+h y(4)=y(3) y(5)=y(1) iic=int(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=int(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cpth(l0,l1,r0,r1,l0dot,l1dot,r0dot,r1dot,it1, + xscale,yscale,xshift,yshift,zshift,xl,xr,yb,yt) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=sqrt(dr*dr+dl*dl) if(al.eq.0.0e0) 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.0e0*yd0*yd1 w1=-(xd0*yd1+xd1*yd0) a=sqrt(w0*w0+w1*w1) if(abs(a).lt.1.e-2) go to 10 c2=w0/a s2=w1/a ud0=c2*xd0+s2*yd0 if(abs(ud0).le.1.e-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.0e0/(4.0e0*b*ud0) t=b*vd0/ud0 pr=r0+(c*2.0e0*ud0-s*vd0)*t pl=l0+(c*vd0+s*2.0e0*ud0)*t c c compute number of points c num=int(abs(r0-r1)*yscale*50.0e0) + +int(abs(l0-l1)*xscale*50.0e0) 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)/float(num-1) do i=1,num u=u0+float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tmhist(jp,path,iptr) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ccolor real + 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.0e0 yy=t(16)-size/2.0e0 zshift=t(5) num=int(path(101,1)) if(num.le.1) return tmin=path(1,1) tmax=path(num,1) if(tmax.le.tmin) return rr(1)=0.0e0 rr(2)=alog10(path(2,iptr+1)) rmax=rr(2) rmin=rmax do i=2,num rr(i)=alog10(path(i,iptr+1)) rmax=amax1(rmax,rr(i)) rmin=amin1(rmin,rr(i)) enddo irmax=int(rmax)+1 irmin=int(rmin)-1 c h=0.025e0*size xl=xx+7.0e0*h xr=xx+size-h yb=yy+2.5e0*h yt=yb+size-5.5e0*h c st=(xr-xl)/(tmax-tmin) sr=(yt-yb)/float(irmax-irmin) xshift=(xr+xl)/2.0e0-st*(tmax+tmin)/2.0e0 yshift=(yb+yt)/2.0e0-sr*float(irmax+irmin)/2.0e0 c c banners c call fstr(ichr,nchr,label(iptr),0) xxl=xx xxr=xx+size yyl=yy+size-1.25e0*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.0e0 dt=(tmax-tmin)/10.0e0 do 25 i=1,11 x(1)=xl+float(i-1)*dx x(2)=x(1) y(1)=yb y(2)=yb-0.5e0*h call pline(x,y,z,2,2) if(i-(i/2)*2.eq.0) go to 25 xk=tmin+float(i-1)*dt call sreal(ichr,nchr,xk,3,0) xxl=x(1)-float(nchr)*h/4.0e0 xxr=x(1)+float(nchr)*h/4.0e0 yyl=y(2)-1.75e0*h/2.0e0 yyr=yyl+h/2.0e0 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.0e0 if(irmax-irmin.lt.10) then nn=irmax-irmin+1 inc=1 else nn=(irmax-irmin)/2+1 inc=2 endif dy=(yt-yb)/float(nn-1) do i=1,nn k=irmin+(i-1)*inc call sint(ichr,nchr,k) x(1)=xl x(2)=x(1)-0.5e0*h y(1)=yb+float(i-1)*dy y(2)=y(1) call pline(x,y,z,2,2) xxl=amax1(x(1)-float(nchr+3)*h/2.0e0,xx) xxr=x(1)-h yyl=y(1)-h/4.0e0 yyr=y(1)+h/4.0e0 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.0e0 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.0e0 y(2)=y(1) y(3)=y(1)+h y(4)=y(3) y(5)=y(1) ic=ccolor(4,0,jp) if(int(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ipmplt(jp,path) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ic(100),icc(6),ccolor real + 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.0e0 yy=t(16)-size/2.0e0 t(1)=xx t(2)=yy t(3)=size c num=int(path(101,1)) if(num.le.0) return c c set up input arrays c do i=1,num rmu(i)=alog10(path(i,1)) rho(i)=alog10(abs(path(i,2))) rn(i)=alog10(path(i,3)) ii=int(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=amax1(rn(i),rnmax) rmumax=amax1(rmu(i),rmumax) rmumin=amin1(rmu(i),rmumin) rhomax=amax1(rho(i),rhomax) rhomin=amin1(rho(i),rhomin) enddo c numx=max0(5,int(rnmax)+2) iminy=int(rmumin) if(rmumin.lt.float(iminy)) iminy=iminy-1 imaxy=int(rmumax) if(rmumax.gt.float(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=int(rhomin) if(rhomin.lt.float(iminz)) iminz=iminz-1 imaxz=int(rhomax) if(rhomax.gt.float(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.025e0 xl=3.0e0*h xr=1.0e0-xl yl=xl yr=xr zl=xl zr=xr c c banners c call fstr(ichr,nchr,label,0) xxl=0.0e0 xxr=1.0e0 yyl=1.0e0-h yyr=1.0e0 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=amin1(0.0e0,q(1,1))+amin1(0.0e0,q(2,1)) xmax=amax1(0.0e0,q(1,1))+amax1(0.0e0,q(2,1)) ymin=amin1(0.0e0,q(1,2))+amin1(0.0e0,q(2,2)) ymax=amax1(0.0e0,q(1,2))+amax1(0.0e0,q(2,2))+q(3,2) zmin=amin1(0.0e0,q(1,3))+amin1(0.0e0,q(2,3))+amin1(0.0e0,q(3,3)) zmax=amax1(0.0e0,q(1,3))+amax1(0.0e0,q(2,3))+amax1(0.0e0,q(3,3)) c scale=size/amax1(xmax-xmin,ymax-ymin) xshift=xx+(size-scale*(xmax+xmin))/2.0e0 yshift=yy+(size-scale*(ymax+ymin))/2.0e0 zshift= (size-scale*(zmax+zmin))/2.0e0 t(1)=xshift t(2)=yshift t(5)=zshift t(3)=scale c dx=(xr-xl)/float(numx-1) dz=(zr-zl)/float(numz-1) dy=(yr-yl)/float(numy-1) do i=1,num x(i)=xl+dx*rn(i) y(i)=yl+dy*(rmu(i)-float(iminy)) z(i)=zl+dz*(rho(i)-float(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.0e0) 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.0e0) 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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dbugi(sub,name,nrow,ncol,ia) c implicit real (a-h,o-z) implicit integer (i-n) integer + ia(*) character*6 + sub,name character*80 + list,blank c blank=' ' call filutl(blank,0) if(nrow.eq.1.and.ncol.eq.1) then write(unit=list,fmt='(a11,a6,3x,a9,a6,3x,a6,i6)') + 'subroutine:',sub,'variable:',name,'value:',ia(1) call filutl(list,0) call filutl(blank,0) return else write(unit=list,fmt='(a11,a6,3x,a9,a6)') + 'subroutine:',sub,'variable:',name call filutl(list,0) call filutl(blank,0) endif if(ncol.eq.1) then do irow=1,nrow,6 i5=min0(irow+5,nrow) write(unit=list,fmt='(a4,i6,3x,6i8)') + 'row:',irow,(ia(i),i=irow,i5) call filutl(list,0) enddo else do icol=1,ncol ii=(icol-1)*nrow write(unit=list,fmt='(a4,i6,3x,6i8)') + 'col:',icol,(ia(i),i=ii+1,ii+nrow) call filutl(list,0) enddo endif call filutl(blank,0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine dbugr(sub,name,nrow,ncol,a) c implicit real (a-h,o-z) implicit integer (i-n) real + a(*) character*6 + sub,name character*80 + list,blank c blank=' ' call filutl(blank,0) if(nrow.eq.1.and.ncol.eq.1) then write(unit=list,fmt='(a11,a6,3x,a9,a6,3x,a6,e12.4)') + 'subroutine:',sub,'variable:',name,'value:',a(1) call filutl(list,0) call filutl(blank,0) return else write(unit=list,fmt='(a11,a6,3x,a9,a6)') + 'subroutine:',sub,'variable:',name call filutl(list,0) call filutl(blank,0) endif if(ncol.eq.1) then do irow=1,nrow,4 i3=min0(irow+3,nrow) write(unit=list,fmt='(a4,i6,3x,4e12.4)') + 'row:',irow,(a(i),i=irow,i3) call filutl(list,0) enddo else do icol=1,ncol ii=(icol-1)*nrow write(unit=list,fmt='(a4,i6,3x,4e12.4)') + 'col:',icol,(a(i),i=ii+1,ii+nrow) call filutl(list,0) enddo endif call filutl(blank,0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine prtpth(irgn,nproc,ipath) c implicit real (a-h,o-z) implicit integer (i-n) integer + ipath(6,*) character*80 + list,blank c blank=' ' call filutl(blank,0) write(unit=list,fmt='(a6,i3,3x,a5,i3)') + 'nproc:',nproc,'irgn:',irgn call filutl(list,0) do i=1,nproc+1 iv1=ipath(3,i) iv2=ipath(4,i) ie1=ipath(1,i) ie2=ipath(2,i) call filutl(blank,0) write(unit=list,fmt='(a7,i3,2(3x,a6,2i6))') + 'region:',i,'verts:',iv1,iv2,'edges:',ie1,ie2 call filutl(list,0) call filutl(blank,0) do k=ie1,ie2 write(unit=list,fmt='(a7,i5,3x,4i6))') + 'column:',k,(ipath(j,k),j=1,4) call filutl(list,0) enddo enddo i=nproc+2 iv1=ipath(3,i) iv2=ipath(4,i) ie1=ipath(1,i) ie2=ipath(2,i) call filutl(blank,0) write(unit=list,fmt='(a8,i3,2(3x,a6,2i6))') + 'nproc+2:',i,'verts:',iv1,iv2,'edges:',ie1,ie2 call filutl(list,0) call filutl(blank,0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine aveprt(ptime,jp) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25) real + ptime(*) character*80 + list c ntf=jp(1) if(ntf.le.0) return nproc=jp(2) tmx=ptime(1) tmn=ptime(1) ave=0.0e0 do i=1,nproc tmx=amax1(tmx,ptime(i)) tmn=amin1(tmn,ptime(i)) ave=ave+ptime(i) enddo ave=ave/float(nproc) c write(unit=list,fmt='(a19,f7.2,a9,f7.2,a4,f7.2)') + 'mpi: average time =',ave,' range =',tmn, 1 ' -- ',tmx call filutl(list,0) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine nwtprt(hist) c implicit real (a-h,o-z) implicit integer (i-n) real + e(22,2),hist(22,*) character*80 + list,label(3) save label c data label/'newton residual -- newton increment', + 'upper bound --lower bound', 1 'dd residual -- dd increment'/ c c graph error c mxhist=20 c lab1=int(hist(mxhist+1,2)) if(lab1.eq.-1) then lab=3 else if(lab1.eq.-2) then lab=2 else lab=1 endif num1=int(hist(mxhist+1,1)) num=min0(num1,mxhist) if(num.le.0) return do j=1,2 e1=abs(hist(mxhist+2,j)) if(e1.gt.0.0e0) e1=1.0e0/e1 do i=1,num qq=abs(hist(i,j))*e1 e(i,j)=0.0e0 if(qq.gt.0.0e0) e(i,j)=alog10(qq) enddo enddo c list=label(lab) call filutl(list,0) do i=1,num write(unit=list,fmt='(a10,i4,2f9.2)') + 'iteration:',i,e(i,1),e(i,2) call filutl(list,0) enddo if(num.le.1) return r1=10.0e0**((e(num,1)-e(1,1))/float(num-1)) r2=10.0e0**((e(num,2)-e(1,2))/float(num-1)) write(unit=list,fmt='(a20,2f9.2)') + 'convergence factors:',r1,r2 call filutl(list,0) end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xyaxis(xl,xr,yl,yr,h,t,q,numx,iminx, + incx,numy,iminy,incy) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 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+float(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-float(nchr)*h2 xxr=xx+float(nchr)*h2 yyl=yl-2.25e0*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+float(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-float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine symbl(xm,ym,hx,hy,itype,icolor,t) c implicit real (a-h,o-z) implicit integer (i-n) integer + iptr(5) real + 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.5e0,0.5e0,0.5e0,-0.5e0,0.5e0,0.0e0,-0.5e0,0.0e0, + -0.5e0,0.5e0,0.0e0,0.0e0,0.5e0,-0.5e0/ data py/-0.5e0,-0.5e0,0.5e0,0.5e0,0.0e0,0.5e0,0.0e0,-0.5e0, + -0.5e0,-0.5e0,0.5e0,-0.5e0,0.5e0,0.5e0/ 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xygrid(xl,xr,yl,yr,zl,h,t,q,numx,iminx, + incx,numy,iminy,incy) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 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.0e0.and.q(3,3).eq.0.0e0) go to 10 nn=numy if(q(3,3).eq.0.0e0) nn=1 do i=1,nn yy=yl+float(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+float(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-float(nchr)*h2 xxr=xx+float(nchr)*h2 yyl=zl-2.25e0*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.0e0.and.q(3,3).eq.0.0e0) return nn=numx if(q(3,3).eq.0.0e0) nn=1 do i=1,nn xx=xl+float(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+float(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-float(nchr)*h2 xxr=yy+float(nchr)*h2 yyl=zl-2.25e0*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0,q0,t0,2) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,incz) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0 xp=xl+h2 yp=yl+h2 do i=1,25 t0(i)=t(i) enddo if(abs(q(1,3)).lt.abs(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+float(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-float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cbox(x,y,z,zl,h,t,q,icolor,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + face(4,6),order(6),index(3,3) real + 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.0e0,1.0e0,1.0e0,0.0e0,0.0e0,1.0e0,1.0e0,0.0e0/ data py/0.0e0,0.0e0,1.0e0,1.0e0,0.0e0,0.0e0,1.0e0,1.0e0/ data pz/0.0e0,0.0e0,0.0e0,0.0e0,1.0e0,1.0e0,1.0e0,1.0e0/ 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(abs(q(kmin,3)).gt.abs(q(2,3))) kmin=2 if(abs(q(kmin,3)).gt.abs(q(3,3))) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(abs(q(kmid,3)).gt.abs(q(kmax,3))) kmid=kmax kmax=6-kmin-kmid c if(q(kmax,3).gt.0.0e0) 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.0e0) 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.0e0) then order(3)=2*kmin-1 order(4)=2*kmin else order(4)=2*kmin-1 order(3)=2*kmin endif c tol=1.e-3 istrt=6 if(abs(q(kmin,3)).gt.tol) then istrt=4 else if(abs(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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mktris(ip,vx,vy,ibndry,itnode,xm,ym,jb,jt, + jtnode,jtedge,index,list,llist,ntf,iclrsw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),jb(*),jtnode(5,*),jt(*), 1 jtedge(3,*),list(*),ip(100),index(*) real + vx(*),vy(*),xm(*),ym(*) c c make a crude triangulation of the skeleton c ntr=ip(1) nvr=ip(2) nbr=ip(4) c c make jb c ibdy=nvr+2*nbr+2 inum=ibdy+nvr iornt=inum+nbr c call makjb(nvr,nbr,ntr,vx,vy,xm,ym,ibndry,itnode,1, + jb,list,list(ibdy),list(inum),list(iornt),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)) c*** write(6,*) itag,nb1,nb2,nt1,ntf,nn,ntf-nt1+1-nn+2 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine trisk(nvf,vx,vy,index,ntf,itnode,i4tag,i5tag, + list,istart,istop) c implicit real (a-h,o-z) implicit integer (i-n) integer + istart(*),istop(*),itnode(5,*),list(*),index(*) real + vx(*),vy(*) data ibit/0/ c c triangulate the region give in vx,vy c c*** ntf0=ntf nrgn=1 istart(1)=1 istop(1)=nvf c** eps=0.0e0 eps=ceps(ibit) 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.0e0 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.0e0 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.0e0) 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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine eswapk(nt1,nt2,itnode,itedge,vx,vy) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),index(3,3) real + 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.0e0 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(amin1(q1,q2).lt.amin1(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cedgek(nvf,nt1,nt2,nb1,nb2,itnode,ibndry,itedge,jb, + vx,vy,list) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),list(*),index(3,3), 1 jb(*) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine binits(ip,rp,vx,vy,xm,ym,itnode,ibndry,t,tl,q,jp, + iclr,ntf) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),itnode(5,*),ibndry(6,*),iclr(*), 1 ip(100),tmin(2),tmax(2) real + 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) ndf=ip(5) mpisw=ip(48) icrsn=ip(68) jp(1)=ntf jp(8)=ntr jp(2)=nvf jp(3)=nbf jp(24)=ndf 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/amax1(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmin(1)+bmax(1))/2.0e0 t(2)=ys-scale*(bmin(2)+bmax(2))/2.0e0 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.0e0 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 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 real (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,*) real + 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) ndf=ip(5) 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.0e0 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,z,iflag) call cedge5(nbf,itedge,ibedge,1) ndof=1 call cutr1(ntf,nvf,nbf,irgn,itnode,ibndry,vx,vy, + ht,ndof,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,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(24)=ndf 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=sqrt((bmax(1)-bmin(1))**2+(bmax(2)-bmin(2))**2) endif c size=t(14) xs=t(15) ys=t(16) scale=size/amax1(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmin(1)+bmax(1))/2.0e0 t(2)=ys-scale*(bmin(2)+bmax(2))/2.0e0 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.0e0*float(num(1))/float(num(4)) t(22)=100.0e0*float(num(2))/float(num(4)) t(23)=100.0e0*float(num(3))/float(num(4)) t(24)=abs(val(1)) t(25)=val(2)/float(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)=amin1(ht(i),bmin(3)) bmax(3)=amax1(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.0e0) iscale=2 jp(19)=iscale zmin=fscale(t(19),iscale,0) zmax=fscale(t(20),iscale,0) if(zmax.gt.zmin) then dd=float(ncolor)/(zmax-zmin) do i=1,ntf zz=fscale(ht(i),iscale,0) iq=max0(1,int((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(0,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.0e0 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,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,z,iflag) if(nvf.le.nvtrgt) go to 20 enddo endif c 20 jp(1)=ntf jp(2)=nvf jp(3)=nbf jp(24)=ndf return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cutr1(ntf,nvf,nbf,irgn,itnode,ibndry,vx,vy, + e,ndof,ut,vt,ibedge,mark,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),ibedge(2,*),mark(*),index(3,3) real + vx(*),vy(*),e(*),ut(ndof,*),vt(ndof,*) 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,ndof 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tstvti(i,itnode,ibndry,vx,vy,xm,ym,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len) c implicit real (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) real + xm(*),ym(*),vx(*),vy(*),c(3) save index data index/1,2,3,2,3,1,3,1,2/ 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=abs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(abs(aa-1.0e0).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=abs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(abs(aa-1.0e0).lt.angmin) vtype(i)=6 else tol=1.0e-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(amin1(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(abs(theta2-theta1).le.arcmax) vtype(i)=6 endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine crsn0(nvf,ntf,nbf,itnode,ibndry,vx,vy,xm,ym, + itedge,ibedge,vtype,p,q,qual,iseed,icolor,ibase) c implicit real (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),itdof(10), 2 elist(500),tlist(500),vlist(500),blist(500),vsv(500) real + 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 lenb=3 iord=1 ndof=(iord+1)*(iord+2)/2 angmin=1.0e-3 cc angmin=1.0e-4 arcmax=0.26e0 cc arcmax=0.1e0 c c initailize iseed, vtype c call cvtype(ntf,nbf,nvf,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.0e0) 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 eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy, + lenb,bump,e,iseed,vtype,vlist,tlist,elist, 1 blist,len,0,0,iord,ndof,itdof,iflag) c if(corner(vtype(i)).eq.1) stop 6235 if(iflag.eq.0) then call dlknot(i,itnode,itedge,ibndry,ibedge,ndof, + itdof,vx,vy,lenb,bump,e,iseed,vtype, 1 vlist,tlist,elist,len,iord,ibase,0) else qual(i)=0.0e0 last=last+1 endif c c update vertices in connected to i c do jj=1,lvsv j=vsv(jj) qual(j)=0.0e0 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,vtype,jflag) call cedge5(nbf,itedge,ibedge,1) call eswapa(ntf,nvf,nbf,itnode,itedge,ibndry,ibedge, + iseed,vx,vy,lenb,bump,e,0,0,iord,ndof,itdof) call cedge5(nbf,itedge,ibedge,0) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- real function gqual(i,tlist,elist,len,vtype,icolor) c implicit real (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.0e0 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.5e0 if(len.ge.4) gqual=0.5e0/float(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.0e0 if(len.eq.5) gqual=1.0e0 if(len.ge.6) gqual=3.0e0/float(len) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,icolor,mark) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*),ibedge(2,*), 1 mark(*),icolor(*) real + 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.0e0) then itemp=itnode(2,i) itnode(2,i)=itnode(3,i) itnode(3,i)=itemp endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine smth1(ntf,itedge,icolor) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine smth2(ntf,itedge,itnode,vx,vy,icolor) c implicit real (a-h,o-z) implicit integer (i-n) integer + icolor(*),itedge(3,*),itnode(5,*) real + vx(*),vy(*) c itmax=1 theta=0.05e0 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=amin1(hh,hmin) hmax=amax1(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=float(2*icolor(i))+0.5e0 do j=1,3 if(itedge(j,i).gt.0) then num=num+2 ii=itedge(j,i)/4 q=q+float(icolor(ii)+icolor(i)) endif enddo q=q/float(num) icolor(i)=int(q) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine tplot(vx,vy,ibndry,itnode,xm,ym,t,jp,itedge,iclr) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),itedge(3,*),jp(25),ccolor, 1 iclr(*),index(3,3),ibdy(243) real + vx(*),vy(*),xm(*),ym(*),t(25),x(2),y(2),z(2), 1 q(3,3),bx(3),by(3),bz(3),ut(3),vt(3), 3 xp(243),yp(243),up(243),vp(243) save index,q data index/1,2,3,2,3,1,3,1,2/ data q/1.0e0,0.0e0,0.0e0,0.0e0,1.0e0,0.0e0, + 0.0e0,0.0e0,1.0e0/ 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.0e0 c c color triangles c do ii=1,ntf c c compute triangle boundary c call tbdy(xp,yp,up,vp,ibdy,ntri,ii,itnode,ibndry,itedge, + vx,vy,xm,ym,q,0,1,-1,3,ut,vt) ic=iclr(ii) icolor=ccolor(ic,0,jp) do itri=1,3*ntri,3 do mm=1,3 m=mm+itri-1 xx=xp(m) yy=yp(m) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sfix(list,length,val,ndig) c implicit real (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.0e0) then length=ndig+1 do i=1,length list(i)=zero enddo list(2)=dot return endif zc=abs(val) zz=alog10(zc) iex=int(zz) mdig=min0(ndig,ndig-iex) mdig=max0(0,mdig) tt=zc*(10.0e0**mdig)+0.5e0 n=int(tt) if(n.eq.0) then do i=1,ndig+2 list(i)=zero enddo if(val.ge.0.0e0) 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.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine htext(xl,yl,xr,yr,nchr,cchr,ijust,q,t,icolor) c implicit real (a-h,o-z) implicit integer (i-n) integer + ichr(80),symbcd(640),istart(94),map(128) real + 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.0e0,21.0e0,21.0e0,21.0e0,19.0e0,18.0e0,21.0e0,22.0e0, 1 8.0e0,16.0e0,21.0e0,17.0e0,24.0e0,22.0e0,22.0e0,21.0e0, 2 22.0e0,21.0e0,20.0e0,16.0e0,22.0e0,18.0e0,24.0e0,20.0e0, 3 18.0e0,20.0e0,19.0e0,19.0e0,18.0e0,19.0e0,18.0e0,12.0e0, 4 19.0e0,19.0e0, 8.0e0,10.0e0,17.0e0, 8.0e0,30.0e0,19.0e0, 5 19.0e0,19.0e0,19.0e0,13.0e0,17.0e0/ data (width(i),i=46,94)/ + 12.0e0,19.0e0,16.0e0,22.0e0,17.0e0,16.0e0,17.0e0,20.0e0, 1 20.0e0,20.0e0,20.0e0,20.0e0,20.0e0,20.0e0,20.0e0,20.0e0, 2 20.0e0,26.0e0,26.0e0,14.0e0,14.0e0,10.0e0,10.0e0,22.0e0, 3 26.0e0,16.0e0,20.0e0,24.0e0,24.0e0,14.0e0,14.0e0,27.0e0, 4 22.0e0,14.0e0,14.0e0,21.0e0,10.0e0,10.0e0,10.0e0,18.0e0, 5 24.0e0,25.0e0,24.0e0,16.0e0, 8.0e0,26.0e0,22.0e0,14.0e0, 6 8.0e0/ 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.0e0 do i=1,nchr ic=ichr(i) if(ic.lt.1.or.ic.gt.94) then wid=wid+20.0e0 else wid=wid+width(ic) endif enddo wid=wid/21.0e0 c height=amin1(dx/wid,dy) if(height.lt.dy) then x0=xl y0=yl+(dy-height)/2.0e0 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.0e0 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.0e0 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.0e0*rscale else c c plot a single 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pwindw(x,y,z,llen,t,icolor) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0,-1.0e0,0.0e0,0.0e0/ data cy/0.0e0,0.0e0,1.0e0,-1.0e0/ data cc/0.0e0,0.0e0,0.0e0,0.0e0/ c c map a polygon onto the current window c rmag=t(12) if(rmag.le.1.0e0) then call pfill(x,y,z,llen,icolor) return endif c nmax=22 eps=t(7)/rmag shift=(1.0e0-t(14))/2.0e0 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.0e0-f) yn(num)=y0(i)*f+y0(j)*(1.0e0-f) zn(num)=z0(i)*f+z0(j)*(1.0e0-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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lwindw(x,y,z,n,t,icolor) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e0) 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.0e0-t(14))/2.0e0 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.0e0-f) zz(jl)=zz(jl)*f+zz(jr)*(1.0e0-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.0e0-f) zz(jr)=zz(jr)*f+zz(jl)*(1.0e0-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.0e0-f) zz(jb)=zz(jb)*f+zz(jt)*(1.0e0-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.0e0-f) zz(jt)=zz(jt)*f+zz(jb)*(1.0e0-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 lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine mtxplt(ja,a,ip,rp,sp,w) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ip(100),jp(25),jpl(25),kdist(22) real + a(*),w(*),rp(100),t(25),tl(25),q(3,3),ql(3,3), 1 red(256),green(256),blue(256) character*80 + sp(100) c c user specified ip variables c n=ip(5) 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.4) 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(90) itdof=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 call getptr(w(ka),iqptr,japtr,iaptr,juptr,iuptr) c ispd=ip(8) lenw=ip(82) ibegin=iz iend=lenw c lenja=ja(japtr+n)-1 lenju=ja(juptr+n)-1 if(ispd.eq.1) then lena=lenja lenu=lenju else lena=lenja+ja(japtr+n)-ja(japtr) lenu=lenju+ja(juptr+n)-ja(juptr) endif 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=82 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 c c call linit(t,q) call linit(tl,ql) call minit(ip,rp,w(ka),ja(japtr),ja(juptr),w(ia), + w(icolor),jp,jpl,t,tl,q,ql) jtype=imtxsw-(imtxsw/2)*2 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) call pframe(5) 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 legnd5(jp,t) else call cdist(jp,t,w(ia),kdist) call legnd4(jp,tl,kdist) endif call pframe(-2) c c small plot c call pframe(3) 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) ip(25)=0 10 if(iflag.eq.0) then sp(11)='mtxplt: ok' else if(iflag.eq.25) then write(unit=sp(11),fmt='(a12,i3,a23)') + 'mtxplt error',iflag,': wrong data structure' else if(iflag.ge.82.and.iflag.le.89) then write(unit=sp(11),fmt='(a12,i3,a22)') + 'mtxplt error',iflag,': insufficient storage' else write(unit=sp(11),fmt='(a12,i3,a22)') + 'mtxplt error',iflag,': unknown error' endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine mplot1(jp,t,q,ju,u,color) c implicit real (a-h,o-z) implicit integer (i-n) integer + jp(25),ju(*),color(*),ccolor real + 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.0e0) then c c border for lower triangle c call mtxbrd(t,q,0) c c lower triangle c if(q(1,3).lt.0.0e0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(2,3).lt.0.0e0) 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.0e0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(1,3).gt.0.0e0) 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.0e0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(1,3).gt.0.0e0) 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.0e0) then n1=n n2=1 ns=-1 else n1=1 n2=n ns=1 endif if(q(2,3).lt.0.0e0) 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 lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine centry(ix,iy,val,t,q,jp,icolor,isw) c implicit real (a-h,o-z) implicit integer (i-n) integer + face(4,6),jp(25),order(6),index(3,3) real + 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.0e0,1.0e0,1.0e0,0.0e0,0.0e0,1.0e0,1.0e0,0.0e0/ data py/0.0e0,0.0e0,1.0e0,1.0e0,0.0e0,0.0e0,1.0e0,1.0e0/ data pz/0.0e0,0.0e0,0.0e0,0.0e0,1.0e0,1.0e0,1.0e0,1.0e0/ 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.0e0/float(n) hl=h/10.0e0 hr=h-hl c c compute order c kmin=1 if(abs(q(kmin,3)).gt.abs(q(2,3))) kmin=2 if(abs(q(kmin,3)).gt.abs(q(3,3))) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(abs(q(kmid,3)).gt.abs(q(kmax,3))) kmid=kmax kmax=6-kmin-kmid c if(q(kmax,3).gt.0.0e0) 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.0e0) 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.0e0) then order(3)=2*kmin-1 order(4)=2*kmin else order(4)=2*kmin-1 order(3)=2*kmin endif c tol=1.e-3 istrt=6 if(abs(q(kmin,3)).gt.tol) then istrt=4 else if(abs(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.0e0/(zmax-zmin) else dz=0.0e0 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=float(ix-1)*h y=float(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 lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine mtxbrd(t,q,isw) c implicit real (a-h,o-z) implicit integer (i-n) real + 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 lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine mtxclr(lvl,jmtx,ja,ju,jp,t,u,color) c implicit real (a-h,o-z) implicit integer (i-n) integer + ja(*),ju(*),color(*),jp(25) real + 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.3) then len=ja(n+1)-1 nnz=ja(n+1)-ja(1) icolor=4 else len=ju(n+1)-1 nnz=ju(n+1)-ju(1) icolor=2 endif if(ispd.eq.1) then lenu=len lshift=0 else lenu=len+nnz lshift=nnz 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.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 if(lvl.gt.1) then do j=ju(i),ju(i+jmtx)-1 color(j)=6 color(j+lshift)=6 enddo endif 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.0e0-eps)*float(ncolor)/(zmax-zmin) else zscale=0.0e0 endif c do i=1,lenu zz=(fscale(u(i),iscale,0)-zmin)*zscale color(i)=max0(0,int(zz))+1 color(i)=min0(color(i),ncolor) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine minit(ip,rp,ka,ja,ju,u,color,jp,jpl,t,tl,q,ql) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),jp(25),ja(*),ju(*),color(*),jpl(25),ka(*) real + 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 zoombx(rp,t) rmag=t(12) c c check control parameters in ip and rp c n=ka(1) lvl=ka(2) ispd=ka(14) jmtx=ka(19) 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)) 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 if(imtxsw.ge.3) then len=ja(n+1)-1 if(ispd.ne.1) len=len+ja(n+1)-ja(1) else len=ju(n+1)-1 if(ispd.ne.1) len=len+ju(n+1)-ju(1) endif u(n+1)=u(1) if(ip(55).ge.0) then do i=1,len u(i)=abs(u(i)) enddo endif umin=u(1) umax=u(1) do i=1,len umin=amin1(umin,u(i)) umax=amax1(umax,u(i)) enddo if(iscale.eq.1.and.umin.le.0.0e0) 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=amin1(0.0e0,q(1,1))+amin1(0.0e0,q(2,1)) xmax=amax1(0.0e0,q(1,1))+amax1(0.0e0,q(2,1)) ymin=amin1(0.0e0,q(1,2))+amin1(0.0e0,q(2,2)) ymax=amax1(0.0e0,q(1,2))+amax1(0.0e0,q(2,2)) zmin=amin1(0.0e0,q(1,3))+amin1(0.0e0,q(2,3)) zmax=amax1(0.0e0,q(1,3))+amax1(0.0e0,q(2,3)) if(i3d.eq.1) then ymax=ymax+q(3,2) zmin=zmin+amin1(0.0e0,q(3,3)) zmax=zmax+amax1(0.0e0,q(3,3)) endif size=t(14) xs=t(15) ys=t(16) zs=t(17) scale=size/amax1(xmax-xmin,ymax-ymin) xshift=xs-scale*(xmax+xmin)/2.0e0 yshift=ys-scale*(ymax+ymin)/2.0e0 zshift=zs-scale*(zmax+zmin)/2.0e0 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.amin1(0.0e0,umax)) then t(23)=-umin/(umax-umin) else t(23)=0.0e0 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.0e0 c jpl(20)=0 jpl(21)=0 if(rmag.le.1.0e0) jpl(22)=0 c c set q0, scale,xshift, yshift correctly for picture c if(rmag.ne.1.0e0) then do i=1,3 do j=1,3 ql(i,j)=q(i,j) enddo enddo else tl(1)=xs-size/2.0e0 tl(2)=ys-size/2.0e0 tl(5)=zs tl(3)=size jpl(13)=0 jpl(14)=0 jpl(15)=1 endif c c set colors c call mtxclr(lvl,jmtx,ja,ju,jp,t,u,color) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 8.5 - - - december, 2000 c c----------------------------------------------------------------------- subroutine getptr(ka,iqptr,japtr,iaptr,juptr,iuptr) c implicit real (a-h,o-z) implicit integer (i-n) integer + ka(*) c iqptr=ka(3) japtr=ka(4) iaptr=ka(5) juptr=ka(6) iuptr=ka(7) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltevl(x,y,u,ux,uy,vx,vy,xm,ym,itnode,ibndry, + ip,rp,w) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(100),itnode(5,*),ibndry(6,*) real + x(*),y(*),u(*),ux(*),uy(*),w(*),vx(*),vy(*),xm(*), 1 ym(*),rp(100),p(6) save p 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(6).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(90) itdof=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(82) ntf=ip(1) nvf=ip(2) nbf=ip(4) ndf=ip(5) c c additional pointers c iord=ip(26) ndof=(iord+1)*(iord+2)/2 maxv=ip(84) maxd=ip(89) nevp=iabs(ip(16)) if(nevp.eq.0) return ibegin=iz iend=lenw call memptr(ibedge,2*nbf,'head',ibegin,iend,iflag) call memptr(itedge,3*ntf,'head',ibegin,iend,iflag) call memptr(list,2*nvf,'head',ibegin,iend,iflag) call memptr(iqueue,2*nvf,'head',ibegin,iend,iflag) ltree=max0((iend-ibegin+1)/5,nvf) ll=max0(5*ltree,3*ntf) call memptr(mtree,ll,'head',ibegin,iend,iflag) if(iflag.ne.0) then ip(25)=82 return endif c call ueval(ip,x,y,u,ux,uy,vx,vy,maxd,w(iuu), + xm,ym,w(list),w(mtree),ltree,w(iqueue),p,itnode, 1 w(itedge),ibndry,w(ibedge),ndof,w(itdof)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ueval(ip,x,y,u,ux,uy,vx,vy,maxd,gf,xm,ym,list, + qtree,ltree,queue,p,itnode,itedge,ibndry,ibedge,ndof,itdof) c implicit real (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),list(*),queue(*),itnode(5,*),itdof(ndof,*), 1 ibndry(6,*),itedge(3,*),ip(100),ibedge(2,*) real + x(*),y(*),u(*),ux(*),uy(*),vx(*),vy(*),xm(*),ym(*), 1 gf(maxd,*),c(3),p(6),values(11) 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) ngf=ip(77) nevp=iabs(ip(16)) iord=ip(26) c c ifn=ip(17) for systems c ifn=1 ifn=ip(17) if(ifn.lt.0.or.ifn.gt.ngf) ifn=1 c if(ip(16).gt.0) then call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge, + qtree,jflag) p(5)=0.0e0 p(6)=ceps(ibit)*32.0e0 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)=82 return endif endif c c initailization for evaluation loop c umin=p(5) eps=p(6) do 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.gt.0) then 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.gt.0) then call ptevl(it,itnode,itedge,ibndry,iord, + ndof,itdof,vx,vy,xm,ym,gf(1,ifn), 1 x(i),y(i),0,values) u(i)=values(1) ux(i)=values(2) uy(i)=values(3) endif endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fndtri(x,y,i,c,vx,vy,xm,ym,queue, + llen,qtree,list,itnode,itedge,ibndry,eps) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),ibndry(6,*),list(*),queue(*),qtree(5,*), 1 itedge(3,*) real + 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.0e0) 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.0e0) go to 25 rad=((xc-x1)**2+(yc-y1)**2)*(1.0e0-eps) z=((xc-x)**2+(yc-y)**2)*(1.0e0+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.0e0) 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.01e0) 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.0e0) go to 35 rad=((xc-x1)**2+(yc-y1)**2)*(1.0e0+eps) z=((xc-x)**2+(yc-y)**2)*(1.0e0-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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mktree(qtree,list,llen,p,ntf,vx,vy,xm,ym,itnode, + itedge,ibndry,iflag) c implicit real (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),list(*),itnode(5,*),itedge(3,*),ibndry(6,*) real 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)=amin1(p(1),xmin) p(2)=amax1(p(2),xmax) p(3)=amin1(p(3),ymin) p(4)=amax1(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine refnbx(i,p,qtree,list,vx,vy,xm,ym,itnode, + itedge,ibndry,iflag) c implicit real (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,*) real + 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))/float(2*ib(3)) dy=(p(4)-p(3))/float(2*ib(4)) do j=1,5 xp(j)=p(1)+float(2*ib(1)-4+j)*dx yp(j)=p(3)+float(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.0e0 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.0e0 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.0e0 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.0e0 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine getlst(x,y,queue,iptr,qtree,p) c implicit real (a-h,o-z) implicit integer (i-n) integer + qtree(5,*),queue(*) real + 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=int(xx*float(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=int(yy*float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine vari(i,xmin,xmax,ymin,ymax,vx,vy,xm,ym, + itnode,itedge,ibndry) c implicit real (a-h,o-z) implicit integer (i-n) integer + itnode(5,*),itedge(3,*),ibndry(6,*) real + vx(*),vy(*),xm(*),ym(*) c c compute the maximun and minimum c x and y values in triangle i c xmin=amin1(vx(itnode(1,i)),vx(itnode(2,i)),vx(itnode(3,i))) ymin=amin1(vy(itnode(1,i)),vy(itnode(2,i)),vy(itnode(3,i))) xmax=amax1(vx(itnode(1,i)),vx(itnode(2,i)),vx(itnode(3,i))) ymax=amax1(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.0e0) go to 10 rr=sqrt(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.0e0) then xmax=amax1(xx,xmax) xmin=amin1(xx,xmin) ymax=amax1(yy,ymax) ymin=amin1(yy,ymin) endif enddo 10 continue c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bindex(i,istart,llen,qtree) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine bcoord(i,ib,qtree) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ascutl(id,fname,mode,iflag) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ascstr(id,sval,length,iflag) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ascint(id,ival,length,iflag) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine ascflt(id,rval,length,iflag) c implicit real (a-h,o-z) implicit integer (i-n) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine rdwrt(fname,isave,vx,vy,xm,ym,ibndry,itnode,ja,a, + ip,rp,sp,iu,ru,su,w) c implicit real (a-h,o-z) implicit integer (i-n) integer + ibndry(6,*),itnode(5,*),ip(100),iu(100),ja(*) real + 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/'rwsingle'/ 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=87 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) ndf=ip(5) ifirst=ip(6) iord=ip(26) maxd=ip(89) nproc0=ip(49) ip(48)=mpisw ip(49)=nproc ip(50)=myid+1 c iuu=ip(90) itdof=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 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),6*lipath,jflag) if(lenja.gt.0) then call xdrint(id,w(ka),1000,jflag) call xdrint(id,ja,lenja,jflag) endif ndof=(iord+1)*(iord+2)/2 call xdrint(id,w(itdof),ndof*ntf,jflag) 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(iuu+(k-1)*maxd),ndf,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)*maxd),ndf,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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fixpth(path,path0) c implicit real (a-h,o-z) implicit integer (i-n) real + path0(101,*),path(101,*) c c compare old and new paths and start a new branch if reasonable c num=int(path(101,1)) num0=int(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=int(path(num0,6)) it0=int(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)=float(7) path(101,1)=float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fixhst(hist,hist0) c implicit real (a-h,o-z) implicit integer (i-n) real + hist0(22,*),hist(22,*) c c compare old and new histray arrays c mxhist=20 numhst=20 num=int(hist(mxhist+2,1)) num0=int(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)=float(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine reset(num,name,nptr,labels,values,ip,rp,sp) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(*),nptr(*),mark(100) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine menu(ip,rp,sp) c implicit real (a-h,o-z) implicit integer (i-n) integer + st(24),ip(*),iptr(525),nptr(301),sptr(101) real + 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,mpibtn c data ifirst,mpibtn/-1,0/ data lowera,lowerz/97,122/ c if(ifirst.eq.-1) then call mpiutl(1) mode=0 do i=1,100 ip(i)=0 rp(i)=0.0e0 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) jnlsw=mode if(mode.gt.1.or.mode.lt.-1) then sp(11)='menu: bad value for mode' return endif if(myid.ne.0) then 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 jnlsw=2 mode=-2 else mode=-2 jnlsw=mode endif else 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') then mpibtn=i call xmpi(mpisw,mpibtn) endif 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 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.ge.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 if(ctable(jcmd)(1:6).eq.'mpicmd') ip(48)=mpisw 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.ge.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,mpibtn) go to 5 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine parcmd(ncmd,ctable,list,length,nequal, + jcmd,cmdtyp,ierr) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine shrtfm(ip,rp,sp,length,sty,st,ierr) c implicit real (a-h,o-z) implicit integer (i-n) integer + st(*),ip(*) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine prtfl(file,len) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine prtfl0(file,len) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine getnam(name,nlen) c implicit real (a-h,o-z) implicit integer (i-n) c integer + lcomma(24),lequal(24),ig(2) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkcmd(file,len,name,nlen,nptr,labels,values, + ncmd,ctable,st,sty,iptr,ip,rp,sp) c implicit real (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) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine usrset(file,len,ip,rp,sp) c implicit real (a-h,o-z) implicit integer (i-n) c integer + iptr(5),st(5),nptr(301),ip(100) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine gtfile(file,len) c implicit real (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=ndf,t=i', 5 'ni=6,n=ifirst,t=i,a=f,d="1"', 6 'ni=7,n=iprob,t=i,a=p,d="1"', 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=12,n=ising,t=i,d="0"', 2 '#ni=15,n=mxstep,t=i,a=ms,d="20"', 3 'ni=16,n=nevp,t=i', 4 'ni=19,n=ierrsw,t=i,a=e,d="0"', 5 'ni=20,n=iadapt,t=i,a=a,d="1"', 6 'ni=21,n=irefn,t=i,a=ir,d="2"', 7 'ni=22,n=nvtrgt,t=i,a=n', 8 'ni=23,n=nrgn,t=i,a=nr,d="10"', 9 'ni=24,n=mflag,t=i,a=m,d="0"'/ data (file0(i),i= 21, 30)/ + 'ni=25,n=iflag,t=i', 1 'ni=26,n=iord,t=i,d="1"', 2 'ni=27,n=newntf,t=i', 3 'ni=28,n=newnvf,t=i', 4 'ni=29,n=newnbf,t=i', 5 'ni=30,n=newndf,t=i', 6 'ni=31,n=nvv,t=i', 7 'ni=32,n=nbb,t=i', 8 'ni=33,n=ndd,t=i', 9 'ni=34,n=nvi,t=i'/ data (file0(i),i= 31, 40)/ + 'ni=35,n=nbi,t=i', 1 'ni=36,n=ndi,t=i', 2 'ni=37,n=ntg,t=i', 3 'ni=38,n=nvg,t=i', 4 'ni=39,n=nbg,t=i', 5 'ni=40,n=ndg,t=i', 6 'ni=41,n=iusrsw,t=i,d="1"', 7 'ni=42,n=mode,t=i,d="0"', 8 'ni=43,n=ngraph,t=i,d="0"', 9 'ni=44,n=fdevce,t=i,a=d,d="0"'/ data (file0(i),i= 41, 50)/ + 'ni=45,n=gdevce,t=i,a=d,d="1"', 1 'ni=46,n=jdevce,t=i,a=d,d="2"', 2 'ni=47,n=mdevce,t=i,a=d,d="3"', 3 'ni=48,n=mpisw,t=i,a=i,d="-1"', 4 'ni=49,n=nproc,t=i,d="1"', 5 'ni=50,n=irgn,t=i,d="1"', 6 'ni=51,n=mxcolr,t=i,a=mc,d="100"', 7 'ni=52,n=ifun,t=i,a=f,d="0"', 8 'ni=53,n=inplsw,t=i,a=i,d="0"', 9 'ni=54,n=igrsw,t=i,a=i,d="0"'/ data (file0(i),i= 51, 60)/ + 'ni=55,n=imtxsw,t=i,a=i,d="2"', 1 'ni=56,n=ncon,t=i,a=c,d="11"', 2 'ni=57,n=icont,t=i,a=ic,d="0"', 3 'ni=58,n=iscale,t=i,a=s,d="0"', 4 'ni=59,n=lines,t=i,a=l,d="0"', 5 'ni=60,n=numbrs,t=i,a=n,d="0"', 6 'ni=61,n=nx,t=i,a=nx,d="0"', 7 'ni=62,n=ny,t=i,a=ny,d="0"', 8 'ni=63,n=nz,t=i,a=nz,d="1"', 9 'ni=64,n=mx,t=i,a=mx,d="1"'/ data (file0(i),i= 61, 70)/ + 'ni=65,n=my,t=i,a=my,d="1"', 1 'ni=66,n=mz,t=i,a=mz,d="1"', 2 'ni=67,n=level,t=i,a=lv,d="0"', 3 'ni=68,n=icrsn,t=i,a=cr,d="0"', 4 'ni=69,n=itrgt,t=i,a=it,d="10000"', 5 'ni=70,n=ibase,t=i', 6 'ni=71,n=nvdd,t=i', 7 'ni=72,n=lipath,t=i', 8 'ni=73,n=lenja,t=i', 9 'ni=74,n=lena,t=i'/ data (file0(i),i= 71, 80)/ + 'ni=75,n=lvl,t=i', 1 'ni=76,n=nef,t=i', 2 'ni=77,n=ngf,t=i', 3 'ni=78,n=ndl,t=i', 4 'ni=79,n=ievals,t=i', 5 'ni=80,n=itnum,t=i', 6 'ni=81,n=maxpth,t=i', 7 'ni=82,n=lenw,t=i', 8 'ni=83,n=maxt,t=i', 9 'ni=84,n=maxv,t=i'/ data (file0(i),i= 81, 90)/ + 'ni=85,n=maxc,t=i', 1 'ni=86,n=maxb,t=i', 2 'ni=87,n=maxja,t=i', 3 'ni=88,n=maxa,t=i', 4 'ni=89,n=maxd,t=i', 5 'ni=90,n=iuu,t=i', 6 'ni=91,n=itdof,t=i', 7 'ni=92,n=jtime,t=i', 8 'ni=93,n=jhist,t=i', 9 'ni=94,n=jpath,t=i'/ data (file0(i),i= 91,100)/ + 'ni=95,n=ka,t=i', 1 'ni=96,n=jstat,t=i', 2 'ni=97,n=iee,t=i', 3 'ni=98,n=ipath,t=i', 4 'ni=99,n=iz,t=i', 5 'ni=1,n=rltrgt,t=r,a=l,d="0.0e0"', 6 'ni=2,n=rtrgt,t=r,a=r,d="0.0e0"', 7 'ni=3,n=rmtrgt,t=r,a=m,d="0.1e0"', 8 'ni=4,n=rllwr,t=r,a=lw,d="0.0e0"', 9 'ni=5,n=rlupr,t=r,a=up,d="1.0e0"'/ data (file0(i),i=101,110)/ + 'ni=6,n=dtol,t=r,a=d,d="1.0e-3"', 1 'ni=8,n=smin,t=r,a=sn,d="0.0e0"', 2 'ni=9,n=smax,t=r,a=sx,d="0.0e0"', 3 'ni=10,n=rmag,t=r,a=m,d="1.0e0"', 4 'ni=11,n=cenx,t=r,a=cx,d="0.5e0"', 5 'ni=12,n=ceny,t=r,a=cy,d="0.5e0"', 6 'ni=15,n=hmax,t=r,a=hx,d="0.1e0"', 7 'ni=16,n=grade,t=r,a=g,d="1.5e0"', 8 'ni=17,n=hmin,t=r,a=hn,d="0.001e0"', 9 'ni=21,n=rl,t=r'/ data (file0(i),i=111,120)/ + 'ni=22,n=r,t=r', 1 'ni=23,n=rldot,t=r', 2 'ni=24,n=rdot,t=r', 3 'ni=25,n=sval,t=r', 4 'ni=26,n=rlstrt,t=r', 5 'ni=27,n=rstrt,t=r', 6 'ni=31,n=rl0,t=r', 7 'ni=32,n=r0,t=r', 8 'ni=33,n=rl0dot,t=r', 9 'ni=34,n=r0dot,t=r'/ data (file0(i),i=121,130)/ + 'ni=35,n=sval0,t=r', 1 'ni=37,n=enorm1,t=r', 2 'ni=38,n=unorm1,t=r', 3 'ni=39,n=enorm2,t=r', 4 'ni=40,n=unorm2,t=r', 5 '#ni=42,n=tstart,t=r,a=s,d="0.0e0"', 6 '#ni=43,n=tend,t=r,a=e,d="0.0e0"', 7 '#ni=44,n=tmtol,t=r,a=tt,d="1.0e-2"', 8 '#ni=45,n=sh,t=r,d="0.0e0"', 9 '#ni=46,n=tcur,t=r'/ data (file0(i),i=131,140)/ + '#ni=47,n=deltat,t=r', 1 '#ni=48,n=dtmin,t=r', 2 '#ni=49,n=dtmax,t=r', 3 '#ni=50,n=utnorm,t=r', 4 'ni=51,n=eps,t=r', 5 'ni=52,n=step,t=r,d="1.0e0"', 6 'ni=53,n=reler0,t=r,d="1.0e0"', 7 'ni=54,n=relerr,t=r,d="1.0e0"', 8 'ni=55,n=anorm,t=r,d="1.0d0"', 9 'ni=56,n=relres,t=r,d="1.0e0"'/ data (file0(i),i=141,150)/ + 'ni=57,n=bratio,t=r,d="1.0e0"', 1 'ni=58,n=dnew,t=r', 2 'ni=59,n=bnorm0,t=r', 3 'ni=60,n=bmnrm0,t=r', 4 'ni=63,n=rmu,t=r,d="1.0e0"', 5 'ni=64,n=reg,t=r,d="1.0e0"', 6 'ni=67,n=scleqn,t=r', 7 'ni=68,n=scale,t=r', 8 'ni=69,n=thetal,t=r', 9 'ni=70,n=thetar,t=r'/ data (file0(i),i=151,160)/ + 'ni=71,n=sigma,t=r', 1 'ni=72,n=delta,t=r', 2 'ni=73,n=drdrl,t=r', 3 'ni=74,n=seqdot,t=r', 4 'ni=76,n=qual,t=r', 5 'ni=77,n=angmn,t=r,d="0.25e0"', 6 'ni=78,n=diam,t=r', 7 'ni=79,n=best,t=r', 8 'ni=80,n=area,t=r', 9 'ni=81,n=tola,t=r,d="1.0e-2"'/ data (file0(i),i=161,170)/ + 'ni=82,n=arcmin,t=r,d="0.015e0"', 1 'ni=83,n=arcmax,t=r,d="0.26e0"', 2 'ni=84,n=tolz,t=r,d="1.0e-5"', 3 'ni=85,n=tolf,t=r,d="8.0e0"', 4 'ni=87,n=xmin,t=r', 5 'ni=88,n=xmax,t=r', 6 'ni=89,n=ymin,t=r', 7 'ni=90,n=ymax,t=r', 8 'ni=1,n=ftitle,t=l,a=t,d="triplt"', 9 'ni=2,n=ititle,t=l,a=t,d="inplt"'/ data (file0(i),i=171,180)/ + 'ni=3,n=gtitle,t=l,a=t,d="gphplt"', 1 'ni=4,n=mtitle,t=l,a=t,d="mtxplt"', 2 'ni=5,n=shcmd,t=l,a=c', 3 'ni=6,n=rwfile,t=f,a=f,d="pltmg_mpixxx.rw"', 4 'ni=7,n=jrfile,t=f,a=f,d="pltmg.jnl"', 5 'ni=8,n=jwfile,t=f,d="journl_mpixxx.jnl"', 6 'ni=9,n=bfile,t=f,d="output_mpixxx.out"', 7 'ni=10,n=jtfile,t=f,d="jnltmp_mpixxx.jnl"', 8 'ni=11,n=iomsg,t=l', 9 'ni=12,n=cmd,t=s'/ data (file0(i),i=181,190)/ + 'ni=13,n=logo,t=l,d="pltmg 10.0"', 1 'ni=14,n=bgclr,t=l,d="gray85"', 2 'ni=15,n=btnbg,t=l,d="gray30"', 3 'ni=18,n=psfile,t=f,d="figxxx.ps"', 4 'ni=19,n=xpfile,t=f,d="figxxx.xpm"', 5 'ni=20,n=bhfile,t=f,d="figxxx.bh"', 6 'ni=21,n=sghost,t=f,d="localhost"', 7 'cc=pltmg,k=s,t=popup', 8 'cc=trigen,k=t,t=popup', 9 'cc=triplt,k=f,t=popup'/ data (file0(i),i=191,200)/ + 'cc=gphplt,k=g,t=popup', 1 'cc=inplt,k=i,t=popup', 2 'cc=mtxplt,k=m,t=popup', 3 'cc=read,k=r,t=file', 4 'cc=write,k=w,t=file', 5 'cc=usrcmd,k=u,t=usrcmd', 6 'cc=journl,k=j,t=journl', 7 'cc=shell,k=k,t=popup', 8 'cc=mpi,k=p,t=mpicmd', 9 'cc=quit,k=q,t=quit'/ data (file0(i),i=201,210)/ + 'rc=pltmg,n=iprob', 1 'rc=pltmg,n=ifirst', 2 'rc=pltmg,n=itask', 3 'rc=pltmg,n=ispd', 4 'rc=pltmg,n=mxcg', 5 'rc=pltmg,n=mxnwtt', 6 'rc=pltmg,n=rltrgt', 7 'rc=pltmg,n=rtrgt', 8 'rc=pltmg,n=dtol', 9 'rc=pltmg,n=rllwr'/ data (file0(i),i=211,220)/ + 'rc=pltmg,n=rlupr', 1 'rc=pltmg,n=rmtrgt', 2 '#rc=pltmg,n=mxstep', 3 '#rc=pltmg,n=tmtol', 4 '#rc=pltmg,n=tstart', 5 '#rc=pltmg,n=tend', 6 'rc=trigen,n=iadapt', 7 'rc=trigen,n=ifirst', 8 'rc=trigen,n=nvtrgt', 9 'rc=trigen,n=ierrsw'/ data (file0(i),i=221,230)/ + 'rc=trigen,n=irefn', 1 'rc=trigen,n=nrgn', 2 'rc=trigen,n=hmax', 3 'rc=trigen,n=hmin', 4 'rc=trigen,n=grade', 5 'rc=triplt,n=ifun,s=1', 6 'rc=triplt,n=iscale', 7 'rc=triplt,n=lines', 8 'rc=triplt,n=numbrs', 9 'rc=triplt,n=fdevce'/ data (file0(i),i=231,240)/ + 'rc=triplt,n=nx', 1 'rc=triplt,n=ny', 2 'rc=triplt,n=nz', 3 'rc=triplt,n=ncon', 4 'rc=triplt,n=icont', 5 'rc=triplt,n=icrsn', 6 'rc=triplt,n=itrgt', 7 'rc=triplt,n=mxcolr', 8 'rc=triplt,n=smin', 9 'rc=triplt,n=smax'/ data (file0(i),i=241,250)/ + 'rc=triplt,n=rmag', 1 'rc=triplt,n=cenx', 2 'rc=triplt,n=ceny', 3 'rc=triplt,n=ftitle', 4 'rc=gphplt,n=igrsw,s=1', 5 'rc=gphplt,n=mx', 6 'rc=gphplt,n=my', 7 'rc=gphplt,n=mz', 8 'rc=gphplt,n=gdevce', 9 'rc=gphplt,n=mxcolr'/ data (file0(i),i=251,260)/ + 'rc=gphplt,n=gtitle', 1 'rc=inplt,n=inplsw,s=1', 2 'rc=inplt,n=iscale', 3 'rc=inplt,n=lines', 4 'rc=inplt,n=numbrs', 5 'rc=inplt,n=jdevce', 6 'rc=inplt,n=rmag', 7 'rc=inplt,n=cenx', 8 'rc=inplt,n=ceny', 9 'rc=inplt,n=ncon'/ data (file0(i),i=261,270)/ + 'rc=inplt,n=mxcolr', 1 'rc=inplt,n=icrsn', 2 'rc=inplt,n=itrgt', 3 'rc=inplt,n=ititle', 4 'rc=inplt,n=smin', 5 'rc=inplt,n=smax', 6 'rc=mtxplt,n=imtxsw,s=1', 7 'rc=mtxplt,n=iscale', 8 'rc=mtxplt,n=lines', 9 'rc=mtxplt,n=numbrs'/ data (file0(i),i=271,280)/ + 'rc=mtxplt,n=mdevce', 1 'rc=mtxplt,n=mx', 2 'rc=mtxplt,n=my', 3 'rc=mtxplt,n=mz', 4 'rc=mtxplt,n=ncon', 5 'rc=mtxplt,n=level', 6 'rc=mtxplt,n=mxcolr', 7 'rc=mtxplt,n=smin', 8 'rc=mtxplt,n=smax', 9 'rc=mtxplt,n=rmag'/ data (file0(i),i=281,290)/ + 'rc=mtxplt,n=cenx', 1 'rc=mtxplt,n=ceny', 2 'rc=mtxplt,n=mtitle', 3 'rc=read,n=rwfile,s=1', 4 'rc=write,n=rwfile,s=1', 5 'rc=journl,n=jrfile,s=1', 6 'rc=shell,n=shcmd,s=1', 7 'rc=mpi,n=mpisw,s=1', 8 'rc=mpi,n=mflag', 9 'sn=ifirst,v=0,l="default"'/ data (file0(i),i=291,300)/ + 'sn=ifirst,v=1,l="initialize linear elements"', 1 'sn=ifirst,v=2,l="initialize quadratic elements"', 2 'sn=ifirst,v=3,l="initialize cubic elements"', 3 'sn=iprob,v=1,l="simple pde"', 4 'sn=iprob,v=2,l="obstacle problem"', 5 'sn=iprob,v=3,l="continuation problem"', 6 'sn=iprob,v=4,l="parameter identification"', 7 'sn=iprob,v=5,l="optimal control"', 8 '#sn=iprob,v=6,l="parabolic problem"', 9 'sn=iprob,v=-1,l="dd solve - simple pde (mpi) "'/ data (file0(i),i=301,310)/ + 'sn=iprob,v=-2,l="dd solve - obstacle (mpi)"', 1 'sn=iprob,v=-3,l="dd solve - continuation (mpi)"', 2 'sn=iprob,v=-4,l="dd solve - parameter identification (mpi)"', 3 'sn=iprob,v=-5,l="dd solve - optimal control (mpi)"', 4 'sn=ispd,v=0,l="nonsymmetric"', 5 'sn=ispd,v=1,l="symmetric"', 6 'sn=itask,v=0,l="target point / default"', 7 'sn=itask,v=1,l="compute singular point"', 8 'sn=itask,v=2,l="switch branches"', 9 'sn=itask,v=3,l="initialize, lambda fixed"'/ data (file0(i),i=311,320)/ + 'sn=itask,v=4,l="initialize, rho fixed"', 1 'sn=itask,v=5,l="sigma = 0, lambda fixed"', 2 'sn=itask,v=6,l="sigma = 0, rho fixed"', 3 'sn=itask,v=7,l="sigma = 0, theta = 1"', 4 'sn=itask,v=8,l="new lambda"', 5 'sn=itask,v=9,l="use functional"', 6 '#sn=itask,v=10,l="time steps"', 7 '#sn=itask,v=11,l="fixed time"', 8 'sn=ierrsw,v=0,l="global continuous recovery"', 9 'sn=ierrsw,v=1,l="patchwise continuous recovery"'/ data (file0(i),i=321,330)/ + 'sn=iadapt,v=0,l="error estimates"', 1 'sn=iadapt,v=1,l="refine or unrefine"', 2 'sn=iadapt,v=-1,l="refine or unrefine (qxy)"', 3 'sn=iadapt,v=2,l="unrefine and refine"', 4 'sn=iadapt,v=-2,l="unrefine and refine (qxy)"', 5 'sn=iadapt,v=3,l="mesh smoothing"', 6 'sn=iadapt,v=-3,l="mesh smoothing (qxy)"', 7 'sn=iadapt,v=4,l="uniform refinement"', 8 'sn=iadapt,v=5,l="skeleton --> triangulation"', 9 'sn=iadapt,v=-5,l="skeleton --> skeleton"'/ data (file0(i),i=331,340)/ + '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=341,350)/ + '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=351,360)/ + '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=361,370)/ + '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=371,380)/ + '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=381,390)/ + '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=391,400)/ + 'sn=ifun,v=11,l="dual"', 1 'sn=inplsw,v=0,l="region tag"', 2 'sn=inplsw,v=1,l="load balance"', 3 'sn=inplsw,v=2,l="element quality"', 4 'sn=inplsw,v=3,l="max angle"', 5 'sn=inplsw,v=4,l="min angle"', 6 'sn=inplsw,v=5,l="element diameter"', 7 'sn=inplsw,v=6,l="error"', 8 'sn=igrsw,v=0,l="newton conv"', 9 'sn=igrsw,v=1,l="multigraph conv"'/ data (file0(i),i=401,410)/ + 'sn=igrsw,v=-1,l="matrix size"', 1 'sn=igrsw,v=2,l="subroutine times"', 2 'sn=igrsw,v=-2,l="time pie chart"', 3 'sn=igrsw,v=3,l="continuation path"', 4 'sn=igrsw,v=-3,l="load balance"', 5 'sn=igrsw,v=4,l="h1 error"', 6 'sn=igrsw,v=-4,l="l2 error"', 7 'sn=igrsw,v=5,l="ip array"', 8 'sn=igrsw,v=-5,l="sp array"', 9 'sn=igrsw,v=6,l="rp array"'/ data (file0(i),i=411,420)/ + 'sn=imtxsw,v=1,l="|ilu| by type"', 1 'sn=imtxsw,v=-1,l="ilu by type"', 2 'sn=imtxsw,v=2,l="|ilu| by value"', 3 'sn=imtxsw,v=-2,l="ilu by value"', 4 'sn=imtxsw,v=3,l="|mtx a| by type"', 5 'sn=imtxsw,v=-3,l="mtx a by type"', 6 'sn=imtxsw,v=4,l="|mtx a| by value"', 7 'sn=imtxsw,v=-4,l="mtx a by value"', 8 'sn=icont,v=0,l="do not smooth function"', 9 'sn=icont,v=1,l="smooth function"'/ data (file0(i),i=421,430)/ + 'sn=iscale,v=0,l="linear"', 1 'sn=iscale,v=1,l="log"', 2 'sn=iscale,v=2,l="arcsinh"', 3 'sn=lines,v=0,l="triangulation"', 4 'sn=lines,v=1,l="regions"', 5 'sn=lines,v=2,l="load balance"', 6 'sn=lines,v=3,l="contours"', 7 'sn=lines,v=-1,l="graphics triangulation"', 8 'sn=lines,v=-2,l="matrix elements"', 9 'sn=numbrs,v=0,l="none"'/ data (file0(i),i=431,440)/ + 'sn=numbrs,v=1,l="triangles/regions"', 1 'sn=numbrs,v=2,l="vertices"', 2 'sn=numbrs,v=3,l="edges"', 3 'sn=numbrs,v=4,l="arcs"', 4 'sn=numbrs,v=5,l="bdy cond"', 5 'sn=numbrs,v=6,l="bdy tag"', 6 'sn=numbrs,v=7,l="processor"', 7 'sn=numbrs,v=8,l="vertex type"', 8 'sn=numbrs,v=-1,l="mtx value"', 9 'sn=numbrs,v=-2,l="mtx index"'/ data (file0(i),i=441,444)/ + 'sn=icrsn,v=0,l="no coarsening"', 1 'sn=icrsn,v=1,l="coarsening"', 2 'sn=mpisw,v=1,l="turn on mpi"', 3 'sn=mpisw,v=-1,l="turn off mpi"'/ c data len0/444/ c len=len0 do i=1,len file(i)=file0(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mktabl(icmd,name,iptr,sname, + nptr,labels,values,sptr,slabel,svalue) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine getcmd(list) c implicit real (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) if(mode.eq.1.or.jnlsw.eq.2) then list='q' else list=' ' jnlsw=mode endif endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine lookup(name,num,ip,rp,sp,list,ierr,length) c implicit real (a-h,o-z) implicit integer (i-n) integer + ival(24),ip(*),lequal(24),lcomma(24),iptr(24) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine disply(name,num,ip,rp,sp) c implicit real (a-h,o-z) implicit integer (i-n) integer + ip(*) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine discmd(ncmd,ctable) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sreal(list,length,val,ndig,just) c implicit real (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.0e0) then length=3 list(1)=zero list(2)=dot list(3)=zero else zc=abs(val) zz=alog10(zc) iex=int(zz) ratio=10.0e0**(zz-float(iex)) c** ratio=zc*(10.0e0**(-iex)) if(iex.eq.-1) then h=0.5e0*10.0e0**(2-ndig) else h=0.5e0*10.0e0**(1-ndig) endif if(ratio+h.lt.1.0e0) then ratio=ratio*10.0e0 iex=iex-1 else if(ratio+h.ge.10.0e0) then ratio=ratio/10.0e0 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=int(ratio*10.0e0**(ndig-2)+0.5e0) else n=int(ratio*10.0e0**(ndig-1)+0.5e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sint(list,length,ival) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine fstr(ss,length,sval,iquote) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkname(outnam,innam) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine creal(list,length,val,ierr) c implicit real (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.0e0 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.0e0 do i=ii,newlen kx=ichar(temp(i))-zero if(kx.lt.0.or.kx.gt.9) return value=10.0e0*value+float(kx) enddo if(temp(1).eq.minus) then val=-value*(10.0e0**ix) else val=value*(10.0e0**ix) endif ierr=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cint(list,length,ival,ierr) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine cpause() c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine crtutl(list,mode,prompt) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine filutl(list,isw) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine mkjnl(sp,iflag) c implicit real (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=-7 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine stfile(outnam,innam) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pltutl(ncolor,red,green,blue) c implicit real (a-h,o-z) implicit integer (i-n) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pframe(iframe) c implicit real (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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pline(x,y,z,n,icolor) c implicit real (a-h,o-z) implicit integer (i-n) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pfill(x,y,z,n,icolor) c implicit real (a-h,o-z) implicit integer (i-n) real + 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine psutl(ncolor,red,green,blue,fname) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.0e3 fscale=1.0e0 xshift=0.0e0 yshift=0.0e0 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.0e0/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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine sframe(iframe) c implicit real (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.0e0 xshift=scale yshift=scale/2.0e0 else if(iframe.eq.3) then fscale=scale/2.0e0 xshift=scale yshift=0.0e0 else fscale=scale xshift=0.0e0 yshift=0.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine pspath(x,y,z,n,icolor,itype) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=nint((x(i+1)-x(i))*fscale) iy=nint((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=nint(x(1)*fscale+xshift) iy=nint(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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xutl(ncolor,red,green,blue,id) c implicit real (a-h,o-z) implicit integer (i-n) real + red(*),green(*),blue(*) common /xpm0/iscale,jscale,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)=int(red(i)*65535.0e0) image(3*i-1)=int(green(i)*65535.0e0) image(3*i)=int(blue(i)*65535.0e0) enddo call xginit(ncolor,image,id,ix,iy) ny=min0(600,iy) nx=ny*3/2 scale=float(ny) iscale=nx jscale=ny ishift=512 do k=1,nx*ny image(k)=0 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xpmutl(ncolor,red,green,blue,fname) c implicit real (a-h,o-z) implicit integer (i-n) real + red(*),green(*),blue(*) character*1 + cdef(92) character*2 + cmap(256),cs character*80 + fname,sname character*2000 + msg common /xpm0/iscale,jscale,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=600 c*** ny=260 nx=ny*3/2 c*** nx=ny scale=float(ny) iscale=nx jscale=ny 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine hexclr(r,g,b,color) c implicit real (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)=int(r*65535.0e0) ic(2)=int(g*65535.0e0) ic(3)=int(b*65535.0e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xframe(iframe) c implicit real (a-h,o-z) implicit integer (i-n) common /xpm1/scale,fscale,xshift,yshift c c if(iframe.eq.2) then fscale=scale/2.0e0 xshift=scale yshift=scale/2.0e0 else if(iframe.eq.3) then fscale=scale/2.0e0 xshift=scale yshift=0.0e0 else fscale=scale xshift=0.0e0 yshift=0.0e0 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xline(x,y,z,n,icolor) c implicit real (a-h,o-z) implicit integer (i-n) real + 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.01e0 ix=int(x(1)*fscale+xshift+0.5e0) iy=int(y(1)*fscale+yshift+0.5e0) iz=int(z(1)*fscale+zshift+0.5e0) do i=2,n jx=ix jy=iy jz=iz ix=int(x(i)*fscale+xshift+0.5e0) iy=int(y(i)*fscale+yshift+0.5e0) iz=int(z(i)*fscale+zshift+0.5e0) call iline(ix,iy,iz,jx,jy,jz,icolor) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine iline(ix,iy,iz,jx,jy,jz,ic) c implicit real (a-h,o-z) implicit integer (i-n) common /xpm0/iscale,jscale,ishift,image(540000) c c update bitmap for a line segment c ix=max0(ix,1) ix=min0(ix,iscale) jx=max0(jx,1) jx=min0(jx,iscale) iy=max0(iy,1) iy=min0(iy,jscale) jy=max0(jy,1) jy=min0(jy,jscale) c if(ix.ne.jx) then kmin=min0(ix,jx) kmax=max0(ix,jx) do k=kmin,kmax x=float((k-ix)*jx+(jx-k)*ix)/float(jx-ix) y=float((k-ix)*jy+(jx-k)*iy)/float(jx-ix) z=float((k-ix)*jz+(jx-k)*iz)/float(jx-ix) kx=max0(int(x+0.5e0),1) kx=min0(kx,iscale) ky=max0(int(y+0.5e0),1) ky=min0(ky,jscale) kz=int(z+0.5e0) 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=float((k-iy)*jx+(jy-k)*ix)/float(jy-iy) y=float((k-iy)*jy+(jy-k)*iy)/float(jy-iy) z=float((k-iy)*jz+(jy-k)*iz)/float(jy-iy) kx=max0(int(x+0.5e0),1) kx=min0(kx,iscale) ky=max0(int(y+0.5e0),1) ky=min0(ky,jscale) kz=int(z+0.5e0) 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 lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine xfill(x,y,z,n,icolor) c implicit real (a-h,o-z) implicit integer (i-n) real + 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=int(x(1)*fscale+xshift+0.5e0) ixmax=ixmin iymin=int(y(1)*fscale+yshift+0.5e0) iymax=iymin do i=2,n ix=int(x(i)*fscale+xshift+0.5e0) iy=int(y(i)*fscale+yshift+0.5e0) 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=(float(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=int(rm(j )*fscale+yshift+0.5e0) iz=int(rz(j )*fscale +0.5e0) jy=int(rm(j+1)*fscale+yshift+0.5e0) jz=int(rz(j+1)*fscale +0.5e0) 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=(float(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=int(rm(j )*fscale+xshift+0.5e0) iz=int(rz(j )*fscale +0.5e0) jx=int(rm(j+1)*fscale+xshift+0.5e0) jz=int(rz(j+1)*fscale +0.5e0) call iline(ix,k,iz,jx,k,jz,icolor) enddo enddo endif c c trace boundary c ix=int(x(n)*fscale+xshift+0.5e0) iy=int(y(n)*fscale+yshift+0.5e0) iz=int(z(n)*fscale +0.5e0) do i=1,n jx=ix jy=iy jz=iz ix=int(x(i)*fscale+xshift+0.5e0) iy=int(y(i)*fscale+yshift+0.5e0) iz=int(z(i)*fscale +0.5e0) call iline(ix,iy,iz,jx,jy,jz,icolor) enddo return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 10.0 - - - september, 2007 c c----------------------------------------------------------------------- subroutine timer(time,isw) c implicit real (a-h,o-z) implicit integer (i-n) real + time(3,*) real temp(2),etime save tx,len data tx/0.0e0/ 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=amax1(tx-ty,1.0e-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.0e0 enddo else if(isw.eq.-2) then do i=1,len time(1,i)=0.0e0 time(2,i)=0.0e0 time(3,i)=0.0e0 enddo endif return end