c***************************** file: mg1.f ***************************** c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pltmg(vx,vy,sf,itnode,ibndry,itdof,ipath, + e,ip,rp,sp,gf,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), allocatable, dimension(:,:) :: ibedge integer(kind=iknd), allocatable, dimension(:) :: ja, + ibs,ibp,jp,ibo real(kind=rknd), dimension(*) :: vx,vy,e,gf real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp character(len=80), dimension(100) :: sp cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c user specified ip variables c if(ip(5)<0.or.ip(5)>9) ip(6)=1 if(ip(6)<-6.or.ip(6)>7) ip(7)=1 if(ip(9)<-2.or.ip(9)>2) ip(3)=1 if(ip(12)/=1) ip(12)=0 if(ip(8)/=1) ip(8)=0 ip(10)=max(1_iknd,ip(10)) ip(11)=max(1_iknd,ip(11)) rp(3)=max(rp(3),0.0e0_rknd) ip(25)=0 if(ip(5)/=0) ip(24)=0 c c call setcom c c error flags c if(itnode(3,1)==0) then ip(25)=25 go to 20 endif c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) iprob=ip(6) mpisw=ip(48) nproc=ip(49) irgn=ip(50) maxd=ip(85) c if(ip(5)/=0) then call stor(ip,rp) call timer(-2_iknd) call hist2(rp,0_iknd,0_iknd) call updpth(1_iknd,1_iknd,rp) call dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy) if(ip(25)/=0) return c c setup itdof c call mkdof(ntf,nvf,nbf,ip,itnode,ibndry,itdof) ndf=ip(4) ip(5)=0 c maxt=ip(83) maxd=ip(85) c call gfinit(ip,maxd,gf,maxt,e) else call timer(-1_iknd) endif c c check for mpi status c if(iprob<0) then if(mpisw/=1) then ip(25)=48 go to 20 endif call timer(35_iknd) call exflag(ip(24)) call timer(11_iknd) if(ip(24)/=0) then ip(25)=24 go to 20 endif endif c c storage sizes c call clenja(ip,itnode,ibndry,itdof,nvf) call clnja0(ip,itdof) call lsize(ip,isize) allocate(ja(isize(2)),ibs(isize(1)), + ibp(isize(1)),ibedge(2,nbf),jp(isize(2)),ibo(isize(1))) c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,kflag) if(kflag/=0) then ip(25)=kflag go to 10 endif c c sparse matrix data structures c nb=ip(91) maxja=ip(92) call timer(35_iknd) call mkblk(ndf,ntf,nb,nsc,ibs,ibp,itdof) call setgrb(ntf,ndf,nb,maxja,itdof,ja,ibs,ibp,kflag) call timer(19_iknd) if(kflag/=0) then ip(25)=kflag go to 10 endif ip(91)=nb ip(92)=ja(nb+1)-1 c c sparse matrix ordering c maxja=ip(92) call ja2ja(nb,nsc,maxja,ja,ibs,ibp) call timer(21_iknd) c c coarse grid projection factors c call f2cmap(nb,ntf,nbf,ndf,itdof,ibndry,ibedge,ibs,ibp,ibo,jp) c c factored matrix storage c call clenju(ip,nb,maxja,ja,ibs) call lsize(ip,isize) c call gfptr(ip,iuu,iu0,iudot,iu0dot, + ievr,ievl,ivx0,ivy0,ium,iuc,iudl) c c continuation options c if(iprob==3) then c call pltmgc(ip,rp,vx,vy,sf,itnode,ibndry,gf(iuu), + gf(iu0),gf(iudot),gf(iu0dot),gf(ievr),gf(ievl),gf(ium), 1 gf(iuc),gf(ivx0),gf(ivy0),gf(iudl),itdof, 2 ja,jp,ibs,ibp,ibo,ibedge,isize, 3 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) c c time dependent options c else if(iprob==7) then call pltmgp(ip,rp,vx,vy,sf,itnode,ibndry,gf(iuu), + gf(iu0),gf(iudot),gf(iu0dot),gf(ievr),gf(ievl),gf(ium), 1 gf(iuc),gf(ivx0),gf(ivy0),gf(iudl),itdof, 2 ja,jp,ibs,ibp,ibo,ibedge,isize, 3 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) c c obstacle problem c else if(iprob==1.or.iprob==2) then call pltmgo(ip,rp,vx,vy,sf,itnode,ibndry,gf(iuu), + gf(iu0),gf(iudot),gf(iu0dot),gf(ievr),gf(ievl),gf(ium), 1 gf(iuc),gf(ivx0),gf(ivy0),gf(iudl),itdof, 2 ja,jp,ibs,ibp,ibo,ibedge,isize, 3 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) c c parameter identification problem c else if(iprob>=4.and.iprob<=6) then call pltmgi(ip,rp,vx,vy,sf,itnode,ibndry,gf(iuu), + gf(iu0),gf(iudot),gf(iu0dot),gf(ievr),gf(ievl),gf(ium), 1 gf(iuc),gf(ivx0),gf(ivy0),gf(iudl),itdof, 2 ja,jp,ibs,ibp,ibo,ibedge,isize, 3 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) c c domain decomposition solve c else if(iprob<0) then call pltmgd(ip,rp,vx,vy,sf,itnode,ibndry,gf(iuu), + gf(iu0),gf(iudot),gf(iu0dot),gf(ievr),gf(ievl),gf(ium), 1 gf(iuc),gf(ivx0),gf(ivy0),gf(iudl),itdof,ipath, 2 ja,jp,ibs,ibp,ibo,ibedge,isize, 3 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) else ip(25)=6 endif c 10 deallocate(ja,jp,ibs,ibp,ibo,ibedge) call timer(35_iknd) c 20 iflag=ip(25) c c successful return c if(iflag==0) then if(ip(6)<0) then write(unit=sp(11),fmt='(a17,i2,a8,i2,a6,i10,a1)') + 'pltmg: ok (iprob=',ip(6),', itask=',ip(7), 1 ', ndg=',ip(40),')' else write(unit=sp(11),fmt='(a17,i2,a8,i2,a6,i8,a1)') + 'pltmg: ok (iprob=',ip(6),', itask=',ip(7), 1 ', ndf=',ip(4),')' endif c c insufficient storage errors, wrong input data structure c else if(iflag>=82.and.iflag<=86) then write(unit=sp(11),fmt='(a11,i3,a22)') + 'pltmg error',iflag,': insufficient storage' if(nproc>1) ip(24)=irgn else if(iflag==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==1) then write(unit=sp(11),fmt='(a11,i2,a29)') + 'pltmg error',iflag,': zero pivot in factorization' if(nproc>1) ip(24)=irgn else if(iflag==2) then write(unit=sp(11),fmt='(a11,i2,a27)') + 'pltmg error',iflag,': newton line search failed' if(nproc>1) ip(24)=irgn else if(iflag==6) then write(unit=sp(11),fmt='(a11,i2,a22)') + 'pltmg error',iflag,': illegal problem type' else if(iflag==7) then write(unit=sp(11),fmt='(a11,i2,a31)') + 'pltmg error',iflag,': continuation procedure failed' else if(iflag==10) then write(unit=sp(11),fmt='(a11,i3,a29)') + 'pltmg error',iflag,': multigraph iteration failed' if(nproc>1) ip(24)=irgn else if(iflag==11) then if(ip(6)<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>1) ip(24)=irgn else if(iflag==24) then write(unit=sp(11),fmt='(a11,i3,a8,i4)') + 'pltmg error',iflag,': region',ip(24) else if(iflag==48) then write(unit=sp(11),fmt='(a11,i3,a12)') + 'pltmg error',iflag,': mpi is off' else if(iflag==71.or.iflag==72) then write(unit=sp(11),fmt='(a11,i3,a27)') + 'pltmg error',iflag,': dd solver not initialized' if(nproc>1) ip(24)=irgn else if(iflag>-55.and.iflag<-31) then if(nproc>1) ip(24)=irgn else write(unit=sp(11),fmt='(a11,i3,a15)') + 'pltmg error',iflag,': unknown error' if(nproc>1) ip(24)=irgn endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pltmgd(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ipath,ja,jp,ibs,ibp,ibo, 1 ibedge,isize,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl real(kind=rknd), dimension(2,*) :: sf cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c make sure the system is solved on each domain c iprob=abs(ip(6)) ip(6)=iprob jflag=0 c if(iprob==3) then if(ip(7)<5.or.ip(7)>7) ip(9)=7 call ctheta(ip,rp,jflag) if(jflag/=0) then ip(25)=7 return endif else if(iprob==1) then if(ip(7)/=9) ip(7)=0 else ip(7)=0 endif c call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot,evr,evl, + um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo,isize, 1 ibedge,-1_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) c ip(6)=-ip(6) call timer(35_iknd) call exflag(ip(25)) call timer(11_iknd) if(ip(25)/=0) return c call nwttd(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot,um,uc, + vx0,vy0,udl,itdof,ipath,ja,jp,ibs,ibp,ibo,isize,ibedge, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine nwttd(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + um,uc,vx0,vy0,udl,itdof,ipath,ja,jp,ibs,ibp,ibo,isize, 1 ibedge,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo integer(kind=iknd), allocatable, dimension(:) :: jua, + jug,ja0,ir0,map,juac,jugc,jbo integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot, + u0dot,um,uc,vx0,vy0,udl real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), allocatable, dimension(:) :: a,h,g,su,sm, + b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc,usv,umsv,ucsv,ua,ug, 1 a0,h0,g0,su0,sm0,uac,ugc real(kind=rknd), dimension(20) :: t cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c approximate newton method c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) itask=ip(7) iprob=abs(ip(6)) ising=ip(12) nproc=ip(49) nb=ip(91) c eps=1.0e2_rknd*epsilon(1.0e0_rknd) epsmg=max(1.0e-4_rknd,eps) if(iprob==4.or.iprob==6) then t(1)=rp(21) call pl2ip(t,1_iknd) rl=t(1)/real(nproc,rknd) rmu=rp(3) rllwr=rp(4) rlupr=rp(5) tol=max(1.0e-2_rknd*rmu,eps) c if(rlupr/=0.0e0_rknd) then rup=abs(rlupr)*tol else rup=tol endif if(rllwr/=0.0e0_rknd) then rlw=abs(rllwr)*tol else rlw=tol endif if(rllwr+rlw<=rlupr-rup) then rl=max(rl,rllwr+rlw) rl=min(rl,rlupr-rup) else rr=tol*(rlupr-rllwr) rl=max(rl,rllwr+rr) rl=min(rl,rlupr-rr) endif c rp(21)=rl else if(iprob==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_iknd) do k=1,7 rp(20+k)=t(k)/real(nproc,rknd) enddo rp(68)=t(8)/real(nproc,rknd) do k=1,5 rp(30+k)=rp(20+k) enddo endif c c nvdd=ip(71) lipath=ip(72) if(nvdd<=0) then ip(25)=71 else if(lipath<=0) then ip(25)=72 else if(ipath(2,nproc+2)=0) then call timer(35_iknd) call sfhb(nb,ja,jp,ibs,ibo,a, + maxjuac,juac,maxuac,uac,ispd,hbtol,1_iknd) call timer(23_iknd) ip(100)=juac(nb+1)-1 endif c if(iprob==5) then maxjug=isize(13) maxug=isize(14) if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,g,ibs,maxjug,jug, + maxug,ug,1_iknd,dtol,1_iknd) call timer(22_iknd) endif maxjugc=isize(24) maxugc=isize(24) if(method>=0) then do i=1,nb jbo(i)=abs(ibo(i)) enddo call timer(35_iknd) call sfhb(nb,ja,jp,ibs,jbo,g, + maxjugc,jugc,maxugc,ugc,1_iknd,hbtol,1_iknd) call timer(23_iknd) endif endif c c the main loop c call hist3(11_iknd,-1_iknd,1.0e0_rknd,1.0e0_rknd) do itnum=1,jnwtt c c compute approximate factorization c if(itnum>1) then if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,a,ibs,maxjua,jua, + maxua,ua,ispd,dtol,0_iknd) call timer(22_iknd) endif if(method>=0) then call timer(35_iknd) call sfhb(nb,ja,jp,ibs,ibo,a, + maxjua,juac,maxuac,uac,ispd,hbtol,0_iknd) call timer(23_iknd) endif endif c c multi-level solution of newton equations c call timer(35_iknd) if(iprob==3) then call blk3(ndf,ip,rp,vx,vy,itdof,itnode,du,dum, + ja,ibs,ibp,ibo,a,jua,ua,juac,jp,uac, 1 b,rd,p,udot,u0dot,epsmg,jflag,0_iknd) call timer(25_iknd) if(iconv==1) go to 170 if(itnum>mxnwtt) go to 100 else if(iprob==4.or.iprob==6) then call blk4(ndf,ip,rp,du,dum,ja,ibs,ibp,ibo,a, + jua,ua,juac,jp,uac,h,b,p,dl,rd, 1 udot,epsmg,jflag,0_iknd) call timer(19_iknd) else if(iprob==5) then if(itnum>1) then if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,g,ibs,maxjug, + jug,maxug,ug,1_iknd,dtol,0_iknd) call timer(22_iknd) endif if(method>=0) then call timer(35_iknd) call sfhb(nb,ja,jp,ibs,jbo,g, + maxjugc,jugc,maxugc,ugc,1_iknd,hbtol,0_iknd) call timer(23_iknd) endif endif call blk5(ndf,ip,epsmg,ja,ibs,ibp,ibo,a,h,g, + su,sm,jua,ua,juac,jp,uac,jug,ug, 1 jbo,jugc,ugc,du,dum,duc,p,b,dl,reler5,jflag) call timer(27_iknd) else call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 du,b,reler1,jflag,7_iknd) if(iprob==1.and.itask==9) then call mg(ndf,nb,jspd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 dum,p,reler2,jflag,8_iknd) endif call timer(24_iknd) endif c c line search loop c isw=0 call timer(35_iknd) call tpickd(ndf,ip,rp,vx,vy,itnode,ibndry,sf,itdof,u,um, + uc,usv,umsv,ucsv,ja,ibs,ibp,a,h,g,su,sm, 1 b,d,p,dl,bdlwr,bdupr,du,dum,duc,ipath,ir0,map,ja0,a0, 2 h0,g0,su0,sm0,isw,itnum,sxy) call timer(34_iknd) dnew=rp(58) if(dnew>0.0e0_rknd) then call hist3(11_iknd,itnum,rp(56),rp(54)) iconv=icvtst(itnum,-iprob,itask,itype,rp) c**** iconv=jcvtst(itnum,-iprob,itask,itype,rp) if(iconv==1) go to 170 ip(25)=2 if(jflag/=0) ip(25)=11 go to 130 endif iter=0 70 iter=iter+1 c call timer(35_iknd) call rgnsys(ntf,ndf,ip,rp,vx,vy,sf,itnode, + ibndry,ibedge,u,u0,udot,um,uc,vx0,vy0,itdof, 1 ja,ibs,ibp,a,h,g,su,sm,b,d,rd,p,dl, 2 bdlwr,bdupr,ir0,map,ipath,ja0,a0,h0,g0,su0,sm0,nvdd, 3 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) ievals=ievals+1 call timer(29_iknd) c call tpickd(ndf,ip,rp,vx,vy,itnode,ibndry,sf,itdof,u,um, + uc,usv,umsv,ucsv,ja,ibs,ibp,a,h,g,su,sm, 1 b,d,p,dl,bdlwr,bdupr,du,dum,duc,ipath,ir0,map,ja0,a0, 2 h0,g0,su0,sm0,isw,itnum,sxy) call timer(34_iknd) c c test for sufficient decrease c if(isw>=0) then if(iter=tend) return mxstep=max(1_iknd,ip(15)) mxfail=5 rp(46)=tstart rp(49)=tend-tstart rp(48)=rp(49)/real(mxstep,rknd) tnew=rp(46) ifirst=1 c c compute time step c 60 call dtpick(ntf,ndf,itnode,vx,vy,u,u0,rp,itflag, + ifirst,itdof) c c update solution c if(itflag/=-1.and.ifirst/=-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==-1) then rp(46)=tnew rp(42)=tnew rp(43)=tnew endif c c save time history c if(ifirst==1) then if(itflag<=-3) then call updtm(1_iknd,itflag,rp) else call updtm(0_iknd,itflag,rp) endif else if(itflag==-1) then call updtm(0_iknd,itflag,rp) else call updtm(-1_iknd,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_iknd) if(ifirst==-1) return ifirst=0 c c solve equations c 220 idsp=idsp+1 tcur=rp(46) deltat=max(rp(47),rp(48)) rp(21)=tcur+deltat if(deltat>0) then rp(45)=1.0e0_rknd/deltat else rp(45)=0.0e0_rknd endif call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,0_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) if(ip(25)/=0) then if(idsp0) then rp(45)=1.0e0_rknd/deltat else rp(45)=0.0e0_rknd endif call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,0_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) itflag=3 write(unit=iostr,fmt='(2i3,3(1x,e12.5))') + ip(25),itflag,rp(46),rp(47),rp(50) call filutl(iostr,0_iknd) call updtm(0_iknd,3_iknd,rp) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pltmgc(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 ibedge,isize,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl real(kind=rknd), dimension(2,*) :: sf character(len=80) :: iostr character(len=80), save, dimension(7) :: msg cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy 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'/ c c continuation c itask=ip(7) ispd=ip(8) ntf=ip(1) nbf=ip(3) ndf=ip(4) eps=1.0e2_rknd*epsilon(1.0e0_rknd) c call filutl(msg(1),0_iknd) c istep=0 idsp=0 mxbis=10 mxfail=10 mxstep=10 c c restore solution c call uinit(ntf,ndf,ip,rp,itnode,ibndry,ibedge,vx,vy,sf, + u,um,uc,itdof,gdxy,sxy) 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==0.0e0_rknd.and.itask<=1) itask=7 if(dd/=0.0e0_rknd.and.itask>=5) itask=0 ip(7)=itask c c switch branches at bifurcation point c if(itask==2) then call timer(35_iknd) call swbrch(ndf,ntf,nbf,itnode,ibndry,itdof,vx,vy, + sf,evl,evr,udot,u,u0dot,rp,ibedge,ispd, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy,0_iknd) call timer(31_iknd) call updpth(0_iknd,6_iknd,rp) do i=1,ndf u0dot(i)=udot(i) enddo rp(33)=rp(23) rp(34)=rp(24) ip(7)=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_iknd) return endif c c switch functional and/or parameters c if(itask>=3) then call ctheta(ip,rp,iflag) if(iflag/=0) then ip(25)=7 return endif call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,0_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0_iknd) if(ip(25)/=0) then ip(7)=itask rp(1)=rp(21) rp(2)=rp(22) return else if(itask<=4) then call updpth(1_iknd,1_iknd,rp) ip(7)=0 else call updpth(-1_iknd,3_iknd,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>mxstep) then ip(25)=7 ip(7)=itask rp(1)=rp(21) rp(2)=rp(22) return endif c c step picker c call timer(35_iknd) call predct(ip,ntf,ndf,itnode,ibndry,vx,vy,sf, + u0,u0dot,rp,ibedge,idsp,mxfail,itdof, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) call timer(32_iknd) if(idsp>mxfail) then ip(25)=7 ip(7)=itask rp(1)=rp(21) rp(2)=rp(22) return endif c c solve nonlinear equations c call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,0_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0_iknd) if(ip(25)/=0) then ip(7)=itask rp(1)=rp(21) rp(2)=rp(22) return endif sval=rp(25) sval0=rp(35) if(istep==1) then call updpth(-1_iknd,4_iknd,rp) else call updpth(0_iknd,4_iknd,rp) endif if(sval0*sval>=0.0e0_rknd.or.itask==0) go to 40 c c change in sign in determinent c call filutl(msg(2),0_iknd) c c information for testing type of singular point c rqmx=max(abs(sval),abs(sval0)) rlsign=rp(23)*rp(33) idsp=0 isw=0 call hist3(15_iknd,-2_iknd,sval,sval0) c do istep=1,mxbis c c bisection/secant step c call bisect(rp,isw,rqup,rqlow) call hist3(15_iknd,istep,rqup,rqlow) if(isw==-1) go to 30 sigma=rp(71) 20 call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,1_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) write(unit=iostr,fmt='(2i3,5(1x,e12.5))') + ip(25),ip(80),(rp(k),k=21,25) call filutl(iostr,0_iknd) if(ip(25)/=0) then if(abs(sigma)==abs(rp(71))) then rp(71)=sigma*(1.0e0_rknd-eps) go to 20 else if(abs(sigma)0.0e0_rknd) dnorm=1.0e0_rknd/dnorm udr=rl2ip(ndf,evr,udot)*dnorm if(abs(udr)>1.0e-1_rknd.and.rlsign<0.0e0_rknd) then call filutl(msg(3),0_iknd) call updpth(0_iknd,2_iknd,rp) else if(abs(rp(25))>rqmx*1.0e-2_rknd) then call filutl(msg(4),0_iknd) call updpth(0_iknd,4_iknd,rp) else call filutl(msg(5),0_iknd) call updpth(0_iknd,6_iknd,rp) call timer(35_iknd) call swbrch(ndf,ntf,nbf,itnode,ibndry,itdof,vx,vy, + sf,evl,evr,udot,u,u0dot,rp,ibedge,ispd, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy,1_iknd) call timer(31_iknd) 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_iknd) 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/=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pltmgo(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 ibedge,isize,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo integer(kind=iknd), save :: isw=1 real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl real(kind=rknd), dimension(2,*) :: sf character(len=80) :: iostr cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c solve equations c rp(21)=rp(1) rp(22)=rp(2) iprob=ip(6) if(iprob==2) then rp(63)=rp(3) else if(ip(7)/=9) ip(7)=0 endif call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,0_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) if(iprob==2.and.ip(25)==0) then if(isw==1) then call updip(1_iknd,1_iknd,rp,ip) isw=0 else call updip(-1_iknd,2_iknd,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_iknd) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pltmgi(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 ibedge,isize,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo integer(kind=iknd), save :: isw=1 real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl real(kind=rknd), dimension(2,*) :: sf character(len=80) :: iostr cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c solve equations c iprob=ip(6) itask=ip(7) if(iprob==4.or.iprob==6) then if(itask==8) then rp(21)=rp(1) cc rp(21)=(rp(4)+rp(5))/2.0e0_rknd ip(7)=0 endif rmu=rp(3) rllwr=rp(4) rlupr=rp(5) eps=1.0e2_rknd*epsilon(1.0e0_rknd) tol=max(1.0e-2_rknd*rmu,eps) rl=rp(21) c if(rlupr/=0.0e0_rknd) then rup=abs(rlupr)*tol else rup=tol endif if(rllwr/=0.0e0_rknd) then rlw=abs(rllwr)*tol else rlw=tol endif if(rllwr+rlw<=rlupr-rup) then rl=max(rl,rllwr+rlw) rl=min(rl,rlupr-rup) else rr=tol*(rlupr-rllwr) rl=max(rl,rllwr+rr) rl=min(rl,rlupr-rr) endif c rp(21)=rl endif rp(63)=rp(3) call nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo, 1 isize,ibedge,0_iknd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy, 2 p2xy,sxy) c if(ip(25)==0) then if(isw==1) then call updip(1_iknd,1_iknd,rp,ip) isw=0 else if(iprob==4.and.itask==8) then call updip(-1_iknd,3_iknd,rp,ip) else call updip(-1_iknd,2_iknd,rp,ip) endif endif if(iprob==4.or.iprob==6) 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_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine nwtt(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,u0dot, + evr,evl,um,uc,vx0,vy0,udl,itdof,ja,jp,ibs,ibp,ibo,isize, 1 ibedge,itype,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo integer(kind=iknd), allocatable, dimension(:) :: jua, + jug,juac,jugc,jbo integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(100) :: rp,rpsv real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot, + u0dot,evr,evl,um,uc,vx0,vy0,udl real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), allocatable, dimension(:) :: a,h,g,su,sm, + b,d,rd,p,dl,bdlwr,bdupr,du,dum,duc,usv,umsv,ucsv,ua, 1 ug,uac,ugc cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c approximate newton method c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) itask=ip(7) iprob=ip(6) ising=ip(12) mpisw=ip(48) nproc=ip(49) nb=ip(91) eps=1.0e2_rknd*epsilon(1.0e0_rknd) c rp(52)=1.0e0_rknd rp(56)=1.0e0_rknd rp(57)=1.0e0_rknd if(itype==0) then epsmg=max(1.0e-3_rknd,eps) else epsmg=max(1.0e-4_rknd,eps) endif epsmg0=epsmg mxdamp=20 iconv=0 jflag=0 c ispd=ip(8) jspd=1 if(ispd/=1) jspd=-1 method=ip(9) mxcg=ip(10) mxnwtt=ip(11) jnwtt=mxnwtt if(iprob==3) jnwtt=mxnwtt+1 dtol=rp(6) hbtol=rp(7) c c save rp c do i=1,100 rpsv(i)=rp(i) enddo c allocate(a(isize(3)),h(isize(4)),g(isize(5)), + su(isize(6)),sm(isize(6)),b(isize(31)), 1 p(isize(35)),d(isize(36)),rd(isize(37)), 2 dl(isize(38)),bdlwr(isize(34)),bdupr(isize(34)), 3 du(isize(31)),dum(isize(32)),duc(isize(33)), 4 usv(isize(31)),umsv(isize(32)),ucsv(isize(33)), 5 jua(isize(11)),ua(isize(12)), 6 jug(isize(13)),ug(isize(14)), 7 juac(isize(22)),uac(isize(23)),ugc(isize(24)), 8 jugc(isize(24)),jbo(isize(21))) c call uinit(ntf,ndf,ip,rp,itnode,ibndry,ibedge, + vx,vy,sf,u,um,uc,itdof,gdxy,sxy) if(iprob==3) call evinit(ndf,ip,evl,evr,itdof, + ibndry,ibedge) if(iprob==2) call bdinit(ntf,ndf,ip,rp,u,vx,vy,sf, + itdof,itnode,ibndry,ibedge,bdlwr,bdupr,gdxy,sxy) if(iprob==5) call bdinit(ntf,ndf,ip,rp,uc,vx,vy,sf, + itdof,itnode,ibndry,ibedge,bdlwr,bdupr,gdxy,sxy) c if(iprob==3.and.itask<=1) then seqdot=rp(74) sigma=rp(71) rl0dot=rp(33) if(seqdot/=0.0e0_rknd) 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(35_iknd) call linsys(ntf,ndf,ip,rp,vx,vy,sf,itnode,ibndry,ibedge, + u,u0,udot,um,uc,vx0,vy0,itdof,ja,ibs, 1 ibp,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,a1xy,a2xy, 2 fxy,gnxy,gdxy,p1xy,p2xy,sxy) call timer(28_iknd) c ievals=1 c c compute ordering symbolic factorization c maxjua=isize(11) maxua=isize(12) maxjuac=isize(22) maxuac=isize(23) if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,a,ibs,maxjua,jua, + maxua,ua,ispd,dtol,1_iknd) call timer(22_iknd) ip(97)=maxjua ip(98)=maxua endif if(method>=0) then call timer(35_iknd) call sfhb(nb,ja,jp,ibs,ibo,a, + maxjuac,juac,maxuac,uac,ispd,hbtol,1_iknd) call timer(23_iknd) ip(100)=juac(nb+1)-1 endif c if(iprob==5) then maxjug=isize(13) maxug=isize(14) if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,g,ibs,maxjug,jug, + maxug,ug,1_iknd,dtol,1_iknd) call timer(22_iknd) endif maxjugc=isize(24) maxugc=isize(24) if(method>=0) then do i=1,nb jbo(i)=abs(ibo(i)) enddo call timer(35_iknd) call sfhb(nb,ja,jp,ibs,jbo,g, + maxjugc,jugc,maxugc,ugc,1_iknd,hbtol,1_iknd) call timer(23_iknd) endif endif c c the main loop c call hist3(11_iknd,0_iknd,1.0e0_rknd,1.0e0_rknd) do itnum=1,jnwtt c c compute approximate factorization c if(itnum>1) then if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,a,ibs,maxjua,jua, + maxua,ua,ispd,dtol,0_iknd) call timer(22_iknd) endif if(method>=0) then call timer(35_iknd) call sfhb(nb,ja,jp,ibs,ibo,a, + maxjua,juac,maxuac,uac,ispd,hbtol,0_iknd) call timer(23_iknd) endif if(itype==0) then epsmg=max(epsmg0,rp(57)) epsmg=min(1.0e-2_rknd,rp(57)) endif endif c c compute singular vectors c if(iprob==3) then call timer(35_iknd) call cev(ndf,ip,rp,ja,ibp,ibs,ibo,a,jua,ua, + juac,jp,uac,evl,evr) call timer(30_iknd) endif c c multi-level solution of newton equations c call timer(35_iknd) if(iprob==3) then call blk3(ndf,ip,rp,vx,vy,itdof,itnode,du,dum, + ja,ibs,ibp,ibo,a,jua,ua,juac,jp,uac, 1 b,rd,p,udot,u0dot,epsmg,jflag,0_iknd) call timer(25_iknd) if(iconv==1) go to 170 if(itnum>mxnwtt) go to 100 else if(iprob==4.or.iprob==6) then call blk4(ndf,ip,rp,du,dum,ja,ibs,ibp,ibo,a, + jua,ua,juac,jp,uac,h,b,p,dl,rd, 1 udot,epsmg,jflag,0_iknd) call timer(19_iknd) else if(iprob==5) then if(itnum>1) then if(abs(method)==1) then call timer(35_iknd) call sfbilu(ndf,nb,ja,g,ibs,maxjug, + jug,maxug,ug,1_iknd,dtol,0_iknd) call timer(22_iknd) endif if(method>=0) then call timer(35_iknd) call sfhb(nb,ja,jp,ibs,jbo,g, + maxjugc,jugc,maxugc,ugc,1_iknd,hbtol,0_iknd) call timer(23_iknd) endif endif call blk5(ndf,ip,epsmg,ja,ibs,ibp,ibo,a,h,g, + su,sm,jua,ua,juac,jp,uac,jug,ug, 1 jbo,jugc,ugc,du,dum,duc,p,b,dl,reler5,jflag) call timer(27_iknd) else call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 du,b,reler1,jflag,7_iknd) if(iprob==1.and.itask==9) then call mg(ndf,nb,jspd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 dum,p,reler2,jflag,8_iknd) endif call timer(24_iknd) endif c c line search loop c isw=0 call timer(35_iknd) call tpick(ndf,ip,rp,vx,vy,itnode,ibndry,sf,itdof,u, + um,uc,usv,umsv,ucsv,ja,ibs,ibp,a,h,g, 1 su,sm,b,d,p,dl,bdlwr,bdupr,du,dum,duc,isw,itnum,sxy) call timer(33_iknd) dnew=rp(58) cc write(6,*) itnum,dnew,rp(52) if(dnew>0.0e0_rknd) then call hist3(11_iknd,itnum,rp(56),rp(54)) iconv=icvtst(itnum,iprob,itask,itype,rp) if(iconv==1) go to 170 ip(25)=2 if(jflag/=0) ip(25)=11 go to 130 endif iter=0 70 iter=iter+1 c call timer(35_iknd) call linsys(ntf,ndf,ip,rp,vx,vy,sf,itnode,ibndry,ibedge, + u,u0,udot,um,uc,vx0,vy0,itdof,ja,ibs, 1 ibp,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,a1xy,a2xy, 2 fxy,gnxy,gdxy,p1xy,p2xy,sxy) ievals=ievals+1 call timer(28_iknd) call tpick(ndf,ip,rp,vx,vy,itnode,ibndry,sf,itdof,u, + um,uc,usv,umsv,ucsv,ja,ibs,ibp,a,h,g, 1 su,sm,b,d,p,dl,bdlwr,bdupr,du,dum,duc,isw,itnum,sxy) call timer(33_iknd) c c test for sufficient decrease c if(isw>=0) then if(iter1) then call timer(35_iknd) call cdlfn(ndf,ip,itnode,itdof,udl,ja,ibs,ibp,ibo, + a,jua,ua,juac,jp,uac) call timer(9_iknd) endif c 190 if(iprob==6) then call timer(35_iknd) call csf(ip,rp,vx,vy,ibndry,sf,sxy) call mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,vx,vy,sf,sxy) call linsys(ntf,ndf,ip,rp,vx,vy,sf,itnode,ibndry,ibedge, + u,u0,udot,um,uc,vx0,vy0,itdof,ja,ibs, 1 ibp,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,a1xy,a2xy, 2 fxy,gnxy,gdxy,p1xy,p2xy,sxy) ievals=ievals+1 call timer(28_iknd) endif c do i=1,ndf c u(i)=b(i) c um(i)=p(i) c uc(i)=dl(i) c enddo deallocate(a,h,g,su,sm,b,p,d,rd,dl,bdlwr,bdupr,juac,uac,du, + dum,duc,usv,umsv,ucsv,jua,ua,jug,ug,ugc,jugc,jbo) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function icvtst(itnum,iprob,itask,itype,rp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd) :: icvtst integer(kind=iknd), save :: isw real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: tola,tolb,eps,erf,egf,tole,tolr,trf cy 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(abs(iprob)/=3.or.itask>=5) ii=1 if(iprob<0) ii=1 if(itype<0) ii=2 c if(itnum<=1) then isw=0 eps=1.0e2_rknd*epsilon(1.0e0_rknd) tola=eps if(itype==1) tola=sqrt(tola) tolb=tola trf=0.5e0_rknd erf=1.0e0_rknd-eps egf=0.1e0_rknd if(ii==1) then tole=1.0e-1_rknd tolr=1.0e-2_rknd else if(ii==2) then tole=1.0e-2_rknd tolr=1.0e-4_rknd else tole=1.0e-2_rknd tolr=1.0e-4_rknd endif endif c reler0=rp(53) relerr=rp(54) relres=rp(56) ratio=rp(57) c c revise tol if indicated c if(isw==0.and.ii>=1.and.relerr=egf) icvtst=1 if(relerr=5) ii=1 if(iprob<0) ii=1 if(itype<0) ii=2 c if(itnum<=1) then isw=0 eps=1.0e2_rknd*epsilon(1.0e0_rknd) tola=eps if(itype==1) tola=sqrt(tola) tolb=tola trf=0.5e0_rknd erf=1.0e0_rknd-eps egf=0.1e0_rknd if(ii==1) then tole=1.0e-4_rknd tolr=1.0e-6_rknd else if(ii==2) then tole=1.0e-2_rknd tolr=1.0e-4_rknd else tole=1.0e-2_rknd tolr=1.0e-4_rknd endif endif c reler0=rp(53) relerr=rp(54) relres=rp(56) ratio=rp(57) c c revise tol if indicated c if(isw==0.and.ii>=1.and.relerr=egf) jcvtst=1 if(relerr2) 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 hbslv(ndf,nb,ja,jp,ibs,ibp,ibo,ju,juc, + a,u,uc,devr,br,ispd,method) call csv(ndf,nb,ja,ibs,ibp,a,evr,devr,evr0,ispd) c if(ispd/=1) then ee=tol1*blnorm do i=1,ndf bl(i)=bl(i)+ee ee=-ee enddo c call hbslv(ndf,nb,ja,jp,ibs,ibp,ibo,ju,juc, + a,u,uc,devl,bl,jspd,method) call csv(ndf,nb,ja,ibs,ibp,a,evl,devl,evl0,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<0.0e0_rknd) then sval=-sval do i=1,ndf evl(i)=-evl(i) enddo endif rp(25)=sval return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine csv(n,nb,ja,ibs,ibp,a,ev,dev,ev0,ispd) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(*) :: a,ev,dev,ev0 real(kind=rknd), dimension(n) :: aev,adev,aev0 real(kind=rknd), dimension(3,3) :: aa,q real(kind=rknd), dimension(3) :: r cy c orthogonalize c call orthog(n,ev,dev,ev0,irank) c call mtxmlt(n,nb,ja,ibs,ibp,a,ev,aev,ispd) call mtxmlt(n,nb,ja,ibs,ibp,a,dev,adev,ispd) call mtxmlt(n,nb,ja,ibs,ibp,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>0.0e0_rknd) evnorm=1.0e0_rknd/evnorm ev0nrm=rl2nrm(n,ev0) if(ev0nrm>0.0e0_rknd) ev0nrm=1.0e0_rknd/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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine c3x3(a,b,num) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(3,3) :: a,b cy 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=max(abs(a(j,1)),abs(a(j,2)),abs(a(j,3))) if(rmax/=0.0e0_rknd) rmax=1.0e0_rknd/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))abs(d2)) then dd=1.0e0_rknd/sqrt(d1**2+d12) c=-a12*dd s=d1*dd else dd=1.0e0_rknd/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_rknd d12=a12**2 d13=a13**2 d23=a23**2 p=-(a11+a22+a33)/3.0e0_rknd qq=a11*a22+a22*a33+a33*a11-d12-d13-d23 s=a11*d23+a22*d13+a33*d12 + -a11*a22*a33-2.0e0_rknd*a12*a23*a13 c c solve cubic equation (all roots should be real and non-neg.) c aa=qq/3.0e0_rknd-p**2 bb=p**3-(p*qq-s)/2.0e0_rknd if(bb**2+aa**3>=0.0e0_rknd) then c c case of two equal roots (assume b*b+a*a*a=0) c sgn=2.0e0_rknd if(bb>0.0e0_rknd) sgn=-2.0e0_rknd bb=sgn*(abs(bb)**(1.0e0_rknd/3.0e0_rknd)) r(1)=bb-p r(2)=-bb/2.0e0_rknd-p r(3)=r(2) else c c three distinct roots c d=sqrt(-aa)*2.0e0_rknd theta=2.0e0_rknd*bb/(aa*d) theta=min(1.0e0_rknd,theta) theta=max(-1.0e0_rknd,theta) theta=acos(theta)/3.0e0_rknd pi=3.141592653589793e0_rknd/3.0e0_rknd r(1)=d*cos(theta)-p r(2)=d*cos(theta+2.0e0_rknd*pi)-p r(3)=d*cos(theta+4.0e0_rknd*pi)-p endif c c order c ic1=1 if(r(2)max(s2,s3)) then qq=1.0e0_rknd/sqrt(s1) v1=qq*a1 v2=qq*a12 v3=qq*a13 else if(s2>s3) then qq=1.0e0_rknd/sqrt(s2) v1=qq*a12 v2=qq*a2 v3=qq*a23 else qq=1.0e0_rknd/sqrt(s3) v1=qq*a13 v2=qq*a23 v3=qq*a3 endif if(v1==0.0e0_rknd) then w1=1.0e0_rknd w2=0.0e0_rknd w3=0.0e0_rknd else if(v2==0.0e0_rknd) then w1=0.0e0_rknd w2=1.0e0_rknd w3=0.0e0_rknd else qq=1.0e0_rknd/sqrt(v1**2+v2**2) w1=-v2*qq w2=v1*qq w3=0.0e0_rknd endif z1=v2*w3-v3*w2 z2=v3*w1-v1*w3 z3=v1*w2-v2*w1 if(r(2)-r(1)<=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)>(r(3)-r(2))*1.0e-2_rknd) 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>max(ww,zz)) then qq=1.0e0_rknd/sqrt(vv) q(1,i)=qq*v1 q(2,i)=qq*v2 q(3,i)=qq*v3 else if(ww>zz) then qq=1.0e0_rknd/sqrt(ww) q(1,i)=qq*w1 q(2,i)=qq*w2 q(3,i)=qq*w3 else qq=1.0e0_rknd/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)<0.0e0_rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine orthog(n,v1,v2,v3,irank) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: v1,v2,v3 real(kind=rknd), dimension(3) :: r cy c orthogonalize, normalize, determine rank c tol=1.0e-1_rknd a11=0.0e0_rknd a22=0.0e0_rknd a33=0.0e0_rknd do i=1,n a11=a11+v1(i)**2 a22=a22+v2(i)**2 a33=a33+v3(i)**2 enddo if(a11>0.0e0_rknd) a11=1.0e0_rknd/sqrt(a11) if(a22>0.0e0_rknd) a22=1.0e0_rknd/sqrt(a22) if(a33>0.0e0_rknd) a33=1.0e0_rknd/sqrt(a33) d12=0.0e0_rknd d13=0.0e0_rknd 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_rknd a33=0.0e0_rknd 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>0.0e0_rknd) a22=1.0e0_rknd/sqrt(a22) if(a33>0.0e0_rknd) a33=1.0e0_rknd/sqrt(a33) d23=0.0e0_rknd do i=1,n v2(i)=v2(i)*a22 v3(i)=v3(i)*a33 d23=d23+v2(i)*v3(i) enddo a33=0.0e0_rknd do i=1,n v3(i)=v3(i)-d23*v2(i) a33=a33+v3(i)**2 enddo if(a33>0.0e0_rknd) a33=1.0e0_rknd/sqrt(a33) a12=0.0e0_rknd a13=0.0e0_rknd a23=0.0e0_rknd 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>0.0e0_rknd) a11=1.0e0_rknd if(a22>0.0e0_rknd) a22=1.0e0_rknd if(a33>0.0e0_rknd) a33=1.0e0_rknd d12=a12**2 d13=a13**2 d23=a23**2 p=-(a11+a22+a33)/3.0e0_rknd qq=a11*a22+a22*a33+a33*a11-d12-d13-d23 s=a11*d23+a22*d13+a33*d12 + -a11*a22*a33-2.0e0_rknd*a12*a23*a13 c c solve cubic equation (all roots should be real and non-neg.) c aa=qq/3.0e0_rknd-p**2 bb=p**3-(p*qq-s)/2.0e0_rknd if(bb**2+aa**3>=0.0e0_rknd) then c c case of two equal roots (assume b*b+a*a*a=0) c sgn=2.0e0_rknd if(bb>0.0e0_rknd) sgn=-2.0e0_rknd bb=sgn*(abs(bb)**(1.0e0_rknd/3.0e0_rknd)) r(1)=bb-p r(2)=-bb/2.0e0_rknd-p r(3)=r(2) else c c three distinct roots c d=sqrt(-aa)*2.0e0_rknd theta=2.0e0_rknd*bb/(aa*d) theta=min(1.0e0_rknd,theta) theta=max(-1.0e0_rknd,theta) theta=acos(theta)/3.0e0_rknd pi=3.141592653589793e0_rknd/3.0e0_rknd r(1)=d*cos(theta)-p r(2)=d*cos(theta+2.0e0_rknd*pi)-p r(3)=d*cos(theta+4.0e0_rknd*pi)-p endif c c order c ic1=1 if(r(2)tol) irank=2 if(r(ic1)>tol) irank=3 c if(irank==1) then do i=1,n v2(i)=0.0e0_rknd v3(i)=0.0e0_rknd enddo else if(irank==2.and.a33>0.0e0_rknd) then if(a22<=0.0e0_rknd) then do i=1,n v2(i)=v3(i) enddo else if(abs(a13)=0) cycle k=-itedge(j,i) if(ibndry(3,k)==0) cycle iv1=itnode(index(2,j),i) iv2=itnode(index(3,j),i) ivj=itnode(j,i) if(ibndry(3,k)>0) then call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + sf(1,k),sf(2,k),theta1,theta2,rad,alen) call bari(sf(1,k),sf(2,k),vx,vy,itnode(1,i),c) theta=abs(theta2-theta1)*pi aa=(rad**2/2.0e0_rknd)*(theta-sin(theta)) if(c(j)<0.0e0_rknd) aa=-aa det=det+aa else itag=-ibndry(3,k) theta1=sf(1,k) theta2=sf(2,k) x(1)=vx(iv1)-vx(ivj) y(1)=vy(iv1)-vy(ivj) x(9)=vx(iv2)-vx(ivj) y(9)=vy(iv2)-vy(ivj) dt=(theta2-theta1)/8.0e0_rknd do m=1,7 do mm=1,12 values(mm)=0.0e0_rknd enddo theta=theta1+real(m,rknd)*dt call sxy(rl,theta,itag,values) x(m+1)=values(1)-vx(ivj) y(m+1)=values(2)-vy(ivj) enddo dd=0.0e0 do m=1,8 dd=dd+abs(x(m)*y(m+1)-x(m+1)*y(m)) enddo det=det+(dd/2.0e0_rknd-det0) endif enddo area=area+det enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bari(x,y,vx,vy,iv,c) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3) :: iv real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: c cy 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_rknd-c(2)-c(3) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function rl2nrm(n,b) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: b real(kind=rknd) :: rl2nrm cy c compute norm of b and update history c bnorm=0.0e0_rknd bmax=0.0e0_rknd do i=1,n if(abs(b(i))=0.0e0_rknd) then if(t=0.0e0_rknd) then if(t0) then t(i)=s/real(num,rknd) else t(i)=e(i,2) endif enddo do i=1,ntf e(i,2)=e(i,2)*theta+t(i)*(1.0e0_rknd-theta) enddo enddo c enorm1=0.0e0_rknd enorm2=0.0e0_rknd unorm1=0.0e0_rknd unorm2=0.0e0_rknd enrm1p=0.0e0_rknd enrm2p=0.0e0_rknd unrm1p=0.0e0_rknd unrm2p=0.0e0_rknd do i=1,ntf call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,erh1,erl2) call elenrm(i,itnode,vx,vy,nef,maxd,u,itdof,uh1,ul2) e(i,1)=erh1 c enorm1=enorm1+erh1 enorm2=enorm2+erl2 unorm1=unorm1+uh1 unorm2=unorm2+ul2 c if(itnode(4,i)/=irgn) cycle enrm1p=enrm1p+erh1 enrm2p=enrm2p+erl2 unrm1p=unrm1p+uh1 unrm2p=unrm2p+ul2 enddo c c sum=0.0e0_rknd smax=e(1,2) smin=e(1,2) ave=0.0e0_rknd rp(86)=1.0e0_rknd if(mpisw==1) then nn=0 do i=1,ntf if(itnode(4,i)/=irgn) cycle nn=nn+1 sum=sum+e(i,2)**2 ave=ave+e(i,2) smax=max(smax,e(i,2)) smin=min(smin,e(i,2)) enddo rp(82)=ave/real(nn,rknd) rp(83)=sum/real(nn,rknd)-rp(82)**2 rp(84)=smin rp(85)=smax if(unrm1p>0.0e0_rknd) rp(86)=sqrt(enrm1p/unrm1p) rp(87)=enrm1p/real(nn,rknd) else do i=1,ntf sum=sum+e(i,2)**2 ave=ave+e(i,2) smax=max(smax,e(i,2)) smin=min(smin,e(i,2)) enddo rp(82)=ave/real(ntf,rknd) rp(83)=sum/real(ntf,rknd)-rp(82)**2 rp(84)=smin rp(85)=smax if(unorm1>0.0e0_rknd) rp(86)=sqrt(enorm1/unorm1) rp(87)=enorm1/real(ntf,rknd) endif c c compute norms c ii=0 if(mpisw==1.and.iadapt==0) ii=1 if(iadapt==7) ii=1 if(ii==1) then c do i=1,ndf mark(i)=0 enddo do i=1,ntf if(itnode(4,i)/=irgn) cycle call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof mark(idof(j))=1 enddo enddo ndg=0 do i=1,ndf if(mark(i)==1) ndg=ndg+1 enddo t(1)=unrm2p t(2)=unrm1p t(3)=enrm2p t(4)=enrm1p t(5)=real(ndg,rknd) c call pl2ip(t,5_iknd) 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_rknd if(unorm1/=0.0e0_rknd) relerr=enorm1/unorm1 if(unorm1+enorm1<=0.0e0_rknd) relerr=0.0e0_rknd rp(53)=relerr c call hist2(rp,-2_iknd,ndg) else enorm1=sqrt(enorm1) rp(37)=enorm1 unorm1=sqrt(unorm1) rp(38)=unorm1 rp(39)=sqrt(enorm2) rp(40)=sqrt(unorm2) relerr=1.0e0_rknd if(unorm1/=0.0e0_rknd) relerr=enorm1/unorm1 if(unorm1+enorm1<=0.0e0_rknd) relerr=0.0e0_rknd rp(53)=relerr endif c ii=abs(iadapt) if(ii==1.and.ndtrgt1) then ii=ii+1 deg(idof(ii))=2 ibo(idof(ii))=abs(iords(j)) endif enddo if(iord>2) then deg(idof(7))=6 ibo(idof(7))=iord endif enddo c jp(1)=nb+2 do i=1,nb jp(i+1)=jp(i)+deg(i) enddo c c compute mapping array c do itri=1,ntf call l2bmap(itri,idof,ndof,iord,iords,map,itdof) ii=3 do j=1,3 if(abs(iords(j))>1) then ii=ii+1 m=idof(ii) if(iords(j)>0) then jp(jp(m))=idof(index(2,j)) jp(jp(m)+1)=idof(index(3,j)) else jp(jp(m))=idof(index(3,j)) jp(jp(m)+1)=idof(index(2,j)) endif endif enddo if(iord>2) then m=idof(7) do j=1,6 jp(jp(m)+j-1)=idof(j) enddo endif enddo c call cdbcb(nb,nbf,itdof,ibndry,ibedge,deg,map) do i=1,nb if(deg(i)==1) ibo(i)=-ibo(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sfhb(nb,ja,jp,ibs,ibo,a,maxju,ju,maxu,u,ispd, + dtol,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ibs,ibo,ju,jp integer(kind=iknd), allocatable, dimension(:) :: jap real(kind=rknd), dimension(*) :: a,u real(kind=rknd), allocatable, dimension(:) :: ac cy c lenja=ja(nb+1) lena=lenja if(ispd/=1) lena=2*lenja-nb allocate(jap(lenja),ac(lena)) call cjap(nb,ispd,ja,jap,ibs) c if(ispd==1) then call a2ac1(nb,ibs,ibo,jp,ja,jap,a,ac) else call a2ac0(nb,ibs,ibo,jp,ja,jap,a,ac) endif c call sfilu(nb,ja,ac,maxju,ju,maxu,u,ispd,dtol,itype) c deallocate(jap,ac) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine a2ac1(nb,ibs,ibo,jp,ja,jap,a,ac) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7) :: is,js,idx,jdx integer(kind=iknd), dimension(*) :: ja,jap,jp,ibs,ibo real(kind=rknd), dimension(*) :: a,ac integer(kind=iknd) :: amtx,amtx0 real(kind=rknd), dimension(36,36) :: r cy c coarse to fine mapping c amtx=0 amtx0=0 do i=1,ja(nb+1)-1+amtx0 ac(i)=0.0e0_rknd enddo do i=1,nb ni=ibs(i) call setidx(i,numi,idx,is,ibo,jp) c c diagonal block c k=jap(i)+ni do ii=1,ni r(ii,ii)=a(jap(i)+ii-1) do jj=ii+1,ni r(ii,jj)=a(k) r(jj,ii)=a(k) k=k+1 enddo enddo call f2cblk(r,ni,numi,is,ni,numi,is) do k=1,numi ii=idx(k) ac(ii)=ac(ii)+r(k,k) do m=k+1,numi jj=idx(m) call jamap0(ii,jj,ij,ji,ja,amtx0) ac(ij)=ac(ij)+r(k,m) enddo enddo c c off diagonal blocks c do mm=ja(i),ja(i+1)-1 j=ja(mm) nj=ibs(j) call setidx(j,numj,jdx,js,ibo,jp) c km=jap(mm) do m=1,nj do k=1,ni r(k,m)=a(km) km=km+1 enddo enddo call f2cblk(r,ni,numi,is,nj,numj,js) c do k=1,numi ii=idx(k) do m=1,numj jj=jdx(m) if(ii==jj) then ac(ii)=ac(ii)+r(k,m)*2.0e0_rknd else call jamap0(ii,jj,ij,ji,ja,amtx0) ac(ij)=ac(ij)+r(k,m) endif enddo enddo enddo enddo c c set matrix dirichlet boundary conditions c do i=1,nb if(ibo(i)<0) then do jj=ja(i),ja(i+1)-1 ac(jj)=0.0e0_rknd enddo else do jj=ja(i),ja(i+1)-1 if(ibo(ja(jj))<0) ac(jj)=0.0e0_rknd enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine a2ac0(nb,ibs,ibo,jp,ja,jap,a,ac) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7) :: is,js,idx,jdx integer(kind=iknd), dimension(*) :: ja,jap,jp,ibs,ibo real(kind=rknd), dimension(*) :: a,ac integer(kind=iknd) :: amtx,amtx0 real(kind=rknd), dimension(36,36) :: r,s cy c coarse to fine mapping c amtx=jap(ja(nb+1))-jap(ja(1)) amtx0=ja(nb+1)-ja(1) do i=1,ja(nb+1)-1+amtx0 ac(i)=0.0e0_rknd enddo do i=1,nb ni=ibs(i) call setidx(i,numi,idx,is,ibo,jp) c c diagonal block c k=jap(i)+ni lshift=((ni-1)*ni)/2 do ii=1,ni r(ii,ii)=a(jap(i)+ii-1) do jj=ii+1,ni r(ii,jj)=a(k) r(jj,ii)=a(k+lshift) k=k+1 enddo enddo call f2cblk(r,ni,numi,is,ni,numi,is) do k=1,numi ii=idx(k) ac(ii)=ac(ii)+r(k,k) do m=k+1,numi jj=idx(m) call jamap0(ii,jj,ij,ji,ja,amtx0) ac(ij)=ac(ij)+r(k,m) ac(ji)=ac(ji)+r(m,k) enddo enddo c c off diagonal blocks c do mm=ja(i),ja(i+1)-1 j=ja(mm) nj=ibs(j) call setidx(j,numj,jdx,js,ibo,jp) c km=jap(mm) do m=1,nj do k=1,ni r(k,m)=a(km) s(k,m)=a(km+amtx) km=km+1 enddo enddo call f2cblk(r,ni,numi,is,nj,numj,js) call f2cblk(s,ni,numi,is,nj,numj,js) c do k=1,numi ii=idx(k) do m=1,numj jj=jdx(m) if(ii==jj) then ac(ii)=ac(ii)+r(k,m)+s(k,m) else call jamap0(ii,jj,ij,ji,ja,amtx0) ac(ij)=ac(ij)+r(k,m) ac(ji)=ac(ji)+s(k,m) endif enddo enddo enddo enddo c c set matrix dirichlet boundary conditions c do i=1,nb if(ibo(i)<0) then do jj=ja(i),ja(i+1)-1 ac(jj)=0.0e0_rknd ac(jj+amtx0)=0.0e0_rknd enddo else do jj=ja(i),ja(i+1)-1 if(ibo(ja(jj))>0) cycle ac(jj)=0.0e0_rknd ac(jj+amtx0)=0.0e0_rknd enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sfilu(n,ja,a,maxju,ju,maxu,u,ispd,dtol,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ju integer(kind=iknd), dimension(n) :: list,mark,indx integer(kind=iknd), dimension(2,n) :: ivf integer(kind=iknd) :: amtx,umtx real(kind=rknd), dimension(*) :: a,u cy c c sparse numeric factorization c if(itype==1) then c if(ispd/=1) then amtx=ja(n+1)-ja(1) umtx=(maxu-ja(1)+1)/2 maxu=maxu-umtx else amtx=0 umtx=0 endif c if(dtol>0.0e0_rknd) then rtol=max(epsilon(1.0e0_rknd),dtol)/real(n,rknd) else rtol=0.0e0_rknd endif c ju(1)=n+2 else if(ispd/=1) then amtx=ja(n+1)-ja(1) umtx=ju(n+1)-ju(1) else amtx=0 umtx=0 endif endif c do i=1,n mark(i)=0 list(i)=0 indx(i)=0 enddo c c do i=1,n c c first determine the ju array c if(itype==1) then next=ju(i) atol=rtol*abs(a(i)) do jj=ja(i),ja(i+1)-1 j=ja(jj) xx=max(abs(a(jj)),abs(a(jj+amtx))) if(xx<=atol) cycle mark(j)=1 ju(next)=j next=next+1 enddo c lk=list(i) 10 if(lk>0) then k=lk lk=list(k) j1=indx(k) j2=ju(k+1)-1 sl=u(j1)/u(k) su=u(j1+umtx)/u(k) isw=0 if(ivf(1,k)==i.or.ivf(2,k)==i) isw=1 do jj=j1+1,j2 j=ju(jj) if(mark(j)/=0) cycle xx=max(abs(su*u(jj)),abs(sl*u(jj+umtx))) if(xx<=atol.and.isw==0) cycle mark(j)=1 ju(next)=j next=next+1 enddo go to 10 endif c c cleanup c ju(i+1)=next len=ju(i+1)-ju(i) if(len>1) call ihp(ju(ju(i)),len) endif c c initialize row i and col i c do jj=ju(i),ju(i+1)-1 u(jj)=0.0e0_rknd u(jj+umtx)=0.0e0_rknd mark(ju(jj))=jj enddo u(i)=a(i) do jj=ja(i),ja(i+1)-1 j=ja(jj) if(mark(j)==0) cycle u(mark(j))=a(jj) u(mark(j)+umtx)=a(jj+amtx) enddo c c do outer product updates c lk=list(i) 20 if(lk>0) then k=lk lk=list(k) j1=indx(k) j2=ju(k+1)-1 sl=u(j1+umtx)/u(k) u(i)=u(i)-u(j1)*sl c if(ispd==1) then do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle u(mark(j))=u(mark(j))-sl*u(jj) enddo else su=u(j1)/u(k) do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle u(mark(j))=u(mark(j))-sl*u(jj) u(mark(j)+umtx)=u(mark(j)+umtx)-su*u(jj+umtx) enddo endif if(j1emax0) then emax1=emax0 kmax1=kmax0 emax0=ee kmax0=j else if(ee>emax1) then emax1=ee kmax1=j endif enddo ivf(1,i)=kmax0 ivf(2,i)=kmax1 c enddo c c shift u for non symmetric case c maxju=ju(n+1)-1 if(ispd/=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 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine fn2cr(nb,ibs,ibp,ibo,jp,b,bc) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7) :: is,idx integer(kind=iknd), dimension(*) :: jp,ibs,ibp,ibo real(kind=rknd), dimension(*) :: b,bc common /pltmg4/fc(2541),ishift(7) cy c fine to coarse mapping c do i=1,nb bc(i)=0.0e0_rknd enddo c do i=1,nb c c vertex case c if(ibo(i)<0) cycle call setidx(i,num,idx,is,ibo,jp) if(num==1) then bc(i)=bc(i)+b(ibp(i)) c c edge case c else do k=1,num s=0.0e0_rknd do j=1,ibs(i) s=s+b(ibp(i)+j-1)*fc(is(k)+j) enddo cc if(ibo(idx(k))>0) bc(idx(k))=bc(idx(k))+s bc(idx(k))=bc(idx(k))+s enddo endif enddo do i=1,nb if(ibo(i)<0) bc(i)=0.0e0_rknd enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cr2fn(n,nb,ibs,ibp,ibo,jp,x,xc) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7) :: is,idx integer(kind=iknd), dimension(*) :: jp,ibs,ibp,ibo real(kind=rknd), dimension(*) :: x,xc common /pltmg4/fc(2541),ishift(7) cy c coarse to fine mapping c do i=1,n x(i)=0.0e0_rknd enddo do i=1,nb c c vertex case c if(ibo(i)<0) cycle call setidx(i,num,idx,is,ibo,jp) if(num==1) then x(ibp(i))=xc(i) c c element and edge cases c else do j=1,ibs(i) s=0.0e0_rknd do k=1,num s=s+xc(idx(k))*fc(is(k)+j) enddo x(ibp(i)+j-1)=s enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setidx(i,num,idx,is,ibo,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7) :: is,idx integer(kind=iknd), dimension(*) :: ibo,jp common /pltmg1/ic(3,363),jc(12) common /pltmg4/fc(2541),ishift(7) cy iord=abs(ibo(i)) if(jp(i)==jp(i+1)) then num=1 idx(1)=i is(1)=0 else if(jp(i)+2==jp(i+1)) then num=3 ii=jp(i) idx(1)=jp(ii) idx(2)=jp(ii+1) idx(3)=i do k=1,3 is(k)=ishift(k+1)+jc(iord)+2 enddo else num=7 ii=jp(i) do k=1,6 idx(k)=jp(ii+k-1) enddo idx(7)=i do k=1,7 is(k)=ishift(k)+jc(iord)+3*iord-1 enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine f2cblk(r,ni,numi,is,nj,numj,js) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7) :: is,js real(kind=rknd), dimension(36,36) :: r,s common /pltmg4/fc(2541),ishift(7) cy c coarse to fine mapping c c multiply on i side c if(numi==1) then do jj=1,nj s(1,jj)=r(1,jj) enddo else do jj=1,nj do kk=1,numi q=0.0e0_rknd do ii=1,ni q=q+fc(is(kk)+ii)*r(ii,jj) enddo s(kk,jj)=q enddo enddo endif c c multiply on j side c if(numj==1) then do ii=1,numi r(ii,1)=s(ii,1) enddo else do ii=1,numi do kk=1,numj q=0.0e0_rknd do jj=1,nj q=q+s(ii,jj)*fc(js(kk)+jj) enddo r(ii,kk)=q enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine snsilu(n,ju,u,x,b,ispd) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ju integer(kind=iknd) :: lmtx,umtx real(kind=rknd), dimension(*) :: u,x,b cy 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==0) lmtx=ju(n+1)-ju(1) if(ispd==-1) umtx=ju(n+1)-ju(1) c do i=1,n x(i)=b(i) enddo c c lower triangular system c do i=1,n 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 enddo c c upper triangular system c do i=n,1,-1 s=0.0e0_rknd 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) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mtxml0(n,ja,a,x,b,ispd) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja integer(kind=iknd) :: umtx,lmtx real(kind=rknd), dimension(*) :: a,x,b cy 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==0) lmtx=ja(n+1)-ja(1) if(ispd==-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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sgs(n,ja,a,x,b,ispd) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja integer(kind=iknd) :: lmtx,umtx real(kind=rknd), dimension(*) :: a,x,b cy c ispd = 1 symmetric c = 0 non-symmetric c =-1 non-symmetric for a-transpose c lmtx=0 umtx=0 if(ispd==0) lmtx=ja(n+1)-ja(1) if(ispd==-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) do jj=ja(i),ja(i+1)-1 j=ja(jj) x(j)=x(j)-a(jj+lmtx)*s enddo enddo c c the upper triangular system c do i=n,1,-1 s=0.0e0_rknd do jj=ja(i),ja(i+1)-1 j=ja(jj) s=s+a(jj+umtx)*x(j) enddo x(i)=(x(i)-s)/a(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sgscg1(n,n1,n2,ja,a,x,r,mxcg,eps) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja real(kind=rknd), dimension(*) :: a,x,r real(kind=rknd), dimension(n) :: ap,p,z cy c sgs-cg using just one matrix multiply per iteration c c initialize c nn=n2-n1+1 zdz=0.0e0_rknd relerr=1.0e0_rknd do i=n1,n2 p(i)=0.0e0_rknd ap(i)=0.0e0_rknd 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 snrm=rl2nrm(nn,z(n1)) if(snrm==0.0e0_rknd) return sum=0.0e0_rknd do i=n1,n2 t=z(i)/a(i) sum=sum+(t/snrm)*(z(i)/snrm) do j=ja(i),ja(i+1)-1 z(ja(j))=z(ja(j))-(t+x(i))*a(j) enddo enddo sum=sqrt(sum)*snrm c c test for convergence c if(itnum>1) then if(zdz==0.0e0_rknd) return beta=(sum/zdz)**2 relerr=relerr*beta if(sqrt(relerr)1) then if(zdz==0.0e0_rknd) return beta=(sum/zdz)**2 relerr=relerr*beta if(sqrt(relerr)=0) then dd=d(i) else if(d(i)/=0.0e0_rknd) dd=1.0e0_rknd/d(i) endif if(abs(b(i))=0) then t=x(i)*y(i)*d(i) else if(d(i)/=0.0e0_rknd) t=x(i)*y(i)/d(i) endif if(t>=0.0e0_rknd) then if(t1) iudl=iuu+(ngf-1)*maxd return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lsize(ip,isize) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(50) :: isize cy c array sizes c do i=1,50 isize(i)=1 enddo c ndf=ip(4) iprob=ip(6) ispd=ip(8) method=ip(9) c nb=ip(91) lenja=ip(92) lenas=ip(93)+ip(94)+1 lenans=(ip(93)+ip(94))*2-ndf+1 lenju=ip(95) lenus=ip(93)+ip(96)+1 lenuns=(ip(93)+ip(96))*2-ndf+1 c c matrices c c isize(1)=nb c isize(2)=ja c isize(3)=a c isize(4)=h c isize(5)=g c isize(6)=sm/su c c isize(11)=jua c isize(12)=ua c isize(13)=jug c isize(14)=ug c isize(1)=nb isize(2)=lenja+1 isize(11)=lenju+1 if(ispd==1) then isize(3)=lenas isize(12)=lenus else isize(3)=lenans isize(12)=lenuns endif if(abs(iprob)==4.or.abs(iprob)==6) then isize(4)=lenas else if(abs(iprob)==5) then isize(4)=lenas isize(5)=lenas isize(6)=lenans isize(13)=lenju isize(14)=lenus endif c c isize(21)=jbo c isize(22)=juac c isize(23)=uac c isize(24)=ugc c lenac=isize(2) if(ispd/=1) lenac=2*lenac-(nb+1) lenuac=isize(11) if(ispd/=1) lenuac=2*lenuac-(nb+1) isize(22)=isize(11) isize(23)=lenuac if(abs(iprob)==5) then isize(21)=isize(1) isize(24)=isize(11) endif c if(method==0.or.abs(method)==2) then isize(11)=1 isize(12)=1 isize(13)=1 isize(14)=1 endif if(method<0) then isize(22)=1 isize(23)=1 isize(24)=1 isize(21)=1 endif c c isize(31)=b/du/usv c isize(32)=dum/umsv c isize(33)=duc/ucsv c isize(34)=bdlwr/bdupr c isize(35)=p c isize(36)=d c isize(37)=rd c isize(38)=dl c isize(31)=ndf if(abs(iprob)==1) then isize(32)=ndf isize(35)=ndf else if(abs(iprob)==2) then isize(34)=ndf else if(abs(iprob)==3) then isize(32)=ndf isize(35)=ndf isize(36)=ndf isize(37)=ndf else if(abs(iprob)==4.or.abs(iprob)==6) then isize(32)=ndf isize(35)=ndf isize(36)=ndf isize(37)=ndf isize(38)=ndf else if(abs(iprob)==5) then isize(32)=ndf isize(33)=ndf isize(34)=ndf isize(35)=ndf isize(38)=ndf endif c if(iprob>0) return c c interface matrices c c isize(41)=ja0 c isize(42)=a0 c isize(43)=h0 c isize(44)=g0 c isize(45)=su0/sm0 c isize(46)=ir0/map c ndd=max(0_iknd,ip(33)) nvdd=ip(71) lenja0=ip(99) maxa0n=2*lenja0-nvdd c isize(41)=lenja0 if(ispd==1) then isize(42)=lenja0 else isize(42)=maxa0n endif c if(iprob==-3) then isize(35)=ndf+ndd isize(36)=ndf+ndd else if(iprob==-4.or.iprob==-6) then isize(37)=ndf+ndd isize(38)=ndf+ndd isize(43)=lenja0 else if(iprob==-5) then isize(35)=ndf+ndd isize(38)=ndf+ndd isize(43)=lenja0 isize(44)=lenja0 isize(45)=maxa0n endif isize(46)=2*nvdd return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine stor(ip,rp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(100) :: rp cy c determine ngf, nef c if(ip(6)==3.and.ip(7)<3) ip(7)=3 if(ip(6)==4) ip(7)=8 ip(70)=0 iprob=abs(ip(6)) itask=ip(7) nproc=ip(49) c if(iprob==1) then ngf=2 nef=1 if(itask==9) nef=2 else if(iprob==2) then ngf=1 nef=1 else if(iprob==3) then ngf=6 nef=1 else if(iprob==4.or.iprob==6) then ngf=3 nef=2 else if(iprob==5) then ngf=3 nef=3 else if(iprob==7) then ngf=4 nef=2 endif if(nproc>1) ngf=ngf+1 ip(76)=nef ip(77)=ngf c c set some rp array defaults c rp(21)=rp(1) rp(31)=rp(1) rp(33)=1.0e0_rknd rp(34)=0.0e0_rknd rp(45)=0.0e0_rknd rp(53)=1.0e0_rknd rp(59)=0.0e0_rknd rp(60)=0.0e0_rknd rp(63)=rp(3) rp(64)=1.0e0_rknd return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setcom cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: ifirst=1 cy c c set up pltmg common blocks c if(ifirst==0) return c c pointers for coefficient functions c call setval c c element definitions c call cnodes c c quadrature rules c call cquad1 call cquad2 c c 1-d interpolation formulae coefficients c call edvals ifirst=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dtpick(ntf,ndf,itnode,vx,vy,u,u0,rp,iflag,isw,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,u,u0 real(kind=rknd), dimension(ndf) :: z,gm real(kind=rknd), dimension(100) :: rp cy 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==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_rknd fudge=0.9e0_rknd iflag=3 c c the main loop c if(isw==1) go to 30 call mkgm(ndf,ntf,vx,vy,gm,itnode,itdof) do i=1,ndf z(i)=u(i)-u0(i) enddo unorm=dl2nrm(ndf,u,gm,1_iknd) utnorm=dl2nrm(ndf,z,gm,1_iknd) if(unorm>0.0e0_rknd) utnorm=utnorm/unorm rp(50)=utnorm if(isw==-1) return c c compute a new tentative time step c 30 if(utnorm>tmtol) then c c cut step back c if(deltat<=dtmin) then iflag=-2 deltat=dtmin else deltat=max(dtmin,deltat/ratio, + deltat*tmtol*fudge/utnorm) iflag=-1 endif else if(utnorm>0.0e0_rknd) then c c increase step (slight cutback if utnorm > tmtol*fudge) c deltat=min(dtmax,deltat*ratio, + deltat*tmtol*fudge/utnorm) deltat=max(dtmin,deltat) iflag=0 else iflag=-3 deltat=dtmin endif endif c c check for end of interval c if(tcur+deltat>=tend) then deltat=tend-tcur if(iflag/=-3) then iflag=2 else iflag=-4 endif else if(tcur+2.0e0_rknd*deltat>=tend) then if(tend-tcur-deltat<=2.0e0_rknd*deltat/ratio) + deltat=tend-tcur-2.0e0_rknd*deltat/ratio if(iflag/=-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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bisect(rp,isw,rqup0,rqlow0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: tol,sigup,siglow,signew,sigold,rqup real(kind=rknd), save :: rqlow,rqnew,rqold,rqmx cy 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==0) then tol=max(1.0e-6_rknd,1.0e2_rknd*epsilon(1.0e0_rknd)) sigup=rp(71) siglow=0.0e0_rknd signew=sigup sigold=siglow rqup=rp(25) rqlow=rp(35) rqnew=rqup rqold=rqlow rqmx=max(abs(rqup),abs(rqlow)) isw=1 else sigold=signew signew=rp(71) rqold=rqnew rqnew=rp(25) if(rqnew*rqlow<0.0e0_rknd) 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_rknd ds=abs(sigup-siglow) c c convergence test c if(sigma==signew.or.ds 0 update c < 0 converged c ntf=ip(1) iprob=ip(6) itask=ip(7) c c compute norms c call mkgm(ndf,ntf,vx,vy,gm,itnode,itdof) if(iprob==1.and.itask==9) then call norm1(ndf,ip,rp,isw,itnum,u,du,um,dum, + ja,ibs,ibp,a,b,p,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) enddo step0=1.0e0_rknd endif else if(iprob==2) then call norm2(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) enddo step0=stepmx(ndf,u,du,bdlwr,bdupr) endif else if(iprob==3) then call norm3(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,p,d,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) enddo rlsv=rp(21) step0=1.0e0_rknd endif else if(iprob==4) then call norm4(ndf,ip,rp,isw,itnum,u,um,du,dum,ja, + ibs,ibp,a,h,b,p,d,dl,gm) if(isw<=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<0.0e0_rknd) then step0=min((rllwr-rlsv)/delta,1.0e0_rknd) else if(delta>0.0e0_rknd) then step0=min((rlupr-rlsv)/delta,1.0e0_rknd) else step0=1.0e0_rknd endif endif else if(iprob==5) then call norm5(ndf,ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,ibs,ibp,a,h,g,su,sm,b,p,dl,gm) if(isw<=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 if(iprob==6) then call norm4(ndf,ip,rp,isw,itnum,u,um,du,dum,ja, + ibs,ibp,a,h,b,p,d,dl,gm) if(isw<=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<0.0e0_rknd) then step0=min((rllwr-rlsv)/delta,1.0e0_rknd) else if(delta>0.0e0_rknd) then step0=min((rlupr-rlsv)/delta,1.0e0_rknd) else step0=1.0e0_rknd endif endif else call norm7(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) enddo step0=1.0e0_rknd endif endif c c compute new step c call cstep(rp,0_iknd,isw,step0) if(isw==-1) return c c update solution with current step c step=rp(52) delta=rp(72) if(iprob==1.and.itask==9) then do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob==3) then rp(21)=rlsv+step*delta else if(iprob==4) then rp(21)=rlsv+step*delta do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob==5) then do i=1,ndf um(i)=umsv(i)+step*dum(i) uc(i)=ucsv(i)+step*duc(i) enddo else if(iprob==6) then rl=rlsv+step*delta rp(21)=rl do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo call csf(ip,rp,vx,vy,ibndry,sf,sxy) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cstep(rp,iexsw,isw,step0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: ksw real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: tol,eps,snew,sold,sleft,sright,dnew real(kind=rknd), save :: dold,fnew,fold cy 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<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) tol=1.0e-2_rknd snew=0.0e0_rknd sleft=0.0e0_rknd sright=0.0e0_rknd dnew=rp(58) fnew=rp(56)**2/2.0e0_rknd step=rp(52) ratio=rp(57) step=step/(step+(1.0e0_rknd-step)*ratio/100.0e0_rknd) if(step0<1.0e0_rknd) then frac=max(0.75e0_rknd,0.98e0_rknd-rp(63)) step=min(step,frac*step0) endif if(iexsw==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_rknd relres=rp(56) ratio=rp(57) relerr=rp(54) c if(sright<=0.0e0_rknd.or.dnew>0.0e0_rknd.or.ksw==1) then sright=snew if(dnew<=0.0e0_rknd) then ksw=1 else ksw=0 endif else sleft=snew endif c c sufficient decrease c ds=sright-sleft if(ds<=tol.and.dnew<=0.0e0_rknd) isw=-1 if(ratio<=1.0e0_rknd-eps*snew.and.dnew<=0.0e0_rknd) isw=-1 if(min(relerr,relres)<=eps) isw=-1 if(isw==-1) return c c bisection step c rp(52)=(sleft+sright)/2.0e0_rknd if(ksw==0) then c c secant step c if(dold==dnew) return step=snew-dnew*(snew-sold)/(dnew-dold) else c c cubic interpolation step c ff=-(fold-fnew)*6.0e0_rknd/(sold-snew) gg=(dold+dnew) a=ff+gg*3.0e0_rknd b=-(ff+2.0e0_rknd*(gg+dnew)) c=dnew if(snew>sold) then a=-a b=-b c=-c endif rr=max(abs(a),abs(b),abs(c))*eps c c quadratic case c if(abs(a) 0 for min c if(b<=rr) return step=snew-(c/b)*(sold-snew) else c c cubic case c b=b/(2.0e0_rknd*a) c=c/a discr=b**2-c if(discr<=0.0e0_rknd) return d=sqrt(discr) if(b<0.0e0_rknd) then c c the min occurs for 2*a r + b > 0 (not b/2a above) c if(a>0.0e0_rknd) then r=-(b-d) else r=-c/(b-d) endif else if(a<0.0e0_rknd) 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(max(dl,dr)<=ds*(1.0e0_rknd-tol)) then rp(52)=step else if(dl<=ds*tol) then rp(52)=sleft+ds*tol else if(dr<=ds*tol) then rp(52)=sright-ds*tol endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function stepmx(n,u,du,bdlwr,bdupr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: u,du,bdlwr,bdupr real(kind=rknd) :: stepmx cy c compute maximum step for interior point c stepmx=1.0e0_rknd do i=1,n if(du(i)<0.0e0_rknd) then stepmx=min((bdlwr(i)-u(i))/du(i),stepmx) else if(du(i)>0.0e0_rknd) then stepmx=min((bdupr(i)-u(i))/du(i),stepmx) endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm1(ndf,ip,rp,isw,itnum,u,du,um,dum,ja,ibs, + ibp,a,b,p,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(*) :: u,du,a,b,gm,um,dum,p real(kind=rknd), dimension(ndf) :: adu,adum real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: eps,bnorm0=0.0e0_rknd, + bmnrm0=0.0e0_rknd,blast=0.0e0_rknd,bmlast=0.0e0_rknd cy c compute norms -- iprob=1 c ispd=ip(8) nb=ip(91) jspd=1 if(ispd/=1) jspd=-1 c call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd) bnorm=dl2nrm(ndf,b,gm,-1_iknd) gamma=dl2ip(ndf,b,adu,gm,-1_iknd) c call mtxmlt(ndf,nb,ja,ibs,ibp,a,dum,adum,jspd) bmnorm=dl2nrm(ndf,p,gm,-1_iknd) gammam=dl2ip(ndf,p,adum,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c enorm=dl2nrm(ndf,du,gm,1_iknd) unorm=dl2nrm(ndf,u,gm,1_iknd) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd emnorm=dl2nrm(ndf,dum,gm,1_iknd) umnorm=dl2nrm(ndf,um,gm,1_iknd) relerm=1.0e0_rknd if(umnorm>emnorm) relerm=emnorm/umnorm if(umnorm+emnorm<=0.0e0_rknd) relerm=0.0e0_rknd rp(54)=relerr+relerm rp(54)=relerr c if(bnorm<=0.0e0_rknd) bnorm=eps if(bmnorm<=0.0e0_rknd) bmnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 bmnrm0=max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm2(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp,a,b,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: u,du,a,b,gm real(kind=rknd), dimension(ndf) :: adu real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=2 c ispd=ip(8) nb=ip(91) c call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd) bnorm=dl2nrm(ndf,b,gm,-1_iknd) gamma=dl2ip(ndf,b,adu,gm,-1_iknd) c if(isw==0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c enorm=dl2nrm(ndf,du,gm,1_iknd) unorm=dl2nrm(ndf,u,gm,1_iknd) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd rp(54)=relerr c if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm3(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,p,d,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: u,du,a,b,p,d,gm real(kind=rknd), dimension(ndf) :: adu real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=3 c ispd=ip(8) nb=ip(91) 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 mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd) ss=thetar*(rl2ip(ndf,p,du)+drdrl*delta)+thetal*delta bnorm=sqrt(dl2nrm(ndf,b,gm,-1_iknd)**2+scleqn**2) gamma=dl2ip(ndf,b,adu,gm,-1_iknd) bd=dl2ip(ndf,b,d,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c c compute relerr c enorm=dl2nrm(ndf,du,gm,1_iknd) unorm=dl2nrm(ndf,u,gm,1_iknd) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd rlerr=1.0e0_rknd if(abs(rl)>abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta)==0.0e0_rknd) rlerr=0.0e0_rknd rp(54)=relerr+rlerr c if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm4(ndf,ip,rp,isw,itnum,u,um,du,dum,ja, + ibs,ibp,a,h,b,p,d,dl,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: u,um,du,dum,a,h,b,p,d,dl,gm real(kind=rknd), dimension(ndf) :: adu,hdu real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c c compute norms -- iprob=4 c ispd=ip(8) jspd=1 if(ispd/=1) jspd=-1 nb=ip(91) scleqn=rp(67) seqdot=rp(74) delta=rp(72) rl=rp(21) c c matrix multiplies c call mtxmlt(ndf,nb,ja,ibs,ibp,h,du,hdu,1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,a,dum,adu,jspd) do i=1,ndf hdu(i)=hdu(i)+adu(i)-delta*dl(i) enddo call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd) do i=1,ndf adu(i)=adu(i)-delta*d(i) enddo bnorm=dl2nrm(ndf,b,gm,-1_iknd) gamma=dl2ip(ndf,b,adu,gm,-1_iknd) pnorm=dl2nrm(ndf,p,gm,-1_iknd) pgamma=dl2ip(ndf,p,hdu,gm,-1_iknd) bnorm=sqrt(scleqn**2+bnorm**2+pnorm**2) c=-rl2ip(ndf,du,dl)-rl2ip(ndf,dum,d)-seqdot*delta c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c uunorm=dl2nrm(ndf,u,gm,1_iknd) umnorm=dl2nrm(ndf,um,gm,1_iknd) eunorm=dl2nrm(ndf,du,gm,1_iknd) emnorm=dl2nrm(ndf,dum,gm,1_iknd) c c compute relerr c rulerr=1.0e0_rknd if(uunorm>eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd rmlerr=1.0e0_rknd if(umnorm>emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd rlerr=1.0e0_rknd if(abs(rl)>abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta)==0.0e0_rknd) rlerr=0.0e0_rknd rp(54)=rulerr+rmlerr+rlerr c if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm5(ndf,ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,ibs,ibp,a,h,g,su,sm,b,p,dl,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(*) :: u,um,uc,du,dum,duc,a,h,g,su real(kind=rknd), dimension(*) :: sm,b,p,dl,gm real(kind=rknd), dimension(ndf) :: adu,hdu real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c c compute norms -- iprob=5 c ispd=ip(8) jspd=1 if(ispd/=1) jspd=-1 nb=ip(91) c c first equation c call mtxmlt(ndf,nb,ja,ibs,ibp,h,du,hdu,1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,a,dum,adu,jspd) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo call mtxmlt(ndf,nb,ja,ibs,ibp,su,duc,adu,0_iknd) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo umip=dl2ip(ndf,p,hdu,gm,-1_iknd) bmnorm=dl2nrm(ndf,p,gm,-1_iknd) if(isw<=0) then umnorm=dl2nrm(ndf,um,gm,1_iknd) emnorm=dl2nrm(ndf,dum,gm,1_iknd) endif c c second equation c call mtxmlt(ndf,nb,ja,ibs,ibp,sm,duc,hdu,0_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd) do i=1,ndf adu(i)=adu(i)+hdu(i) enddo uip=dl2ip(ndf,b,adu,gm,-1_iknd) bnorm=dl2nrm(ndf,b,gm,-1_iknd) if(isw<=0) then uunorm=dl2nrm(ndf,u,gm,1_iknd) eunorm=dl2nrm(ndf,du,gm,1_iknd) endif c c third equation c call mtxmlt(ndf,nb,ja,ibs,ibp,g,duc,hdu,1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,sm,dum,adu,-1_iknd) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo call mtxmlt(ndf,nb,ja,ibs,ibp,su,du,adu,-1_iknd) do i=1,ndf hdu(i)=hdu(i)+adu(i) enddo ucip=dl2ip(ndf,dl,hdu,gm,-1_iknd) bcnorm=dl2nrm(ndf,dl,gm,-1_iknd) bnorm=sqrt(bcnorm**2+bnorm**2+bmnorm**2) if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c ucnorm=dl2nrm(ndf,uc,gm,1_iknd) ecnorm=dl2nrm(ndf,duc,gm,1_iknd) c c compute relerr c rulerr=1.0e0_rknd if(uunorm>eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd rmlerr=1.0e0_rknd if(umnorm>emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd rclerr=1.0e0_rknd if(ucnorm>ecnorm) rclerr=ecnorm/ucnorm if(ucnorm+ecnorm<=0.0e0_rknd) rclerr=0.0e0_rknd rp(54)=rulerr+rmlerr+rclerr c if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm7(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp,a,b,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(*) :: u,du,a,b,gm real(kind=rknd), dimension(ndf) :: adu real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=7 c ispd=ip(8) nb=ip(91) c c compute adu c call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd) bnorm=dl2nrm(ndf,b,gm,-1_iknd) gamma=dl2ip(ndf,b,adu,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c enorm=dl2nrm(ndf,du,gm,1_iknd) unorm=dl2nrm(ndf,u,gm,1_iknd) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd rp(54)=relerr c if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tpickd(ndf,ip,rp,vx,vy,itnode,ibndry,sf,itdof,u, + um,uc,usv,umsv,ucsv,ja,ibs,ibp,a,h,g,su,sm,b, 1 d,p,dl,bdlwr,bdupr,du,dum,duc,ipath,ir0,map,ja0,a0,h0,g0, 2 su0,sm0,isw,itnum,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,u,um,uc,usv,umsv, + ucsv,a,h,g,su,sm,b,d,p,dl,bdlwr,bdupr,du,dum,duc,a0, 1 h0,g0,su0,sm0 real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(ndf) :: gm real(kind=rknd), save :: rlsv,step0 cy external sxy 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(4) nn=ip(71) newntf=ip(27) iprob=abs(ip(6)) itask=ip(7) c c compute norms c call mkgm(ndf,newntf,vx,vy,gm,itnode,itdof) if(iprob==1.and.itask==9) then call norm1p(ndf,ip,rp,isw,itnum,u,du,um,dum,ja,ibs,ibp, + a,b,p,ipath,ir0,map,ja0,a0,nn,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) umsv(i)=um(i) enddo step0=1.0e0_rknd endif else if(iprob==2) then call norm2p(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,ipath,ir0,map,ja0,a0,nn,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) enddo step0=stepmx(ndf,u,du,bdlwr,bdupr) endif else if(iprob==3) then call norm3p(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,p,d,ipath,ir0,map,ja0,a0,nn,gm) c if(isw<=0) then do i=1,ndf usv(i)=u(i) enddo rlsv=rp(21) step0=1.0e0_rknd endif else if(iprob==4) then call norm4p(ndf,ip,rp,isw,itnum,u,um,du,dum,ja, + ibs,ibp,a,h,b,p,d,dl,ipath,ir0,map,ja0,a0,h0,nn,gm) if(isw<=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<0.0e0_rknd) then step0=min((rllwr-rlsv)/delta,1.0e0_rknd) else if(delta>0.0e0_rknd) then step0=min((rlupr-rlsv)/delta,1.0e0_rknd) else step0=1.0e0_rknd endif endif else if(iprob==5) then call norm5p(ndf,ip,rp,isw,itnum,u,um,uc,du,dum,duc, + ja,ibs,ibp,a,h,g,su,sm,b,p,dl, 1 ipath,ir0,map,ja0,a0,h0,g0,su0,sm0,nn,gm) if(isw<=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 if(iprob==6) then call norm4p(ndf,ip,rp,isw,itnum,u,um,du,dum,ja, + ibs,ibp,a,h,b,p,d,dl,ipath,ir0,map,ja0,a0,h0,nn,gm) if(isw<=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<0.0e0_rknd) then step0=min((rllwr-rlsv)/delta,1.0e0_rknd) else if(delta>0.0e0_rknd) then step0=min((rlupr-rlsv)/delta,1.0e0_rknd) else step0=1.0e0_rknd endif endif else call norm7p(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,ipath,ir0,map,ja0,a0,nn,gm) if(isw<=0) then do i=1,ndf usv(i)=u(i) enddo step0=1.0e0_rknd endif endif c c compute new step c call cstep(rp,1_iknd,isw,step0) if(isw==-1) return c c update solution with current step c step=rp(52) delta=rp(72) if(iprob==1.and.itask==9) then do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob==3) then rp(21)=rlsv+step*delta else if(iprob==4) then rp(21)=rlsv+step*delta do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo else if(iprob==5) then do i=1,ndf um(i)=umsv(i)+step*dum(i) uc(i)=ucsv(i)+step*duc(i) enddo else if(iprob==6) then rl=rlsv+step*delta rp(21)=rl do i=1,ndf um(i)=umsv(i)+step*dum(i) enddo call csf(ip,rp,vx,vy,ibndry,sf,sxy) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm1p(ndf,ip,rp,isw,itnum,u,du,um,dum,ja,ibs, + ibp,a,b,p,ipath,ir0,map,ja0,a0,nn,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(6,*) :: ipath real(kind=rknd), dimension(*) :: u,du,a,b,a0,um,dum,p,gm real(kind=rknd), dimension(nn,4) :: gf real(kind=rknd), dimension(ndf) :: adu,adum real(kind=rknd), dimension(20) :: t real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: eps,bnorm0=0.0e0_rknd, + bmnrm0=0.0e0_rknd,blast=0.0e0_rknd,bmlast=0.0e0_rknd cy c compute norms -- iprob=-1 c ndf=ip(4) ispd=ip(8) jspd=1 if(ispd/=1) jspd=-1 newndf=ip(30) ndd=ip(33) nb=ip(91) c irgn=ip(50) num=4 c c compute adu c call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,du,adu,ispd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,dum,adum,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,ir0,map,gf,nn,num) call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,1),adu,ispd,1_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),adum,jspd,1_iknd) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1_iknd) t(2)=dl2ip(newndf,p,p,gm,-1_iknd) t(3)=dl2ip(newndf,adu,b,gm,-1_iknd) t(4)=dl2ip(newndf,adum,p,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c t(5)=dl2ip(newndf,du,du,gm,1_iknd) t(6)=dl2ip(newndf,dum,dum,gm,1_iknd) t(7)=dl2ip(newndf,u,u,gm,1_iknd) t(8)=dl2ip(newndf,um,um,gm,1_iknd) c call pl2ip(t,8_iknd) c enorm=sqrt(t(5)) emnorm=sqrt(t(6)) unorm=sqrt(t(7)) umnorm=sqrt(t(8)) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd relerm=1.0e0_rknd if(umnorm>emnorm) relerm=emnorm/umnorm if(umnorm+emnorm<=0.0e0_rknd) relerm=0.0e0_rknd rp(54)=relerr+relerm rp(54)=relerr c bnorm=sqrt(t(1)) if(bnorm<=0.0e0_rknd) bnorm=eps bmnorm=sqrt(t(2)) if(bmnorm<=0.0e0_rknd) bmnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 bmnrm0=max(bmnorm,rp(60)) rp(60)=bmnrm0 endif else call pl2ip(t,4_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm2p(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,ipath,ir0,map,ja0,a0,nn,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(6,*) :: ipath real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: u,du,a,b,a0,gm real(kind=rknd), dimension(nn,2) :: gf real(kind=rknd), dimension(ndf) :: adu real(kind=rknd), dimension(10) :: t real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=-2 c ndf=ip(4) ispd=ip(8) newndf=ip(30) ndd=ip(33) nb=ip(91) irgn=ip(50) c c compute adu c call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,du,adu,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,ir0,map,gf,nn,2_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,1),adu,ispd,1_iknd) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1_iknd) t(2)=dl2ip(newndf,adu,b,gm,-1_iknd) if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c t(3)=dl2ip(newndf,du,du,gm,1_iknd) t(4)=dl2ip(newndf,u,u,gm,1_iknd) c call pl2ip(t,4_iknd) c c enorm=sqrt(t(3)) unorm=sqrt(t(4)) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd rp(54)=relerr c bnorm=sqrt(t(1)) if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,2_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm3p(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,p,d,ipath,ir0,map,ja0,a0,nn,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(6,*) :: ipath real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: u,du,a,b,p,d,a0,gm real(kind=rknd), dimension(nn,2) :: gf real(kind=rknd), dimension(ndf) :: adu real(kind=rknd), dimension(10) :: t real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=-3 c ndf=ip(4) ispd=ip(8) newndf=ip(30) ndd=ip(33) nb=ip(91) irgn=ip(50) 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 call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,du,adu,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,ir0,map,gf,nn,2_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,1),adu,ispd,1_iknd) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1_iknd) t(2)=dl2ip(newndf,adu,b,gm,-1_iknd) t(3)=dl2ip(newndf,b,d,gm,-1_iknd) t(4)=rl2ip(newndf,p,du) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c t(5)=dl2ip(newndf,du,du,gm,1_iknd) t(6)=dl2ip(newndf,u,u,gm,1_iknd) call pl2ip(t,6_iknd) c c compute relerr c enorm=sqrt(t(5)) unorm=sqrt(t(6)) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd rlerr=1.0e0_rknd if(abs(rl)>abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta)==0.0e0_rknd) rlerr=0.0e0_rknd rp(54)=relerr+rlerr c bnorm=sqrt(t(1)+scleqn**2) if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,4_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm4p(ndf,ip,rp,isw,itnum,u,um,du,dum,ja, + ibs,ibp,a,h,b,p,d,dl,ipath,ir0,map,ja0,a0,h0,nn,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(6,*) :: ipath real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: u,um,du,dum,a,h,b,p,d,dl,a0 real(kind=rknd), dimension(*) :: h0,gm real(kind=rknd), dimension(nn,5) :: gf real(kind=rknd), dimension(ndf) :: adu,adum,hdu real(kind=rknd), dimension(20) :: t real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=-4 c ndf=ip(4) ispd=ip(8) newndf=ip(30) ndd=ip(33) nb=ip(91) scleqn=rp(67) seqdot=rp(74) delta=rp(72) rl=rp(21) c irgn=ip(50) c num=5 c c matrix multiplies c ii=ipath(3,irgn)-1 call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + h,ir0,ja0,h0,du,hdu,1_iknd) jspd=1 if(ispd/=1) jspd=-1 call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,dum,adum,jspd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,du,adu,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,ir0,map,gf,nn,num) c call jmpmlt(ip,ja0,h0,ir0,gf(1,2),gf(1,1),hdu,1_iknd,-1_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),adum,jspd,1_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,5),adu,ispd,1_iknd) 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_iknd) t(2)=dl2ip(newndf,p,p,gm,-1_iknd) t(3)=rl2ip(newndf,du,dl) t(4)=rl2ip(newndf,dum,d) t(5)=dl2ip(newndf,b,adu,gm,-1_iknd) t(6)=dl2ip(newndf,p,hdu,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) t(7)=dl2ip(newndf,u,u,gm,1_iknd) t(8)=dl2ip(newndf,um,um,gm,1_iknd) t(9)=dl2ip(newndf,du,du,gm,1_iknd) t(10)=dl2ip(newndf,dum,dum,gm,1_iknd) c call pl2ip(t,10_iknd) 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_rknd if(uunorm>eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd rmlerr=1.0e0_rknd if(umnorm>emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd rlerr=1.0e0_rknd if(abs(rl)>abs(delta)) rlerr=abs(delta)/abs(rl) if(abs(rl)+abs(delta)==0.0e0_rknd) rlerr=0.0e0_rknd rp(54)=rulerr+rmlerr+rlerr c bnorm=sqrt(scleqn**2+t(1)+t(2)) if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,6_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm5p(ndf,ip,rp,isw,itnum,u,um,uc,du,dum,duc,ja, + ibs,ibp,a,h,g,su,sm,b,p,dl,ipath,ir0,map, 1 ja0,a0,h0,g0,su0,sm0,nn,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(6,*) :: ipath real(kind=rknd), dimension(*) :: u,um,uc,du,dum,duc,a,h,g,su real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: sm,b,p,dl,a0,h0,g0,su0,sm0 real(kind=rknd), dimension(nn,11) :: gf real(kind=rknd), dimension(ndf) :: adu,adum,gduc,hdu,smdum real(kind=rknd), dimension(ndf) :: smduc,sudu,suduc real(kind=rknd), dimension(*) :: gm real(kind=rknd), dimension(15) :: t real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=-5 c ndf=ip(4) ispd=ip(8) newndf=ip(30) ndd=ip(33) nb=ip(91) c irgn=ip(50) c num=11 c c matrix multiplies c ii=ipath(3,irgn)-1 jspd=1 if(ispd/=1) jspd=-1 c call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,du,adu,ispd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,dum,adum,jspd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + h,ir0,ja0,h0,du,hdu,1_iknd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + g,ir0,ja0,g0,duc,gduc,1_iknd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + sm,ir0,ja0,sm0,duc,smduc,0_iknd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + sm,ir0,ja0,sm0,dum,smdum,-1_iknd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + su,ir0,ja0,su0,duc,suduc,0_iknd) call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + su,ir0,ja0,su0,dum,sudu,-1_iknd) 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,ir0,map,gf,nn,num) c call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,5),adu,ispd,1_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),adum,jspd,1_iknd) call jmpmlt(ip,ja0,h0,ir0,gf(1,2),gf(1,1),hdu,1_iknd,-1_iknd) call jmpmlt(ip,ja0,g0,ir0,gf(1,7),gf(1,6),gduc,1_iknd,1_iknd) call jmpmlt(ip,ja0,sm0,ir0,gf(1,7),gf(1,9),smduc,0_iknd,-1_iknd) call jmpmlt(ip,ja0,sm0,ir0,gf(1,4),gf(1,8),smdum, + -1_iknd,-1_iknd) call jmpmlt(ip,ja0,su0,ir0,gf(1,7),gf(1,11),suduc, + 0_iknd,-1_iknd) call jmpmlt(ip,ja0,su0,ir0,gf(1,2),gf(1,10),sudu, + -1_iknd,-1_iknd) 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_iknd) t(2)=dl2ip(newndf,b,b,gm,-1_iknd) t(3)=dl2ip(newndf,dl,dl,gm,-1_iknd) t(4)=dl2ip(newndf,p,hdu,gm,-1_iknd) t(5)=dl2ip(newndf,b,adu,gm,-1_iknd) t(6)=dl2ip(newndf,dl,gduc,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c t(7)=dl2ip(newndf,um,um,gm,1_iknd) t(8)=dl2ip(newndf,u,u,gm,1_iknd) t(9)=dl2ip(newndf,uc,uc,gm,1_iknd) t(10)=dl2ip(newndf,dum,dum,gm,1_iknd) t(11)=dl2ip(newndf,du,du,gm,1_iknd) t(12)=dl2ip(newndf,duc,duc,gm,1_iknd) c call pl2ip(t,12_iknd) 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_rknd if(uunorm>eunorm) rulerr=eunorm/uunorm if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd rmlerr=1.0e0_rknd if(umnorm>emnorm) rmlerr=emnorm/umnorm if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd rclerr=1.0e0_rknd if(ucnorm>ecnorm) rclerr=ecnorm/ucnorm if(ucnorm+ecnorm<=0.0e0_rknd) rclerr=0.0e0_rknd rp(54)=rulerr+rmlerr+rclerr c bnorm=sqrt(t(1)+t(2)+t(3)) if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,6_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine norm7p(ndf,ip,rp,isw,itnum,u,du,ja,ibs,ibp, + a,b,ipath,ir0,map,ja0,a0,nn,gm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ir0,map,ja0 integer(kind=iknd), dimension(6,*) :: ipath real(kind=rknd), dimension(*) :: u,du,a,b,a0,gm real(kind=rknd), dimension(nn,2) :: gf real(kind=rknd), dimension(ndf) :: adu real(kind=rknd), dimension(10) :: t real(kind=rknd), dimension(100) :: rp real(kind=rknd), save :: bnorm0=0.0e0_rknd, + blast=0.0e0_rknd,eps cy c compute norms -- iprob=-7 c ndf=ip(4) ispd=ip(8) newndf=ip(30) ndd=ip(33) nb=ip(91) c irgn=ip(50) c c compute adu c call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,du,adu,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,ir0,map,gf,nn,2_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,1),adu,ispd,1_iknd) c c form inner products for line search/convergence c t(1)=dl2ip(newndf,b,b,gm,-1_iknd) t(2)=dl2ip(newndf,adu,b,gm,-1_iknd) c if(isw<=0) then eps=1.0e2_rknd*epsilon(1.0e0_rknd) c t(3)=dl2ip(newndf,du,du,gm,1_iknd) t(4)=dl2ip(newndf,u,u,gm,1_iknd) c call pl2ip(t,4_iknd) c enorm=sqrt(t(3)) unorm=sqrt(t(4)) relerr=1.0e0_rknd if(unorm>enorm) relerr=enorm/unorm if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd rp(54)=relerr c bnorm=sqrt(t(1)) if(bnorm<=0.0e0_rknd) bnorm=eps if(itnum==1) then bnorm0=max(bnorm,rp(59)) rp(59)=bnorm0 endif else call pl2ip(t,2_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine csf(ip,rp,vx,vy,ibndry,sf,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy external sxy c c compute vertices on parameterized edges c nbf=ip(3) rl=rp(21) do i=1,nbf if(ibndry(3,i)>=0) cycle itag=-ibndry(3,i) do j=1,2 iv=ibndry(j,i) ss=sf(j,i) do k=1,12 values(k)=0.0e0_rknd enddo call sxy(rl,ss,itag,values) vx(iv)=values(1) vy(iv)=values(2) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ctheta(ip,rp,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(100) :: rp cy c compute normalization equation parameters c iflag=0 itask=ip(7) c c rtrgt=rp(2) rltrgt=rp(1) rstrt=rp(27) rlstrt=rp(26) scale=rp(68) c c compute theta c if(itask<=1) then rl0dot=rp(33) r0dot=rp(34) if(rtrgt==rstrt) then if(rl0dot==0.0e0_rknd) iflag=1 theta=0.0e0_rknd else if(rltrgt==rlstrt) then if(r0dot==0.0e0_rknd) iflag=1 theta=2.0e0_rknd else iflag=1 theta=1.0e0_rknd endif rl0=rp(31) r0=rp(32) thetal=(2.0e0_rknd-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==0.0e0_rknd) rp(68)=1.0e0_rknd else if(itask>=3.and.itask<=7) then c c initialize for changing parameters or functional c if(itask<=4) then rp(68)=1.0e0_rknd rp(21)=rltrgt rp(22)=rtrgt rp(23)=1.0e0_rknd rp(24)=1.0e0_rknd c rp(31)=rltrgt rp(32)=rtrgt rp(33)=1.0e0_rknd rp(34)=1.0e0_rknd endif rl0dot=rp(33) r0dot=rp(34) if(itask==3.or.itask==5) then if(rl0dot==0.0e0_rknd) iflag=1 theta=0.0e0_rknd else if(itask==4.or.itask==6) then if(r0dot==0.0e0_rknd) iflag=1 theta=2.0e0_rknd else if(itask==7) then if(r0dot==0.0e0_rknd.and.rl0dot==0.0e0_rknd) iflag=1 theta=1.0e0_rknd endif c thetal=(2.0e0_rknd-theta)*rl0dot thetar=theta*r0dot seqdot=thetar*r0dot+thetal*rl0dot rp(69)=thetal rp(70)=thetar rp(71)=0.0e0_rknd rp(74)=seqdot if(scale==0.0e0_rknd) rp(68)=1.0e0_rknd else rp(69)=0.0e0_rknd rp(70)=0.0e0_rknd rp(71)=0.0e0_rknd rp(74)=0.0e0_rknd rp(68)=1.0e0_rknd iflag=1 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine updpth(isw,itype,rp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(100) :: rp common /pltmg6/path(101,6) cy 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==1) then num=1 do i=1,101 do j=1,6 path(i,j)=0.0e0_rknd enddo enddo else if(isw==0) then num=int(path(101,1)) else num=int(path(101,1)) if(num>=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==0) then jtype=int(path(num,6)) if(jtype/=7) path(num,6)=real(itype,rknd) else path(num,6)=real(itype,rknd) endif path(101,1)=real(num,rknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine updtm(isw,itype,rp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(100) :: rp common /pltmg6/path(101,6) cy c update time history c c isw=1 initialize c =0 replace last entry c =-1 append to end of list c if(isw==1) then num=1 else if(isw==0) then num=int(path(101,1)) else num=int(path(101,1)) if(num>=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_rknd path(num,5)=0.0e0_rknd path(num,6)=real(itype,rknd) path(101,1)=real(num,rknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine updip(isw,itype,rp,ip) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(100) :: rp common /pltmg6/path(101,6) cy 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==1) then num=1 do i=1,101 do j=1,6 path(i,j)=0.0e0_rknd enddo enddo else if(isw==0) then num=int(path(101,1)) else num=int(path(101,1)) if(num>=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==3) then path(num,3)=real(ip(38),rknd) else path(num,3)=real(ip(2),rknd) endif path(num,4)=0.0e0_rknd path(num,5)=0.0e0_rknd path(num,6)=real(itype,rknd) if(num>1) then jsw=0 if(path(num-1,1)/=path(num,1)) jsw=1 if(path(num-1,3)/=path(num,3)) jsw=1 if(path(num-1,6)/=path(num,6)) jsw=1 if(jsw==0) then num=num-1 path(num,2)=rp(22) endif endif path(101,1)=real(num,rknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine hist1(ihist,itnum,bnorm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) common /pltmg7/time(3,50),hist(22,30) cy c update history array c mxhist=20 if(itnum<=0) then hist(mxhist+2,ihist)=bnorm else if(itnum>mxhist) then do i=1,mxhist-1 hist(i,ihist)=hist(i+1,ihist) enddo hist(mxhist,ihist)=bnorm else hist(itnum,ihist)=bnorm endif if(itnum>=0) hist(mxhist+1,ihist)=real(itnum,rknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine hist2(rp,iadapt,ndf) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: len=50, mxhist=20 real(kind=rknd), dimension(100) :: rp common /pltmg7/time(3,50),hist(22,30) cy 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) = total time to end of this call to errest 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) = total time to end of this call to errest c hist(*,24) = c hist(*,25) = c hist(*,26) = c hist(*,27) = spectral biscetion --- inverse iteration c hist(*,28) = spectral biscetion --- inverse iteration c hist(*,29) = spectral biscetion --- inverse iteration c hist(*,30) = spectral biscetion --- inverse iteration c c save convergence history c if(ndf==0) then if(iadapt/=0) then sum=0.0e0_rknd num=int(hist(mxhist+2,1)) do i=1,len sum=sum+time(2,i) enddo num=int(hist(mxhist+2,1)) if(num>0) hist(num,5)=sum num=int(hist(mxhist+2,19)) if(num>0) hist(num,23)=sum else numhst=30 do j=1,numhst do i=1,mxhist+2 hist(i,j)=0.0e0_rknd enddo enddo endif return endif c ishift=0 if(iadapt==-2) ishift=18 num=int(hist(mxhist+2,ishift+1)) if(num==mxhist) then do j=ishift+1,ishift+5 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)=real(ndf,rknd) hist(num,ishift+2)=real(iadapt,rknd) hist(num,ishift+3)=rp(37) hist(num,ishift+4)=rp(39) hist(mxhist+2,ishift+1)=real(num,rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine hist3(ihist,itnum,bnorm,enorm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) common /pltmg7/time(3,50),hist(22,30) cy c update history array c mxhist=20 if(itnum<=0) then hist(mxhist+2,ihist)=bnorm hist(mxhist+2,ihist+1)=enorm hist(mxhist+1,ihist+1)=real(itnum,rknd) else if(itnum>mxhist) then do i=1,mxhist-1 hist(i,ihist)=hist(i+1,ihist) hist(i,ihist+1)=hist(i+1,ihist+1) enddo hist(mxhist,ihist)=bnorm hist(mxhist,ihist+1)=enorm else hist(itnum,ihist)=bnorm hist(itnum,ihist+1)=enorm endif if(itnum>=0) hist(mxhist+1,ihist)=real(itnum,rknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pstat(ip,rp,ndf,itnode,itdof,e,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(ndf) :: mark integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: e real(kind=rknd), dimension(100) :: rp cy nsum=0 esum=0.0e0_rknd ntf=ip(1) irgn=ip(50) do i=1,ndf mark(i)=0 enddo do i=1,ntf if(itnode(4,i)/=irgn) cycle call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof mark(idof(j))=1 enddo esum=esum+e(i) enddo do i=1,ndf nsum=nsum+mark(i) enddo if(itype==0) then rp(95)=real(nsum,rknd) rp(96)=esum rp(97)=0.0e0_rknd rp(98)=0.0e0_rknd else rp(97)=real(nsum,rknd) rp(98)=esum endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cequv1(nvf,nbf,ibndry,iequv,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: iequv cy c initialize iequv c do i=1,nvf iequv(i)=i enddo c c set up equivalence classes for vertices c do i=1,nbf if(ibndry(4,i)>=0) cycle if(isw==2) then if(ibndry(5,i)==0) cycle if(abs(ibndry(5,i))==5) cycle endif j=-ibndry(4,i) if(j0) then do k=1,2 if(vtype(ibndry(k,i))/=9) vtype(ibndry(k,i))=7 enddo else if(ibndry(4,i)<0) then do k=1,2 vtype(ibndry(k,i))=9 enddo else do k=1,2 if(vtype(ibndry(k,i))==1) vtype(ibndry(k,i))=4 enddo endif enddo c c mark interfaces in itedge c call cedge5(nbf,itedge,ibedge,1_iknd) 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,sf,rl,itedge,vtype, + angmin,arcmax,vlist,tlist,elist,len,sxy) enddo c call cedge5(nbf,itedge,ibedge,0_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tstvty(i,itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist,tlist,elist,len,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iv,jb integer(kind=iknd), dimension(*) :: vtype,elist, + tlist,vlist integer(kind=iknd), save, dimension(10) :: start integer(kind=iknd) :: rgnct, tot, edct real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3) :: c cy external sxy data index/1,2,3,2,3,1,3,1,2/ data start/1,1,1,4,4,4,7,7,9,9/ c c test for vertex type c vtype(i)=start(vtype(i)) tot=0 rgnct=0 edct=0 if(vtype(i)<=6) then l2=len+1 else l2=len-1 endif do ll=2,l2 i1=tlist(ll) i2=tlist(ll+1) isw=0 ke=abs(elist(ll+1)) if(itnode(4,i1)/=itnode(4,i2)) then rgnct=min(rgnct+1,3) isw=1 endif if(itnode(5,i1)/=itnode(5,i2)) isw=1 if(itedge(index(3,ke),i2)<0) then edct=min(edct+1,3) jb(edct)=-itedge(index(3,ke),i2) isw=1 endif if(isw==1) then tot=min(3,tot+1) iv(tot)=ll+1 endif enddo c if(vtype(i)==1) then if(tot<2) return vtype(i)=3 if(tot/=2) return if(edct>0) stop 5132 aa=abs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(abs(aa-1.0e0_rknd)it1) then if(it1+1/=it2) return if((it1/2)*2/=it1) return else if(it2+1/=it1) return if((it2/2)*2/=it2) return endif vtype(i)=5 else if(edct==2) then ie1=jb(1) ie2=jb(2) if(ibndry(7,ie1)/=ibndry(7,ie2)) return if(max(ibndry(3,ie1),ibndry(3,ie2))>0) then if(ibndry(3,ie1)/=ibndry(3,ie2)) return endif if(min(ibndry(3,ie1),ibndry(3,ie2))<0) then if(ibndry(3,ie1)/=ibndry(3,ie2)) return endif if(ibndry(3,ie1)==0) then aa=abs(cang(vlist(iv(1)),i,vlist(iv(2)),vx,vy)) if(abs(aa-1.0e0_rknd)0) then xc=sf(1,ie1) yc=sf(2,ie1) else call centre(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + vx(i),vy(i),xc,yc) endif call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xc,yc,theta1,theta2,r,alen) if(abs(theta2-theta1)<=arcmax) vtype(i)=4 endif endif else if(vtype(i)==7) then vtype(i)=8 if(tot>0) return ie1=abs(tlist(1)) ie2=abs(tlist(len+1)) if(ibndry(7,ie1)/=ibndry(7,ie2)) return if(ibndry(4,ie1)/=ibndry(4,ie2)) return if(max(ibndry(3,ie1),ibndry(3,ie2))>0) then if(ibndry(3,ie1)/=ibndry(3,ie2)) return endif if(min(ibndry(3,ie1),ibndry(3,ie2))<0) then if(ibndry(3,ie1)/=ibndry(3,ie2)) return endif if(ibndry(3,ie1)==0) then aa=abs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(abs(aa-1.0e0_rknd)=-tol) return enddo if(ibndry(3,ie1)>0) then xc=sf(1,ie1) yc=sf(2,ie1) else call centre(vx(iv(1)),vy(iv(1)),vx(iv(2)), + vy(iv(2)),vx(i),vy(i),xc,yc) endif call arc(vx(iv(1)),vy(iv(1)),vx(iv(2)),vy(iv(2)), + xc,yc,theta1,theta2,r,alen) if(abs(theta2-theta1)<=arcmax) vtype(i)=7 endif else if(vtype(i)==9) then vtype(i)=10 if(tot>0) go to 40 ie1=abs(tlist(1)) ie2=abs(tlist(len+1)) if(ibndry(4,ie1)*ibndry(4,ie2)<=0) go to 40 c if(ibndry(5,ie1)/=0.and.ibndry(5,ie2)==0) go to 40 if(ibndry(5,ie1)==0.and.ibndry(5,ie2)/=0) go to 40 if(ibndry(5,ie1)/=0) then if(abs(ibndry(5,ie1))/=abs(ibndry(5,ie2))) go to 40 it1=ibndry(6,ie1)+1 it2=ibndry(6,ie2)+1 if(it2>it1) then if(it1+1/=it2) go to 40 if((it1/2)*2/=it1) go to 40 else if(it2+1/=it1) go to 40 if((it2/2)*2/=it2) go to 40 endif endif c len1=elist(len+2) ie3=abs(tlist(len1+1)) ie4=abs(tlist(len+2)) if(ibndry(7,ie1)/=ibndry(7,ie2)) go to 40 if(ibndry(7,ie3)/=ibndry(7,ie4)) go to 40 c do ll=len+3,len1-1 i1=tlist(ll) i2=tlist(ll+1) ke=abs(elist(ll+1)) if(itnode(4,i1)/=itnode(4,i2)) go to 40 if(itnode(5,i1)/=itnode(5,i2)) go to 40 if(itedge(index(3,ke),i2)<0) go to 40 enddo c if(max(ibndry(3,ie1),ibndry(3,ie2))>0) then if(ibndry(3,ie1)/=ibndry(3,ie2)) go to 40 endif if(min(ibndry(3,ie1),ibndry(3,ie2))<0) then if(ibndry(3,ie1)/=ibndry(3,ie2)) return endif c if(ibndry(3,ie1)==0) then aa=abs(cang(vlist(2),i,vlist(len+1),vx,vy)) if(abs(aa-1.0e0_rknd)0) then xc=sf(1,ie1) yc=sf(2,ie1) else call centre(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + vx(i),vy(i),xc,yc) endif call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + xc,yc,theta1,theta2,r,alen) if(abs(theta2-theta1)<=arcmax) vtype(i)=9 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine updhp(i,len,p,q,qual,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q real(kind=rknd), dimension(*) :: qual cy c this routine makes a heap with root at vertex i, assuming its c sons are already roots of heaps c if(len<=0) return k=i if(isw==0.or.k==1) go to 10 kfath=k/2 if(qual(p(k))>qual(p(kfath))) go to 60 c c push c 10 kson=2*k if(kson>len) return if(ksonqual(p(kson))) kson=kson+1 endif if(qual(p(k))>=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==0) return if(qual(p(kfath))>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setgr(ntf,nvf,nbf,itnode,ibndry,ja,lenja) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: ja integer(kind=iknd), save, dimension(3,3) :: index cy 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=min(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)==0) cycle kmin=min(ibndry(1,i),ibndry(2,i)) ja(kmin+1)=ja(kmin+1)+1 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 j=1,3 kmax=max(itnode(index(2,j),i),itnode(index(3,j),i)) kmin=min(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)==0) then ja(jj)=kmax exit else if(ja(jj)==kmax) then exit endif enddo enddo 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setgr1(ntf,n,itdof,ja,maxja,ityp,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,itdof integer(kind=iknd), dimension(maxja) :: link integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(100) :: idof cy 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 if(ityp==1) then call l2gmap(it,idof,ndof,iord,iords,itdof) else call l2gmpl(it,idof,ndof,itdof) endif do j=1,ndof do k=j+1,ndof irow=min(idof(j),idof(k)) icol=max(idof(j),idof(k)) ilink=link(irow) 10 if(ilink==0) then if(next>maxja) return ja(next)=icol link(next)=link(irow) link(irow)=next ja(irow)=ja(irow)+1 next=next+1 else if(ja(ilink)/=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 do if(link(i)==i) exit jj=ja(i) ii=link(i) ja(i)=ja(ii) link(i)=link(ii) ja(ii)=jj link(ii)=ii enddo 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setgrb(ntf,ndf,nb,maxja,itdof,ja,ibs,ibp,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ibs,ibp integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(maxja) :: link integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(ndf) :: map cy c construct ja array c iflag=1 c c this loop inverts the ibs/ibp arrays c do i=1,nb do j=1,ibs(i) map(j+ibp(i)-1)=i enddo enddo c do i=1,nb ja(i)=0 link(i)=0 enddo next=nb+2 do it=1,ntf call l2bmap(it,idof,ndof,iord,iords,map,itdof) do j=1,ndof do k=j+1,ndof irow=min(idof(j),idof(k)) icol=max(idof(j),idof(k)) ilink=link(irow) 10 if(ilink==0) then if(next>maxja) return ja(next)=icol link(next)=link(irow) link(irow)=next ja(irow)=ja(irow)+1 next=next+1 else if(ja(ilink)/=icol) then ilink=link(ilink) go to 10 endif enddo enddo enddo c c now make new ja c jai=nb+2 do i=1,nb itemp=ja(i) ja(i)=jai jai=jai+itemp enddo ja(nb+1)=jai c do i=1,nb 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(nb+1)-1 do if(link(i)==i) exit jj=ja(i) ii=link(i) ja(i)=ja(ii) link(i)=link(ii) ja(ii)=jj link(ii)=ii enddo enddo c c sort indices c do i=1,nb len=ja(i+1)-ja(i) call ihp(ja(ja(i)),len) enddo c iflag=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkblk(ndf,ntf,nb,nsc,ibs,ibp,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(*) :: ibs,ibp integer(kind=iknd), dimension(ndf) :: mark,type,ibs0,ibp0 integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: iptr integer(kind=iknd), dimension(100) :: idof cy c compute block arrays c nb=0 nbv=0 nbe=0 nbt=0 do i=1,ndf mark(i)=0 enddo do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) c c vertices c iptr(1)=4 do j=1,3 iptr(j+1)=iptr(j)+iords(j)-1 iv=idof(j) if(mark(iv)/=0) cycle nb=nb+1 nbv=nbv+1 ibs0(nb)=1 ibp0(nb)=iv type(nb)=0 mark(iv)=nb enddo iptr(5)=ndof+1 c c edges c do j=1,3 if(iords(j)<2) cycle iv=min(idof(iptr(j)),idof(iptr(j+1)-1)) if(mark(iv)/=0) cycle nb=nb+1 nbe=nbe+1 ibs0(nb)=iptr(j+1)-iptr(j) ibp0(nb)=iv type(nb)=1 do k=iptr(j),iptr(j+1)-1 mark(idof(k))=nb enddo enddo c c element c if(iord<3) cycle iv=idof(iptr(4)) nb=nb+1 nbt=nbt+1 ibs0(nb)=iptr(5)-iptr(4) ibp0(nb)=iv type(nb)=2 do k=iptr(4),iptr(5)-1 mark(idof(k))=nb enddo c enddo c c reorder by type --- elements, edges, vertices c nsc=nbt m2=1 m1=m2+nbt m0=m1+nbe do i=1,nb if(type(i)==0) then ibs(m0)=ibs0(i) ibp(m0)=ibp0(i) m0=m0+1 else if(type(i)==1) then ibs(m1)=ibs0(i) ibp(m1)=ibp0(i) m1=m1+1 else if(type(i)==2) then ibs(m2)=ibs0(i) ibp(m2)=ibp0(i) m2=m2+1 else stop 9812 endif enddo c c this loop inverts the ibs/ibr arrays c gives block number for each unknown c c do i=1,nb c do j=1,ibs(i) c mark(j+ibp(i)-1)=i c enddo c enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp character(len=80), dimension(100) :: sp character(len=80), save, dimension(20) :: errmsg cy external sxy 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, 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: error in arc specifications ', 7 'input data error -45: error in parametric edges ', 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 ntf=ip(1) nvf=ip(2) nbf=ip(3) rl=rp(21) call xybox(nbf,vx,vy,sf,ibndry,rp(89),rp(91),rp(78), + rp(21),sxy) if(itnode(3,1)==0) then call sklchk(ntf,nvf,nbf,itnode,ibndry, + vx,vy,sf,rl,rp(78),iflag,sxy) ip(4)=0 else call trichk(ntf,nvf,nbf,itnode,ibndry, + vx,vy,sf,rl,rp(80),iflag,sxy) endif c ip(25)=iflag sp(12)(1:6)='input ' if(iflag==0) then sp(11)='input: ok' else if(iflag<=-31.and.iflag>=-32) then sp(11)=errmsg(-iflag-30) else if(iflag<=-40.and.iflag>=-48) then sp(11)=errmsg(-iflag-37) else if(iflag<=-51.and.iflag>=-55) then sp(11)=errmsg(-iflag-39) else sp(11)='input: unknown error' endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine trichk(ntf,nvf,nbf,itnode,ibndry, + vx,vy,sf,rl,area,iflag,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(2,nbf) :: ibedge real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy external sxy c c superficial check of input data c iflag=0 if(nbf<3.or.nvf<3.or.ntf<1) then iflag=-40 return endif c c check ibndry array c call bdychk(ibndry,nvf,nbf,vx,vy,sf,rl,iflag,sxy) if(iflag/=0) return c c orient triangles and boundary edges c call orient(nvf,ntf,nbf,itnode,ibndry,vx,vy,sf,iflag) if(iflag/=0) return c c compute number of regions, holes, consistency check c call cnhnr(nvf,ntf,nbf,nh,nr,ibndry,iflag) if(iflag/=0) return c c compute itedge c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) if(iflag/=0) return call ckgeom(ntf,itnode,ibndry,itedge,ibedge,vx,vy,iflag) if(iflag/=0) return call carea(ntf,itnode,itedge,ibndry,vx,vy,sf,rl,area,sxy) c c initialize region labels c do i=1,ntf itnode(4,i)=1 enddo do i=1,nbf ibndry(5,i)=0 ibndry(6,i)=0 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ckgeom(ntf,itnode,ibndry,itedge,ibedge,vx,vy,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: ibedge real(kind=rknd), dimension(*) :: vx,vy cy 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)>0) then k=itedge(j,i)/4 m=itedge(j,i)-4*k else if(itedge(j,i)<0) then iedge=-itedge(j,i) if(ibndry(4,iedge)/=0) cycle if(ibedge(1,iedge)/4==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=0.0e0_rknd) then iflag=-32 return endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cnhnr(nvf,ntf,nbf,nh,nr,ibndry,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(nvf) :: list,mark cy 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)==0) cycle nb=nb+1 list(ibndry(1,i))=ibndry(2,i) enddo c c nt+nb-2nv=2nh-2nr c id=ntf+nb-2*nvf if((id/2)*2/=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)==0) cycle if(mark(i)/=0) cycle is=is+1 next=i ic=0 10 mark(next)=is next=list(next) ic=ic+1 if(ic>nvf) return if(next/=i) go to 10 enddo c nh=id+is if((nh/2)*2/=nh) return nh=nh/2 if(nh<0) return nr=is-id if((nr/2)*2/=nr) return nr=nr/2 if(nr<1) return iflag=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine orient(nvf,ntf,nbf,itnode,ibndry,vx,vy,sf,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,nvf) :: list integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy 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<1.or.k>nvf) then iflag=-31 return endif enddo r=geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) if(r>=0.0e0_rknd) cycle itemp=itnode(2,i) itnode(2,i)=itnode(3,i) itnode(3,i)=itemp 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)==0) cycle do j=1,2 k=ibndry(j,i) if(list(1,k)==0) then list(1,k)=i else if(list(2,k)==0) then list(2,k)=i else iflag=-47 return endif enddo enddo do i=1,nvf if(list(1,i)==0) cycle if(list(2,i)==0) then iflag=-47 return 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)==0) cycle k1=list(1,j2) k2=list(2,j2) k=0 if(ibndry(1,k1)==j3) then k=k1 ibsv=ibndry(1,k1) ibndry(1,k1)=j2 ibndry(2,k1)=j3 if(ibndry(3,k1)<0.and.ibndry(1,k1)/=ibsv) then sfsv=sf(1,k1) sf(1,k1)=sf(2,k1) sf(2,k1)=sfsv endif else if(ibndry(2,k1)==j3) then k=k1 else if(ibndry(1,k2)==j3) then k=k2 ibsv=ibndry(1,k2) ibndry(1,k2)=j2 ibndry(2,k2)=j3 if(ibndry(3,k2)<0.and.ibndry(1,k2)/=ibsv) then sfsv=sf(1,k2) sf(1,k2)=sf(2,k2) sf(2,k2)=sfsv endif else if(ibndry(2,k2)==j3) then k=k2 endif enddo enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bdychk(ibndry,nvf,nbf,vx,vy,sf,rl,iflag,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(2,*) :: sf cy external sxy c c check ibndry array c iflag=0 eps=1.0e-3_rknd c c simple consistency checks c do i=1,nbf if(ibndry(1,i)<1.or.ibndry(1,i)>nvf) then iflag=-41 return endif if(ibndry(2,i)<1.or.ibndry(2,i)>nvf) then iflag=-41 return endif c if(ibndry(4,i)<0) then j=-ibndry(4,i) if(j>nbf) then iflag=-43 return endif if(ibndry(4,j)/=-i) then iflag=-43 return endif c* else c* if(ibndry(4,i)>2) then c* iflag=-43 c* return c* endif endif enddo c c do i=1,nbf c c check circle centers, arc length c if(ibndry(3,i)<=0) cycle i1=ibndry(1,i) i2=ibndry(2,i) dx=vx(i1)-vx(i2) dy=vy(i1)-vy(i2) xc=sf(1,i)-(vx(i1)+vx(i2))/2.0e0_rknd yc=sf(2,i)-(vy(i1)+vy(i2))/2.0e0_rknd if(abs(xc*dx+yc*dy)>abs(xc*dy-yc*dx)*eps) then iflag=-44 return endif call arc(vx(i1),vy(i1),vx(i2),vy(i2), + sf(1,i),sf(2,i),theta1,theta2,r,alen) aa=abs(theta1-theta2) if(aa>0.5e0_rknd+eps) then iflag=-44 return endif enddo c c check parametric edges c do i=1,nbf if(ibndry(3,i)>=0) cycle itag=-ibndry(3,i) do j=1,2 ivj=ibndry(j,i) theta=sf(j,i) do k=1,12 values(k)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) xx=values(1) yy=values(2) dx=vx(ivj)-xx dy=vy(ivj)-yy dd=max(abs(vx(ivj)),abs(vy(ivj))) if(max(abs(dx),abs(dy))>dd*eps) then iflag=-45 return endif enddo enddo c c check periodic edges...each checked twice (i/j interchanged) c do i=1,nbf if(ibndry(4,i)>=0) cycle 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)>eps*(di+dj)) then iflag=-46 return endif ic=ibndry(3,i) jc=ibndry(3,j) if(ic<=0) then if(jc>0) then iflag=-46 return endif else if(jc<=0) then iflag=-46 return endif call arc(vx(i1),vy(i1),vx(i2),vy(i2), + sf(1,i),sf(2,i),theti1,theti2,ri,ai) call arc(vx(j1),vy(j1),vx(j2),vy(j2), + sf(1,j),sf(2,j),thetj1,thetj2,rj,aj) if(abs(ri-rj)>eps*(abs(ri)+abs(rj))) then iflag=-46 return endif if(abs(ai-aj)>eps*(ai+aj)) then iflag=-46 return endif endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sklchk(ntr,nvr,nbr,itnode,ibndry, + vx,vy,sf,rl,diam,iflag,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3*nbr) :: jb real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy external sxy 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(nbr<3.or.nvr<3.or.ntr<1) then iflag=-40 return endif c c check ibndry c call bdychk(ibndry,nvr,nbr,vx,vy,sf,rl,iflag,sxy) if(iflag/=0) return c c try to make jb c do i=1,ntr if(itnode(1,i)<=0.or.itnode(1,i)>nvr) then iflag=-51 return endif if(itnode(2,i)<=0.or.itnode(1,i)>nbr) then iflag=-52 return endif enddo c call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb, + iflag,rl,sxy) if(iflag/=0) return c c now check each region c call rgnchk(ntr,itnode,ibndry,vx,vy,sf,jb,iflag,rl,sxy) if(iflag/=0) return c c check symmetry specifications c call symtst(ntr,itnode,ibndry,vx,vy,sf,jb,diam,iflag,rl,sxy) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rgnchk(ntr,itnode,ibndry,vx,vy,sf,jb,iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: jb integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(20) :: x,y,values cy external sxy c c check for counterclockwise orientientation of regions c iflag=0 pi=3.141592653589793e0_rknd 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)==0) then x(2)=vx(kb) y(2)=vy(kb) else if(ibndry(3,j)>0) then call arc(vx(kb),vy(kb),vx(kv),vy(kv), + sf(1,j),sf(2,j),thetab,thetav,r,alen) aa=abs(thetav-thetab)*8.0e0_rknd m1=max(int(aa),1) dtheta=(thetav-thetab)/real(m1+1,rknd) ang=(thetab+real(m1,rknd)*dtheta)*pi x(2)=sf(1,j)+r*cos(ang) y(2)=sf(2,j)+r*sin(ang) else if(ibndry(3,j)==0) then itag=-ibndry(3,j) if(kv==ibndry(1,j)) then thetav=sf(1,j) thetab=sf(2,j) else thetab=sf(1,j) thetav=sf(2,j) endif m1=7 dtheta=(thetav-thetab)/real(m1+1,rknd) theta=thetab+real(m1,rknd)*dtheta do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) x(2)=values(1) y(2)=values(2) endif x(3)=vx(kv) y(3)=vy(kv) last=1 bsum=2.0e0_rknd do i=i1,i2 k=jb(i) ka=ibndry(1,k)+ibndry(2,k)-kv do m=1,2 x(m)=x(last+m) y(m)=y(last+m) enddo last=1 if(ibndry(3,k)>0) then call arc(vx(kv),vy(kv),vx(ka),vy(ka), + sf(1,k),sf(2,k),thetav,thetaa,r,alen) aa=abs(thetaa-thetav)*8.0e0_rknd m1=max(int(aa),1_iknd) dtheta=(thetaa-thetav)/real(m1+1,rknd) do m=1,m1 ang=(thetav+real(m,rknd)*dtheta)*pi x(m+2)=sf(1,k)+r*cos(ang) y(m+2)=sf(2,k)+r*sin(ang) enddo last=m1+1 else if(ibndry(3,k)>0) then itag=-ibndry(3,k) if(kv==ibndry(1,k)) then thetav=sf(1,j) thetaa=sf(2,j) else thetaa=sf(1,j) thetav=sf(2,j) endif m1=7 dtheta=(thetaa-thetav)/real(m1+1,rknd) do m=1,m1 theta=thetav+real(m,rknd)*dtheta do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) x(m+2)=values(1) y(m+2)=values(2) 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_rknd enddo kv=ka enddo c c bsum = 0 for counterclockwise, bsum = 4 for clockwise c if(abs(bsum)>0.01e0_rknd) then iflag=-54 return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine symtst(ntr,itnode,ibndry,vx,vy,sf,jb,diam, + iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: jb integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(2,*) :: sf cy external sxy c c check symmetry specifications in itnode c iflag=0 num=16 eps=1.0e-3_rknd if(ntr==1) return c iflag=-55 if(itnode(3,1)/=0) return tol=(eps*diam)**2 do jr=2,ntr if(itnode(3,jr)==0) cycle ir=abs(itnode(3,jr)) if(ir>=jr) return i1=jb(ir) i2=jb(ir+1)-1 j1=jb(jr) j2=jb(jr+1)-1 if(i2-i1/=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)>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*real(inc,rknd))/dd a12=(dxi*dyj-dyi*dxj*real(inc,rknd))/dd a21=-a12*real(inc,rknd) a22=a11*real(inc,rknd) 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>tol) return c iedge=jb(i) jedge=jb(j) if(ibndry(3,iedge)==0) then if(ibndry(3,jedge)/=0) return else if(ibndry(3,iedge)>0) then if(ibndry(3,jedge)<=0) return else if(ibndry(3,iedge)<0) then if(ibndry(3,jedge)>=0) return endif if(ibndry(3,iedge)>0) then cx=a11*sf(1,jedge)+a12*sf(2,jedge) cy=a21*sf(1,jedge)+a22*sf(2,jedge) dx=cx+xx-sf(1,iedge) dy=cy+yy-sf(2,iedge) if(dx*dx+dy*dy>tol) return else if(ibndry(3,iedge)<0) then itag=-ibndry(3,iedge) if(iv==ibndry(1,iedge)) then thi1=sf(1,iedge) thi2=sf(2,iedge) else thi1=sf(2,iedge) thi2=sf(1,iedge) endif jtag=-ibndry(3,jedge) if(jv==ibndry(1,jedge)) then thj1=sf(1,jedge) thj2=sf(2,jedge) else thj1=sf(2,jedge) thj2=sf(1,jedge) endif dti=(thi2-thi1)/real(num,rknd) dtj=(thj2-thj1)/real(num,rknd) do k=1,num-1 do m=1,12 values(m)=0.0e0_rknd enddo theta=thi1+dti*real(k,rknd) call sxy(rl,theta,itag,values) xi=values(1) yi=values(2) c do m=1,12 values(m)=0.0e0_rknd enddo theta=thj1+dtj*real(k,rknd) call sxy(rl,theta,jtag,values) xj=values(1) yj=values(2) c dx=a11*xj+a12*yj+xx-xi dy=a21*xj+a22*yj+yy-yi if(dx*dx+dy*dy>tol) return c enddo endif iv=ibndry(1,iedge)+ibndry(2,iedge)-iv jv=ibndry(1,jedge)+ibndry(2,jedge)-jv j=j+inc enddo enddo iflag=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sklutl(isw,vx,vy,sf,itnode,ibndry,ip,rp,iflag,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), allocatable, dimension(:) :: jb integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp cy external sxy c c utility function for skeleton creation c ntf=ip(1) nvf=ip(2) nbf=ip(3) maxv=ip(84) maxb=ip(86) rl=rp(1) c c create an itnode array from other skeleton data c if(isw==0) then allocate(jb(3*nbf)) call makjb(nvf,nbf,ntf,vx,vy,sf,ibndry,itnode,0_iknd,jb, + iflag,rl,sxy) deallocate(jb) if(iflag/=0) return ip(1)=ntf c c divide long curved edges c else if(isw==1) then len=max(nvf,nbf) call dvedge(ntf,nvf,nbf,len,maxv,maxb,vx,vy, + sf,ibndry,itnode,iflag,rl,sxy) if(iflag/=0) return ip(2)=nvf ip(3)=nbf c c find symmetric regions in skeleton c else if(isw==2) then call fndsym(ntf,nvf,nbf,vx,vy,sf,ibndry,itnode, + iflag,rl,sxy) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dvedge(ntf,nvf,nbf,len,maxv,maxb,vx,vy, + sf,ibndry,itnode,iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(2,len) :: list real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(65) :: x,y,fi cy external sxy c iflag=0 pi=3.141592653589793e0_rknd angmax=1.0e0_rknd/8.0e0_rknd+1.0e-3_rknd num=64 lmax=6 thrsh=1.1e0_rknd c c orient boundary edges c im=1 do i=1,nvf list(1,i)=0 list(2,i)=0 if(vx(i)0) then d=abs(theta2-theta1)/angmax np=int(d) if(np<=0) cycle if(nvf+np>maxv) then iflag=84 return endif if(nbf+np>maxb) then iflag=86 return endif dt=(theta2-theta1)/real(np+1,rknd) do j=1,np arg=(theta1+dt*real(j,rknd))*pi nvf=nvf+1 vx(nvf)=sf(1,i)+radius*cos(arg) vy(nvf)=sf(2,i)+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) ibndry(7,nbf)=ibndry(7,i) sf(1,nbf)=sf(1,i) sf(2,nbf)=sf(2,i) enddo ibndry(2,nbf)=ibsave ibndry(2,i)=nvsave+1 list(1,i)=nbsave+1 list(2,i)=nbf else lev=0 30 nn=2**(lmax-lev) do j=1,num,nn a=sqrt((x(j)-x(j+nn))**2+(y(j)-y(j+nn))**2) b=(fi(j+nn)-fi(j))*alen if(b>a*thrsh) then lev=lev+1 if(levmaxv) then iflag=84 return endif if(nbf+np>maxb) then iflag=86 return endif dt=(theta2-theta1)/real(num,rknd) nn=2**(lmax-lev) ii=1 iold=i do j=1,np ii=ii+nn nvf=nvf+1 vx(nvf)=x(ii) vy(nvf)=y(ii) 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) ibndry(7,nbf)=ibndry(7,i) theta=theta1+dt*real(ii-1,rknd) sf(1,nbf)=theta sf(2,iold)=theta iold=nbf enddo sf(2,nbf)=theta2 ibndry(2,nbf)=ibsave ibndry(2,i)=nvsave+1 list(1,i)=nbsave+1 list(2,i)=nbf endif enddo c c fix itnode c do i=1,ntf k=itnode(1,i) j=itnode(2,i) if(ibndry(1,j)/=k.and.ibndry(2,j)/=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)<=0.or.j<=i) cycle ni1=list(1,i) ni2=list(2,i) c** nj1=list(1,j) nj2=list(2,j) ibndry(4,i)=-nj2 ibndry(4,j)=-ni2 num=ni2-ni1 if(num<=0) cycle do k=1,num ibndry(4,ni1+k-1)=-(nj2-k) ibndry(4,nj2-k)=-(ni1+k-1) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine fndsym(ntf,nvf,nbf,vx,vy,sf,ibndry,itnode, + iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3*nbf) :: jb integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(2) :: vmin,vmax real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(2,*) :: sf cy external sxy c c find symmetry in skeleton c iflag=0 num=16 c call makjb(nvf,nbf,ntf,vx,vy,sf,ibndry,itnode,1_iknd,jb, + iflag,rl,sxy) if(iflag/=0) return c c look for symmetry in mesh c do i=1,ntf itnode(3,i)=0 enddo if(ntf==1) return call xybox(nbf,vx,vy,sf,ibndry,vmin,vmax,diam,rl,sxy) eps=1.0e2_rknd*epsilon(1.0e0_rknd) tol=(eps*diam)**2 do ns1=1,ntf-1 if(itnode(3,ns1)/=0) cycle do ns2=ns1+1,ntf if(itnode(3,ns2)/=0) cycle i1=jb(ns1) i2=jb(ns1+1)-1 j1=jb(ns2) j2=jb(ns2+1)-1 if(i2-i1/=j2-j1) cycle c do kk=1,2 if(kk==1) inc=1 if(kk==2) inc=-1 do 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==1) then if(jj==j1) then jmedge=jb(j2) else jmedge=jb(jj-1) endif else if(jj==j2) then jmedge=jb(j1) else jmedge=jb(jj+1) endif endif if(jv1/=ibndry(1,jmedge).and.jv1/= + 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*real(inc,rknd))/dd a12=(dxi*dyj-dyi*dxj*real(inc,rknd))/dd a21=-a12*real(inc,rknd) a22=a11*real(inc,rknd) 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>tol) go to 80 c iedge=jb(i) jedge=jb(j) if(ibndry(3,iedge)==0) then if(ibndry(3,jedge)/=0) go to 80 else if(ibndry(3,iedge)>0) then if(ibndry(3,jedge)<=0) go to 80 else if(ibndry(3,iedge)<0) then if(ibndry(3,jedge)>=0) go to 80 endif if(ibndry(3,iedge)>0) then cx=a11*sf(1,jedge)+a12*sf(2,jedge) cy=a21*sf(1,jedge)+a22*sf(2,jedge) dx=cx+xx-sf(1,iedge) dy=cy+yy-sf(2,iedge) if(dx*dx+dy*dy>tol) go to 80 else if(ibndry(3,iedge)<0) then itag=-ibndry(3,iedge) if(iv==ibndry(1,iedge)) then thi1=sf(1,iedge) thi2=sf(2,iedge) else thi1=sf(2,iedge) thi2=sf(1,iedge) endif jtag=-ibndry(3,jedge) if(jv==ibndry(1,jedge)) then thj1=sf(1,jedge) thj2=sf(2,jedge) else thj1=sf(2,jedge) thj2=sf(1,jedge) endif dti=(thi2-thi1)/real(num,rknd) dtj=(thj2-thj1)/real(num,rknd) do k=1,num-1 do m=1,12 values(m)=0.0e0_rknd enddo theta=thi1+dti*real(k,rknd) call sxy(rl,theta,itag,values) xi=values(1) yi=values(2) c do m=1,12 values(m)=0.0e0_rknd enddo theta=thj1+dtj*real(k,rknd) call sxy(rl,theta,jtag,values) xj=values(1) yj=values(2) c dx=a11*xj+a12*yj+xx-xi dy=a21*xj+a22*yj+yy-yi if(dx*dx+dy*dy>tol) go to 80 c enddo endif iv=ibndry(1,iedge)+ibndry(2,iedge)-iv jv=ibndry(1,jedge)+ibndry(2,jedge)-jv j=j+inc if(j>j2) j=j1 if(j2) then numt=numt+1 ii=((iord-1)*(iord-2))/2 lenad=lenad+(ii*(ii+1))/2 lenaod=lenaod+ii*(iords(1)+iords(2)+iords(3)) endif c c edge--vertex off diagonal c leneod=leneod+2*(iords(1)+iords(2)+iords(3)-3) lenaod=lenaod+(iords(1)+iords(2)+iords(3)-3) do j=1,3 j2=index(2,j) j3=index(3,j) if(iords(j)>1) then c c edge--edge diagonal c nume=nume+1 lened=lened+((iords(j)-1)*iords(j))/2 c c edge--vertex correction for boundary c iv1=itnode(j2,i) iv2=itnode(j3,i) if(list(1,iv1)==iv2.or.list(2,iv1)==iv2) then nume=nume+1 lened=lened+((iords(j)-1)*iords(j))/2 leneod=leneod+2*(iords(j)-1) endif endif c c edge-edge off-diagonal c lenaod=lenaod+(iords(j2)-1)*(iords(j3)-1) enddo enddo nume=nume/2 lenad=lenad+lened/2 lenaod=lenaod+leneod/2 nb=nvf+nume+numt lenja=nb+2+3*nvf+6*numt+6*nume ip(90)=ndf ip(91)=nb ip(92)=lenja ip(93)=lenad ip(94)=lenaod return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clenju(ip,nb,lenja,ja,ibs) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs integer(kind=iknd), dimension(nb) :: mt,list integer(kind=iknd), dimension(lenja) :: jl cy c c compute fillin using m-tree c c convert to columns c call ja2jl(nb,ja,jl) c c initialize c do i=1,nb mt(i)=0 list(i)=0 enddo c c the main loop c lenju=nb+1 lenuod=0 do i=1,nb c c loop over seed indices in decreasing order c list(i)=i do iseed=jl(i+1)-1,jl(i),-1 k=jl(iseed) c c add a new entry to list c 20 list(k)=i lenju=lenju+1 lenuod=lenuod+ibs(i)*ibs(k) if(mt(k)==0) mt(k)=i k=mt(k) if(list(k)/=i) go to 20 enddo enddo c ip(95)=lenju+1 ip(96)=lenuod return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ja2jl(n,ja,jl) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,jl cy c compute column version of ja c do i=1,n jl(i+1)=0 enddo do i=1,n do jj=ja(i),ja(i+1)-1 j=ja(jj) jl(j+1)=jl(j+1)+1 enddo enddo jl(1)=n+2 do i=1,n jl(i+1)=jl(i+1)+jl(i) enddo do i=1,n do jj=ja(i),ja(i+1)-1 j=ja(jj) jl(jl(j))=i jl(j)=jl(j)+1 enddo enddo do i=n,1,-1 jl(i+1)=jl(i) enddo jl(1)=n+2 do i=1,n len=jl(i+1)-jl(i) if(len>1) call ihp(jl(jl(i)),len) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clnja0(ip,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: ied,iords cy data index/1,2,3,2,3,1,3,1,2/ c iprob=ip(6) if(iprob>0) then ip(99)=0 return endif ntf=ip(1) newndf=ip(30) ndd=ip(33) ndi=ip(36) nproc=ip(49) lenn=0 leni=0 lene=0 do i=1,ntf call locord(i,ndof,iord,iords,itdof) num=0 do j=1,3 i1=itdof(index(2,j),i) i2=itdof(index(3,j),i) k1=min(i1,i2) k2=max(i1,i2) ied(j)=0 if(k1<=ndd) then if(k2<=ndd) then ied(j)=iords(j)+1 num=num+1 else if(k2>newndf.and.k2<=ndi) then ied(j)=iords(j)+1 num=num+1 endif else if(k1>newndf.and.k1<=ndi) then if(k2<=ndi) then ied(j)=iords(j)+1 num=num+1 endif endif enddo numv=0 do j=1,3 i1=itdof(j,i) if(i1<=ndd) then if(ied(index(2,j))==0.and.ied(index(3,j))==0) + numv=numv+1 else if(i1>newndf.and.i1<=ndi) then if(ied(index(2,j))==0.and.ied(index(3,j))==0) + numv=numv+1 endif enddo nume=ied(1)+ied(2)+ied(3) if(num==3) nume=nume-3 if(num==2) nume=nume-1 if(num==1.and.numv==1) nume=nume+1 if(num>0) then lenn=lenn+nume-1 leni=leni+nume*(ndof-nume) lene=lene+nume*(nume-1)/2 else if(numv>0) then c c overestimate since non-interface edge dofs might c be counted more than once c leni=leni+numv*(ndof-numv) lene=lene+numv*(numv-1)/2 endif enddo c c lenn+nproc is right if every region has 1 arc, not circular. c overstimates if some are circular, underestimates if one region c has two or more arcs that are not circular lenja0=lenn+nproc+1+leni+lene/2 ip(99)=lenja0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mg(n,nb,ispd,method,mxcg,ising,eps1,ja,a, + ju,u,juc,jp,uc,ibs,ibp,ibo,dr,br,relerr,iflag,ihist) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ju,ibs,ibp, + juc,jp,ibo real(kind=rknd), dimension(*) :: a,u,dr,br,uc real(kind=rknd), dimension(n) :: r cy c iflag=0 c eps2=1.0e2_rknd*epsilon(1.0e0_rknd) eps=max(eps1,eps2) epsi=1.0e0_rknd/min(eps,eps2) c c bnorm=rl2nrm(n,br) if(bnorm==0.0e0_rknd) then do i=1,n dr(i)=0.0e0_rknd enddo return else do i=1,n r(i)=br(i)/bnorm enddo endif if(ising==1) then sum=0.0e0_rknd do i=1,n sum=sum+r(i) enddo sum=sum/real(n,rknd) do i=1,n r(i)=r(i)-sum enddo endif c if(ispd==1) then call cscg(n,nb,ispd,method,mxcg,eps,epsi,ja,a,ju,u, + juc,jp,uc,ibs,ibp,ibo,dr,r,ihist,relerr,iflag) else call csbcg(n,nb,ispd,method,mxcg,eps,epsi,ja,a,ju,u, + juc,jp,uc,ibs,ibp,ibo,dr,r,ihist,relerr,iflag) endif c if(iflag==0) then do i=1,n dr(i)=dr(i)*bnorm enddo if(ising==1) then sum=0.0e0_rknd do i=1,n sum=sum+dr(i) enddo sum=sum/real(n,rknd) do i=1,n dr(i)=dr(i)-sum enddo endif else do i=1,n dr(i)=0.0e0_rknd enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sfbilu(n,nb,ja,a,ibs,maxju,ju,maxu,u,ispd,dtol,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ju,ibs integer(kind=iknd), dimension(nb) :: list,mark,indx cc integer(kind=iknd), dimension(2,nb) :: ivf integer(kind=iknd) :: amtx,umtx integer(kind=iknd), allocatable, dimension(:) :: jap,jup real(kind=rknd), dimension(*) :: a,u real(kind=rknd), dimension(maxju) :: asz,usz cy c c sparse numeric factorization c lenja=ja(nb+1) allocate(jap(lenja)) call cjap(nb,ispd,ja,jap,ibs) c if(itype==1) then c allocate(jup(maxju)) if(ispd/=1) then amtx=jap(ja(nb+1))-jap(ja(1)) umtx=(maxu-jap(ja(1))+1)/2 maxu=maxu-umtx else amtx=0 umtx=0 endif c if(dtol>0.0e0_rknd) then rtol=max(epsilon(1.0e0_rknd),dtol)/real(n,rknd) else rtol=0.0e0_rknd endif c c block sizes for a c ju(1)=nb+2 do i=1,nb call csze(i,ja,jap,ibs,a,asz,amtx) jup(i)=jap(i) enddo jup(nb+1)=jap(nb+1) jup(nb+2)=jap(nb+2) else lenju=ju(nb+1) allocate(jup(lenju)) call cjap(nb,ispd,ju,jup,ibs) if(ispd/=1) then amtx=jap(ja(nb+1))-jap(ja(1)) umtx=jup(ju(nb+1))-jup(ju(1)) else amtx=0 umtx=0 endif endif c do i=1,nb mark(i)=0 list(i)=0 indx(i)=0 enddo c do i=1,nb ni=ibs(i) c c determine the ju array c if(itype==1) then next=ju(i) atol=rtol*asz(i) do jj=ja(i),ja(i+1)-1 if(asz(jj)<=atol) cycle j=ja(jj) mark(j)=1 ju(next)=j next=next+1 enddo c lk=list(i) 10 if(lk>0) then k=lk lk=list(k) j1=indx(k) j2=ju(k+1)-1 cc isw=0 cc if(ivf(1,k)==i.or.ivf(2,k)==i) isw=1 ccc ss=usz(j1)/usz(k) do jj=j1+1,j2 j=ju(jj) if(mark(j)/=0) cycle if(usz(jj)<=atol) cycle ccc if(ss*usz(jj)<=atol) cycle cc if(ss*usz(jj)<=atol.and.isw==0) cycle mark(j)=1 ju(next)=j next=next+1 enddo go to 10 endif c c cleanup c ju(i+1)=next len=ju(i+1)-ju(i) if(len>1) call ihp(ju(ju(i)),len) do jj=ju(i),ju(i+1)-1 jup(jj+1)=jup(jj)+ni*ibs(ju(jj)) enddo endif c c initialize row i and col i c do jj=jup(ju(i)),jup(ju(i+1))-1 u(jj)=0.0e0_rknd u(jj+umtx)=0.0e0_rknd enddo do jj=ju(i),ju(i+1)-1 mark(ju(jj))=jup(jj) enddo do m=jap(i),jap(i+1)-1 u(m)=a(m) enddo do jj=ja(i),ja(i+1)-1 j=ja(jj) if(mark(j)==0) cycle ishift=mark(j)-jap(jj) do m=jap(jj),jap(jj+1)-1 u(m+ishift)=a(m) u(m+ishift+umtx)=a(m+amtx) enddo enddo c c do outer product updates c lk=list(i) 20 if(lk>0) then k=lk lk=list(k) nk=ibs(k) if(ispd==1) then call schur1(i,k,ni,nk,ibs,ju,jup,u,mark,indx) else call schur0(i,k,ni,nk,ibs,ju,jup,u,mark,indx,umtx) endif c if(indx(k)emax0) then c emax1=emax0 c kmax1=kmax0 c emax0=usz(jj) c kmax0=j c else if(usz(jj)>emax1) then c emax1=usz(jj) c kmax1=j c endif c enddo c ivf(1,i)=kmax0 c ivf(2,i)=kmax1 enddo c c shift u for non symmetric case c if(itype==1) then maxju=ju(nb+1)-1 maxu=jup(ju(nb+1))-jup(ju(1)) if(ispd/=1) then nnz=jup(ju(nb+1))-jup(ju(1)) imtx=umtx+jup(nb+2)-1 kmtx=jup(ju(nb+1))-1 do i=1,nnz u(kmtx+i)=u(imtx+i) enddo endif endif deallocate(jap,jup) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine schur1(i,k,ni,nk,ibs,ju,jup,u,mark,indx) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ju,jup,ibs,mark,indx real(kind=rknd), dimension(*) :: u real(kind=rknd), dimension(ni) :: temp real(kind=rknd), dimension(ni+nk) :: sl1 real(kind=rknd), dimension(nk,ni) :: sl cy c j1=indx(k) j2=ju(k+1)-1 c if(nk==1) then c c both blocks are size 1 c if(ni==1) then sl11=u(jup(j1))/u(jup(k)) u(jup(i))=u(jup(i))-sl11*u(jup(j1)) do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+jz-1 u(ms)=u(ms)-sl11*u(jup(jj)+jz-1) enddo enddo else c c block k is size 1 c do iz=1,ni sl1(iz)=u(jup(j1)+iz-1)/u(jup(k)) u(jup(i)+iz-1)=u(jup(i)+iz-1) + -sl1(iz)*u(jup(j1)+iz-1) enddo c ii=jup(i)+ni do iz=1,ni-1 do jz=iz+1,ni u(ii)=u(ii)-sl1(iz)*u(jup(j1)+jz-1) ii=ii+1 enddo enddo c c update off diagonal blocks for row i using row k c do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+(jz-1)*ni-1 do iz=1,ni u(ms+iz)=u(ms+iz)-sl1(iz)*u(jup(jj)+jz-1) enddo enddo enddo endif else if(ni==1) then c c block i is size 1 c do kz=1,nk sl1(kz)=u(jup(j1)+kz-1) enddo c ir=jup(k)+nk do kz=1,nk sl1(kz)=sl1(kz)/u(jup(k)+kz-1) do jz=kz+1,nk sl1(jz)=sl1(jz)-u(ir)*sl1(kz) ir=ir+1 enddo enddo ir=ir-1 do kz=nk,1,-1 temp1=0.0e0_rknd do jz=nk,kz+1,-1 temp1=temp1+u(ir)*sl1(jz) ir=ir-1 enddo sl1(kz)=sl1(kz)-temp1/u(jup(k)+kz-1) enddo c c schur complement for diagonal block of row i c s=0.0e0_rknd do kz=1,nk s=s+sl1(kz)*u(jup(j1)+kz-1) enddo u(jup(i))=u(jup(i))-s c c update off diagonal blocks for row i using row k c do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+jz-1 ks=jup(jj)+(jz-1)*nk-1 s=0.0e0_rknd do kz=1,nk s=s+sl1(kz)*u(ks+kz) enddo u(ms)=u(ms)-s enddo enddo else c c the general case c c solve with diagonal block of row k c do iz=1,ni ks=jup(j1)+(iz-1)*nk-1 do kz=1,nk sl(kz,iz)=u(ks+kz) enddo enddo c ir=jup(k)+nk do kz=1,nk do iz=1,ni sl(kz,iz)=sl(kz,iz)/u(jup(k)+kz-1) enddo do jz=kz+1,nk do iz=1,ni sl(jz,iz)=sl(jz,iz)-u(ir)*sl(kz,iz) enddo ir=ir+1 enddo enddo ir=ir-1 do kz=nk,1,-1 do iz=1,ni temp(iz)=0.0e0_rknd enddo do jz=nk,kz+1,-1 do iz=1,ni temp(iz)=temp(iz)+u(ir)*sl(jz,iz) enddo ir=ir-1 enddo do iz=ni,1,-1 sl(kz,iz)=sl(kz,iz)-temp(iz)/u(jup(k)+kz-1) enddo enddo c c schur complement for diagonal block of row i c ii=jup(i) do iz=1,ni ks=jup(j1)+(iz-1)*nk-1 s=0.0e0_rknd do kz=1,nk s=s+sl(kz,iz)*u(ks+kz) enddo u(ii)=u(ii)-s ii=ii+1 enddo c do iz=1,ni-1 do jz=iz+1,ni ks=jup(j1)+(jz-1)*nk-1 s=0.0e0_rknd do kz=1,nk s=s+sl(kz,iz)*u(ks+kz) enddo u(ii)=u(ii)-s ii=ii+1 enddo enddo c c update off diagonal blocks for row i using row k c do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+(jz-1)*ni-1 ks=jup(jj)+(jz-1)*nk-1 do iz=1,ni s=0.0e0_rknd do kz=1,nk s=s+sl(kz,iz)*u(ks+kz) enddo u(ms+iz)=u(ms+iz)-s enddo enddo enddo endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine schur0(i,k,ni,nk,ibs,ju,jup,u,mark,indx,umtx) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ju,jup,ibs,mark,indx integer(kind=iknd) :: umtx,kmtx,imtx real(kind=rknd), dimension(*) :: u real(kind=rknd), dimension(ni) :: templ,tempu real(kind=rknd), dimension(ni+nk) :: sl1,su1 real(kind=rknd), dimension(nk,ni) :: sl,su cy c j1=indx(k) j2=ju(k+1)-1 imtx=(ni*(ni-1))/2 kmtx=(nk*(nk-1))/2 c if(nk==1) then c c both blocks are size 1 c if(ni==1) then sl11=u(jup(j1)+umtx)/u(jup(k)) su11=u(jup(j1))/u(jup(k)) u(jup(i))=u(jup(i))-sl11*u(jup(j1)) do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+jz-1 u(ms)=u(ms)-sl11*u(jup(jj)+jz-1) u(ms+umtx)=u(ms+umtx)-su11*u(jup(jj)+jz-1+umtx) enddo enddo else c c block k is size 1 c do iz=1,ni sl1(iz)=u(jup(j1)+iz-1+umtx)/u(jup(k)) su1(iz)=u(jup(j1)+iz-1)/u(jup(k)) u(jup(i)+iz-1)=u(jup(i)+iz-1) + -sl1(iz)*u(jup(j1)+iz-1) enddo c ii=jup(i)+ni do iz=1,ni-1 do jz=iz+1,ni u(ii)=u(ii) + -sl1(iz)*u(jup(j1)+jz-1) u(ii+imtx)=u(ii+imtx) + -su1(iz)*u(jup(j1)+jz-1+umtx) ii=ii+1 enddo enddo c c update off diagonal blocks for row i using row k c do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+(jz-1)*ni-1 do iz=1,ni u(ms+iz)=u(ms+iz) + -sl1(iz)*u(jup(jj)+jz-1) u(ms+iz+umtx)=u(ms+iz+umtx) + -su1(iz)*u(jup(jj)+jz-1+umtx) enddo enddo enddo endif else if(ni==1) then c c block i is size 1 c do kz=1,nk sl1(kz)=u(jup(j1)+kz-1+umtx) su1(kz)=u(jup(j1)+kz-1) enddo c ir=jup(k)+nk do kz=1,nk sl1(kz)=sl1(kz)/u(jup(k)+kz-1) su1(kz)=su1(kz)/u(jup(k)+kz-1) do jz=kz+1,nk sl1(jz)=sl1(jz)-u(ir)*sl1(kz) su1(jz)=su1(jz)-u(ir+kmtx)*su1(kz) ir=ir+1 enddo enddo ir=ir-1 do kz=nk,1,-1 templ1=0.0e0_rknd tempu1=0.0e0_rknd do jz=nk,kz+1,-1 templ1=templ1+u(ir+kmtx)*sl1(jz) tempu1=tempu1+u(ir)*su1(jz) ir=ir-1 enddo sl1(kz)=sl1(kz)-templ1/u(jup(k)+kz-1) su1(kz)=su1(kz)-tempu1/u(jup(k)+kz-1) enddo c c schur complement for diagonal block of row i c s=0.0e0_rknd do kz=1,nk s=s+sl1(kz)*u(jup(j1)+kz-1) enddo u(jup(i))=u(jup(i))-s c c update off diagonal blocks for row i using row k c do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+jz-1 ks=jup(jj)+(jz-1)*nk-1 s=0.0e0_rknd q=0.0e0_rknd do kz=1,nk s=s+sl1(kz)*u(ks+kz) q=q+su1(kz)*u(ks+kz+umtx) enddo u(ms)=u(ms)-s u(ms+umtx)=u(ms+umtx)-q enddo enddo else c c the general case c c solve with diagonal block of row k c do iz=1,ni ks=jup(j1)+(iz-1)*nk-1 do kz=1,nk sl(kz,iz)=u(ks+kz+umtx) su(kz,iz)=u(ks+kz) enddo enddo c ir=jup(k)+nk do kz=1,nk do iz=1,ni sl(kz,iz)=sl(kz,iz)/u(jup(k)+kz-1) su(kz,iz)=su(kz,iz)/u(jup(k)+kz-1) enddo do jz=kz+1,nk do iz=1,ni sl(jz,iz)=sl(jz,iz)-u(ir)*sl(kz,iz) su(jz,iz)=su(jz,iz)-u(ir+kmtx)*su(kz,iz) enddo ir=ir+1 enddo enddo ir=ir-1 do kz=nk,1,-1 do iz=1,ni templ(iz)=0.0e0_rknd tempu(iz)=0.0e0_rknd enddo do jz=nk,kz+1,-1 do iz=1,ni templ(iz)=templ(iz)+u(ir+kmtx)*sl(jz,iz) tempu(iz)=tempu(iz)+u(ir)*su(jz,iz) enddo ir=ir-1 enddo do iz=ni,1,-1 sl(kz,iz)=sl(kz,iz)-templ(iz)/u(jup(k)+kz-1) su(kz,iz)=su(kz,iz)-tempu(iz)/u(jup(k)+kz-1) enddo enddo c c schur complement for diagonal block of row i c ii=jup(i) do iz=1,ni ks=jup(j1)+(iz-1)*nk-1 s=0.0e0_rknd do kz=1,nk s=s+sl(kz,iz)*u(ks+kz) enddo u(ii)=u(ii)-s ii=ii+1 enddo c do iz=1,ni-1 do jz=iz+1,ni ks=jup(j1)+(jz-1)*nk-1 s=0.0e0_rknd q=0.0e0_rknd do kz=1,nk s=s+sl(kz,iz)*u(ks+kz) q=q+su(kz,iz)*u(ks+kz+umtx) enddo u(ii)=u(ii)-s u(ii+imtx)=u(ii+imtx)-q ii=ii+1 enddo enddo c c update off diagonal blocks for row i using row k c do jj=j1+1,j2 j=ju(jj) if(mark(j)==0) cycle do jz=1,ibs(j) ms=mark(j)+(jz-1)*ni-1 ks=jup(jj)+(jz-1)*nk-1 do iz=1,ni s=0.0e0_rknd q=0.0e0_rknd do kz=1,nk s=s+sl(kz,iz)*u(ks+kz) q=q+su(kz,iz)*u(ks+kz+umtx) enddo u(ms+iz)=u(ms+iz)-s u(ms+iz+umtx)=u(ms+iz+umtx)-q enddo enddo enddo endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine csze(i,ja,jap,ibs,a,asz,amtx) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,jap,ibs integer(kind=iknd) :: amtx real(kind=rknd), dimension(*) :: a,asz cy c compute block sizes for blocks in row i c asz(i)=0.0e0_rknd do j=1,ibs(i) asz(i)=max(abs(a(jap(i)+j-1)),asz(i)) enddo do j=ja(i),ja(i+1)-1 asz(j)=0.0e0_rknd do k=jap(j),jap(j+1)-1 asz(j)=max(abs(a(k)),abs(a(k+amtx)),asz(j)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cscg(n,nb,ispd,method,mxcg,eps,epsi,ja,a, + ju,u,juc,jp,uc,ibs,ibp,ibo,dr,br,ihist,relerr,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ju,ibs,ibp, + juc,jp,ibo real(kind=rknd), dimension(*) :: a,dr,br,u,uc real(kind=rknd), dimension(n) :: pr,apr,zr,azr cy c initialize c iflag=0 epsmin=0.5e0_rknd relerr=0.0e0_rknd c c compute initial norm of b c brnorm=rl2nrm(n,br) do i=1,n dr(i)=0.0e0_rknd enddo call hist1(ihist,0_iknd,brnorm) if(brnorm<=0.0e0_rknd) return rrnorm=brnorm c c compute initial pr and apr c call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + pr,br,ispd,method) call mtxmlt(n,nb,ja,ibs,ibp,a,pr,apr,ispd) ss=rrnorm bp=sl2ip(n,pr,br,ss) if(bp==0.0e0_rknd) return c c the main loop c do itnum=1,mxcg c c compute sigma, the next 'psuedo residual' and precondition c pap=sl2ip(n,pr,apr,ss) do i=1,n azr(i)=pap*br(i)-bp*apr(i) enddo zscale=rl2nrm(n,azr) if(zscale>0.0e0_rknd) then do i=1,n azr(i)=azr(i)/zscale enddo endif call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + zr,azr,ispd,method) c c compute alphas c bz=sl2ip(n,zr,azr,ss)*(zscale/pap) beta=bz/bp do i=1,n zr(i)=zr(i)+beta*pr(i) enddo call mtxmlt(n,nb,ja,ibs,ibp,a,zr,azr,ispd) zaz=sl2ip(n,zr,azr,ss) c c decide on pivoting strategy c if(abs(pap)epsi) go to 200 cycle 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(ihist,itnum,-rrnorm) relerr=rrnorm/brnorm cc write(6,*) -itnum,relerr if(relerr<=eps) return if(relerr>epsi) go to 200 c c compute next direction c call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + apr,br,ispd,method) bp=sl2ip(n,apr,br,ss) beta=bp/bz bp=bp*(ss/rrnorm)**2 ss=rrnorm do i=1,n pr(i)=apr(i)+beta*zr(i) enddo call mtxmlt(n,nb,ja,ibs,ibp,a,pr,apr,ispd) enddo if(relerr>epsmin) iflag=10 c return 200 iflag=10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine csbcg(n,nb,ispd,method,mxcg,eps,epsi,ja,a, + ju,u,juc,jp,uc,ibs,ibp,ibo,dr,br,ihist,relerr,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ju,ibs,ibp, + juc,jp,ibo real(kind=rknd), dimension(*) :: a,dr,br,u,uc real(kind=rknd), dimension(n) :: pr,apr,zr,azr real(kind=rknd), dimension(n) :: pl,apl,zl,azl,bl cy c initialize c iflag=0 epsmin=0.5e0_rknd relerr=0.0e0_rknd c c compute initial norm of b c brnorm=rl2nrm(n,br) do i=1,n dr(i)=0.0e0_rknd bl(i)=br(i)+brnorm*eps*(-1.0e0_rknd**i) enddo jspd=-(1+ispd) blnorm=rl2nrm(n,bl) call hist1(ihist,0_iknd,brnorm) if(min(brnorm,blnorm)<=0.0e0_rknd) return rrnorm=brnorm c c compute initial pr and apr c call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + pr,br,ispd,method) call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + pl,bl,jspd,method) call mtxmlt(n,nb,ja,ibs,ibp,a,pr,apr,ispd) call mtxmlt(n,nb,ja,ibs,ibp,a,pl,apl,jspd) ss=rrnorm bp=sl2ip(n,pl,br,ss) if(bp==0.0e0_rknd) return c c the main loop c do itnum=1,mxcg c c compute sigma, the next 'psuedo residual' and precondition c pap=sl2ip(n,pl,apr,ss) 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>0.0e0_rknd) then do i=1,n azr(i)=azr(i)/zscale azl(i)=azl(i)/zscale enddo endif call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + zr,azr,ispd,method) call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + zl,azl,jspd,method) c c compute alphas c bz=sl2ip(n,zl,azr,ss)*(zscale/pap) beta=bz/bp do i=1,n zr(i)=zr(i)+beta*pr(i) zl(i)=zl(i)+beta*pl(i) enddo call mtxmlt(n,nb,ja,ibs,ibp,a,zr,azr,ispd) call mtxmlt(n,nb,ja,ibs,ibp,a,zl,azl,jspd) zaz=sl2ip(n,zl,azr,ss) c c decide on pivoting strategy c if(abs(pap)epsi) go to 200 cycle 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(ihist,itnum,-rrnorm) relerr=rrnorm/brnorm cc write(6,*) -itnum,relerr if(relerr<=eps) return if(relerr>epsi) go to 200 c c compute next direction c call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + apr,br,ispd,method) call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,u,uc, + apl,bl,jspd,method) bp=sl2ip(n,apl,br,ss) beta=bp/bz bp=bp*(ss/rrnorm)**2 ss=rrnorm do i=1,n pr(i)=apr(i)+beta*zr(i) pl(i)=apl(i)+beta*zl(i) enddo call mtxmlt(n,nb,ja,ibs,ibp,a,pr,apr,ispd) call mtxmlt(n,nb,ja,ibs,ibp,a,pl,apl,jspd) enddo if(relerr>epsmin) iflag=10 c return 200 iflag=10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function tstpiv(n,bp,bz,pap,zaz,br,apr,azr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: br,apr,azr real(kind=rknd) :: tstpiv cy c compute norm to decide between 1x1 and 2x2 pivoting c alphap=bp*zaz alphaz=bz*pap alpha=zaz*pap qscale=0.0e0_rknd qmax=0.0e0_rknd do i=1,n dq=alpha*br(i)-(alphap*apr(i)+alphaz*azr(i)) if(abs(dq)iq) then ja(iq+1)=ja(iq+1)+1 else ja(jq+1)=ja(jq+1)+1 endif enddo enddo ja(1)=nb+2 do i=1,nb ja(i+1)=ja(i)+ja(i+1) enddo c c ja indices c do i=1,nb iq=q(i) do jj=ja0(i),ja0(i+1)-1 j=ja0(jj) jq=q(j) if(jq>iq) then ii=ja(iq) ja(ii)=jq ja(iq)=ii+1 else ii=ja(jq) ja(ii)=iq ja(jq)=ii+1 endif enddo enddo do i=nb,1,-1 ja(i+1)=ja(i) enddo ja(1)=nb+2 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ihp(list,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: list cy c reorder entries in list small to large c if(len<=1) return n=len/2 do m=n,1,-1 k=m do kson=2*k if(kson>len) exit if(kson=list(kson)) exit itemp=list(k) list(k)=list(kson) list(kson)=itemp k=kson enddo enddo c c do n=len,2,-1 itemp=list(1) list(1)=list(n) list(n)=itemp k=1 do kson=2*k if(kson>n-1) exit if(kson=list(kson)) exit itemp=list(k) list(k)=list(kson) list(kson)=itemp k=kson enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ja2jc(n,ja,jc) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,jc cy 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine jacmap(i,j,ij,ji,indx,ja,jap,amtx) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,jap integer(kind=iknd) :: amtx cy c compute location of a(i,j) and a(j,i) c if(in) go to 100 c c order vertex of min degree c 10 id=n+1-mndeg if(p(id)==0) then mndeg=mndeg+1 go to 10 endif imin=p(id) if(after(imin)>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,list,mark,equiv,ilen,imndeg,iempty) c numequ=equiv(imin) i=imin nbeg=next do ii=1,numequ p(next)=i next=next+1 equiv(i)=0 lenu=lenu+imndeg+numequ-ii i=list(i) enddo call ihp(p(nbeg),next-nbeg) if(next>n) go to 100 c c if the fillin will create a dense matrix.... c if(next+imndeg>n) then nbeg=next 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 call ihp(p(nbeg),n+1-nbeg) 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)>0) befor(after(i))=befor(i) if(befor(i)<0) then id=-befor(i) if(id>=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,list,befor,after) nvert=befor(i) ncliq=after(i) c c test for equivalence c if(nvert==0.and.ncliq==1) then nbeg=next 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 call ihp(p(nbeg),next-nbeg) endif c c look for equivalent vertices c if(nvert==0.and.ncliq==2) then jcj=-jc(jc(i)) if(mark(jcj)==0) then mark(jcj)=jx jx=jcj jlen=jlen+1 equiv(jcj)=i else ieq=equiv(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 enddo if(next>n) go to 100 c c clean up mark, move clique to jc c call svcliq(imin,jc,mark,equiv,ilen,iempty) c c update cliques c if(jlen>0) call clqupd(jx,jlen,jc,mark,list,equiv,iempty) c c degree updates c list(imin)=imndeg-numequ mndeg=max(1,list(imin)) i=imin 60 do j=jc(i),jc(i+1)-1 i=abs(jc(j)) if(jc(j)<0) go to 60 if(jc(j)==0) exit nvert=befor(i) ncliq=after(i) k1=jc(i)+nvert k2=k1+ncliq-2 ideg=nvert+list(imin)-1 do kk=k1,k2 jck=-jc(kk) ideg=ideg+after(jck) enddo c c overcounting with three cliques requires this c id=n+1-min(ideg,n-next) if(p(id)/=0) befor(p(id))=i after(i)=p(id) p(id)=i befor(i)=-id enddo c c find the next vertex c if(next<=n) go to 10 c c reversing order is specific to bank/smith bordering algorithm c cc100 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 100 do i=1,n mark(p(i))=i enddo do i=1,n p(i)=mark(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkcliq(imin,jc,list,mark,equiv,ilen,imndeg,iempty) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: jc,mark,equiv,list cy mark(imin)=imin imndeg=0 ilen=0 do j=jc(imin),jc(imin+1)-1 jcj=abs(jc(j)) if(jcj==0) return if(jc(j)>0) then c c merge a normal vertex c if(mark(jcj)==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 list(jcj)=0 mark(jcj)=iempty iempty=jcj do m=jc(jcj),jc(jcj+1)-1 jcj=abs(jc(m)) if(jc(m)<0) go to 10 if(jc(m)==0) exit if(mark(jcj)/=0) cycle mark(jcj)=mark(imin) mark(imin)=jcj imndeg=imndeg+equiv(jcj) ilen=ilen+1 enddo endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine jcupdt(imin,i,jc,mark,equiv,list,befor,after) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: jc,mark,equiv,befor integer(kind=iknd), dimension(*) :: after,list cy c update jc for vertex i c iptr=jc(i) nvert=0 ncliq=1 do j=jc(i),jc(i+1)-1 jcj=abs(jc(j)) if(jcj==0) exit if(jc(j)>0) then c c check a normal vertex c if(mark(jcj)==0) then jc(iptr)=jcj iptr=iptr+1 nvert=nvert+1 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(list(jcj)<=0) cycle if(befor(jcj)/=-imin) then befor(jcj)=-imin after(jcj)=0 jck=jcj 10 do k=jc(jck),jc(jck+1)-1 jck=abs(jc(k)) if(jc(k)<0) go to 10 if(jc(k)==0) exit if(mark(jck)<=0) + after(jcj)=after(jcj)+equiv(jck) enddo endif if(after(jcj)>0) then jc(iptr)=-jcj ncliq=ncliq+1 iptr=iptr+1 endif endif enddo jc(iptr)=-imin if(iptr+1jclast) then locsv=jclast jcsave=jc(jclast) 10 next=iempty iempty=mark(next) jcnext=jc(next) jclast=jc(next+1)-1 if(jcnext>=jclast) go to 10 jc(locsv)=-next jc(jcnext)=jcsave jcnext=jcnext+1 endif c jc(jcnext)=i jcnext=jcnext+1 c enddo mark(i)=0 if(jcnext<=jclast) jc(jcnext)=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mlf(n,lenja,ja,p,lenu) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,p integer(kind=iknd), dimension(n) :: mark,equiv,list integer(kind=iknd), dimension(2*n) :: befor,after integer(kind=iknd), dimension(2*lenja-n) :: jc cy c c minimum fillin algorithm c c list = linked list of equivalent vertices (v,e) c = size of clique (c) c equiv = number of equivalent vertices (v) c = ptr to equivant vertex (e) c = (temp) ptr to equiv vertex with clique imin (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 lenu=n+1 mndeg=n+1 imin=0 iempty=0 next=1 do i=1,n equiv(i)=1 list(i)=i befor(i)=0 befor(n+i)=n+i after(i)=0 after(n+i)=n+i mark(i)=0 enddo call ja2jc(n,ja,jc) do i=1,n ncliq=0 ideg=jc(i+1)-jc(i) if(ideg<=0) then p(next)=i next=next+1 else call filup(i,ideg,ncliq,ifill,jc,mark,equiv) ifill=max(1,ifill) ifill=min(n,ifill) id=ifill+n if(id>2*n.or.id<1) stop 1111 befor(i)=id befor(after(id))=i after(i)=after(id) after(id)=i mndeg=min(mndeg,ifill) endif enddo if(next>n) go to 100 c c order vertex of min degree c 10 id=mndeg+n if(after(id)==id) then mndeg=mndeg+1 go to 10 endif imin=after(id) after(id)=after(imin) befor(after(imin))=id befor(imin)=0 after(imin)=0 c c build the current clique (imin) c call mkcliq(imin,jc,list,mark,equiv,ilen,imndeg,iempty) c numequ=equiv(imin) i=imin nbeg=next do ii=1,numequ p(next)=i next=next+1 equiv(i)=0 lenu=lenu+imndeg+numequ-ii i=list(i) enddo call ihp(p(nbeg),next-nbeg) if(next>n) go to 100 c c if the fillin will create a dense matrix.... c if(next+imndeg>n) then nbeg=next 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 call ihp(p(nbeg),n+1-nbeg) 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(befor(i)>0) after(befor(i))=after(i) if(after(i)>0) befor(after(i))=befor(i) befor(i)=0 after(i)=0 i1=jc(i) c c update adjacency list c call jcupdt(imin,i,jc,mark,equiv,list,befor,after) nvert=befor(i) ncliq=after(i) c c test for equivalence c if(nvert==0.and.ncliq==1) then nbeg=next 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 call ihp(p(nbeg),next-nbeg) endif c c look for equivalent vertices c if(nvert==0.and.ncliq==2) then jcj=-jc(i1) if(mark(jcj)==0) then mark(jcj)=jx jx=jcj jlen=jlen+1 equiv(jcj)=i else ieq=equiv(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 look for neighbors of clique members that might c benefit from an update c if(ncliq==3) then jcj=-jc(i1+nvert+1) jcm=-jc(i1+nvert) jck=jcj 20 do k=jc(jck),jc(jck+1)-1 jck=abs(jc(k)) if(jc(k)<0) go to 20 if(jc(k)==0) exit m1=jc(jck) m2=jc(jck+1)-1 if(m2m1+1.and.jc(m1+2)/=0) cycle if(jc(m1)==-jcm.or.jc(m1+1)==-jcm) then befor(i)=-jck exit endif enddo endif c enddo if(next>n) go to 100 c c look for other outmatched vertices c i=imin do ii=1,ilen i=mark(i) if(after(i)<2.or.befor(i)<0) cycle if(after(i)==2.and.befor(i)==0) cycle i1=jc(i)+befor(i) i2=i1+after(i)-2 do j=i1,i2 jcj=-jc(j) if(mark(jcj)/=0) then after(i)=-n exit endif enddo enddo c c clean up mark, move clique to jc c call svcliq(imin,jc,mark,equiv,ilen,iempty) c c update cliques c if(jlen>0) call clqupd(jx,jlen,jc,mark,list,equiv,iempty) c c degree updates c list(imin)=imndeg-numequ c** mndeg=list(imin) i=imin 60 do j=jc(i),jc(i+1)-1 i=abs(jc(j)) if(jc(j)<0) go to 60 if(jc(j)==0) exit nvert=befor(i) ncliq=after(i) if(befor(i)<0) then ii=-befor(i) id=2*n after(i)=after(id) after(id)=i befor(i)=id befor(after(i))=i i=ii after(befor(i))=after(i) befor(after(i))=befor(i) befor(i)=0 after(i)=0 nvert=0 ncliq=2 else if(after(i)<0) then id=2*n after(i)=after(id) after(id)=i befor(i)=id befor(after(i))=i cycle endif call filup(i,nvert,ncliq,ifill,jc,mark,equiv) ifill=max(1,ifill) ifill=min(n,ifill) mndeg=min(ifill,mndeg) id=ifill+n after(i)=after(id) after(id)=i befor(i)=id befor(after(i))=i enddo c c find the next vertex c if(next<=n) go to 10 c c compute inverse permutation c 100 do i=1,n mark(p(i))=i enddo do i=1,n p(i)=mark(i) enddo return end c------------------ ----------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine filin(k,i,len,ifill,jc,mark,equiv) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: jc,mark,equiv cy c exact fillin update c l=i do j=1,len mark(l)=abs(mark(l)) l=mark(l) enddo kk=equiv(k) mark(k)=-mark(k) ifill=(kk*(kk-1))/2 do j=jc(k),jc(k+1)-1 jcj=abs(jc(j)) if(jcj==0) return if(jc(j)>0) then if(mark(jcj)>0) then ifill=ifill+equiv(jcj)*kk mark(jcj)=-mark(jcj) endif else 10 do l=jc(jcj),jc(jcj+1)-1 jcj=abs(jc(l)) if(jc(l)<0) go to 10 if(jc(l)==0) exit if(mark(jcj)>0) then ifill=ifill+equiv(jcj)*kk mark(jcj)=-mark(jcj) endif enddo endif enddo end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine filup(i,nvert,ncliq,ifill,jc,mark,equiv) c use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: jc,mark,equiv c c exact fillin update c mark(i)=i ideg=equiv(i) len=1 if(ncliq==0) then ifill=0 else i1=jc(i)+nvert i2=i1+ncliq-2 jcj=-jc(i2+1) 10 do l=jc(jcj),jc(jcj+1)-1 jcj=abs(jc(l)) if(jc(l)<0) go to 10 if(jc(l)==0) exit if(mark(jcj)==0) then mark(jcj)=mark(i) mark(i)=jcj len=len+1 ideg=ideg+equiv(jcj) endif enddo ifill=(ideg*(ideg-1))/2 if(ncliq>1) then do jj=i1,i2 jcj=-jc(jj) jdeg=0 jlen=len+1 30 do l=jc(jcj),jc(jcj+1)-1 jcj=abs(jc(l)) if(jc(l)<0) go to 30 if(jc(l)==0) exit if(mark(jcj)==0) then mark(jcj)=mark(i) mark(i)=jcj kk=equiv(jcj) jdeg=jdeg+kk call filin(jcj,i,jlen,jfill,jc,mark,equiv) ifill=ifill+jfill-(kk*(kk-1))/2 mark(i)=mark(jcj) mark(jcj)=0 endif enddo jcj=-jc(jj) ideg=ideg+jdeg ifill=ifill+(jdeg*(jdeg-1))/2 if(nvert>0.or.jj0) then i1=jc(i) i2=i1+nvert-1 do jj=i1,i2 jcj=jc(jj) mark(jcj)=mark(i) mark(i)=jcj len=len+1 ideg=ideg+equiv(jcj) call filin(jcj,i,len,jfill,jc,mark,equiv) ifill=ifill+jfill enddo endif c c clean up loop c k=i do ii=1,len ks=k k=abs(mark(k)) mark(ks)=0 enddo c ii=(ideg*(ideg-1))/2-ifill ifill=ii return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine blk3(ndf,ip,rp,vx,vy,itdof,itnode,du,dum,ja,ibs, + ibp,ibo,a,jua,ua,juac,jp,uac,b,rd,p,udot,u0dot,epsmg, 1 jflag,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jua, + ibo,juac,jp real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,du,dum,a,b,rd,p real(kind=rknd), dimension(*) :: u0dot,udot,ua,uac real(kind=rknd), dimension(ndf) :: gm real(kind=rknd), dimension(10) :: t cy ntf=ip(1) nb=ip(91) newntf=ip(27) newndf=ip(30) ising=ip(12) ispd=ip(8) method=ip(9) mxcg=ip(10) jflag=0 c c first solve c call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 du,b,reler1,jflag0,7_iknd) c c block solve c call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 dum,rd,reler2,jflag1,8_iknd) 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==1) then call mkgm(ndf,newntf,vx,vy,gm,itnode,itdof) t(1)=rl2ip(newndf,p,du) t(2)=rl2ip(newndf,p,udot) t(3)=dl2ip(newndf,udot,udot,gm,1_iknd) t(4)=dl2ip(newndf,u0dot,udot,gm,1_iknd) c call pl2ip(t,4_iknd) c pdu=t(1) pudot=t(2) udnorm=sqrt(t(3)) u0dud=t(4) else call mkgm(ndf,ntf,vx,vy,gm,itnode,itdof) pdu=rl2ip(ndf,p,du) pudot=rl2ip(ndf,p,udot) udnorm=dl2nrm(ndf,udot,gm,1_iknd) u0dud=dl2ip(ndf,u0dot,udot,gm,1_iknd) endif c c compute change in scalar c hh=thetal+thetar*(drdrl+pudot) if(hh/=0.0e0_rknd) hh=1.0e0_rknd/hh delta=-(scleqn+thetar*pdu)*hh c c compute proposed lamda-dot, rho-dot c rldot=1.0e0_rknd/sqrt(udnorm**2+1.0e0_rknd) ang=(u0dud+1.0e0_rknd)*rl0dot*rldot if(ang<0.0e0_rknd) rldot=-rldot if(abs(ang)<0.95e0_rknd.and.isw/=1) then sval=rp(25) sval0=rp(35) s1=sval*sval0 s2=rl0dot*rldot if(s1*s2<0.0e0_rknd) 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=max(abs(jflag0),abs(jflag1)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine blk4(ndf,ip,rp,du,dum,ja,ibs,ibp,ibo,a,jua, + ua,juac,jp,uac,h,b,p,dl,rd,udot,epsmg,jflag,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jua, + ibo,juac,jp real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: du,dum,a,h,b,p,dl,rd, + udot,ua,uac real(kind=rknd), dimension(ndf) :: r,hdu,hdl real(kind=rknd), dimension(5) :: t cy newndf=ip(30) nb=ip(91) ndd=ip(33) ising=ip(12) ispd=ip(8) method=ip(9) mxcg=ip(10) jflag=0 c c first solve c call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 du,b,reler1,jflag0,7_iknd) c c second solve c call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 dum,rd,reler2,jflag1,8_iknd) c c update udot c do i=1,ndf udot(i)=udot(i)+dum(i) enddo c call mtxmlt(ndf,nb,ja,ibs,ibp,h,du,hdu,1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,h,udot,hdl,1_iknd) do i=1,ndf hdu(i)=p(i)-hdu(i) enddo if(isw==1) then do i=1,ndd hdl(i)=dl(i)+dl(i+ndf)-hdl(i) enddo do i=ndd+1,ndf hdl(i)=dl(i)-hdl(i) enddo else do i=1,ndf hdl(i)=dl(i)-hdl(i) enddo endif c c compute the change in lamda c if(isw==1) then t(1)=rl2ip(newndf,dl,du) t(2)=rl2ip(newndf,udot,hdu) t(3)=rl2ip(newndf,dl,udot) t(4)=rl2ip(newndf,udot,hdl) c if(isw==1) call pl2ip(t,4_iknd) c dldu=t(1) dmhdu=t(2) dldm=t(3) dmhdl=t(4) else dldu=rl2ip(ndf,dl,du) dmhdu=rl2ip(ndf,udot,hdu) dldm=rl2ip(ndf,dl,udot) dmhdl=rl2ip(ndf,udot,hdl) endif c scleqn=rp(67) seqdot=rp(74) c1=scleqn+dldu+dmhdu c2=seqdot+dldm+dmhdl if(c2/=0.0e0_rknd) then delta=-c1/c2 else delta=0.0e0_rknd endif rp(72)=delta c c right hand sides c do i=1,ndf du(i)=du(i)+delta*udot(i) r(i)=hdu(i)+delta*hdl(i) enddo c c lagrange multiplier update c jspd=1 if(ispd/=1) jspd=-1 call mg(ndf,nb,jspd,method,mxcg,ising,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 dum,r,reler3,jflag2,9_iknd) jflag=max(abs(jflag0),abs(jflag1),abs(jflag2)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine blk5(n,ip,eps1,ja,ibs,ibp,ibo,a,h,g, + su,sm,jua,ua,juac,jp,uac,jug,ug,jbo,jugc,ugc, 1 du,dum,duc,bu,bum,buc,relerr,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jua, + jug,ibo,juac,jp,jugc,jbo integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(*) :: a,h,g,su,sm,du,dum,duc,bu, + bum,buc,ua,ug,uac,ugc real(kind=rknd), dimension(3*n) :: p,ap,z,az,b cy c c initialize c ihist=7 iflag=0 eps2=1.0e2_rknd*epsilon(1.0e0_rknd) eps=max(eps1,eps2) epsi=1.0e0_rknd/min(eps,eps2) epsmin=0.5e0_rknd relerr=0.0e0_rknd 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_rknd dum(i)=0.0e0_rknd duc(i)=0.0e0_rknd enddo bnorm=rl2nrm(n3,b) call hist1(ihist,0_iknd,bnorm) if(bnorm<=0.0e0_rknd) return rnorm=bnorm c c compute initial p and ap c call solve5(n,ip,ja,ibs,ibp,ibo,a,jua,ua,juac, + jp,uac,h,g,jug,ug,jbo,jugc,ugc,su,sm, 1 p(m1),p(m2),p(m3),b(m1),b(m2),b(m3)) call mtxml5(n,ip,ja,ibs,ibp,a,h,g,su,sm, + p(m1),p(m2),p(m3),ap(m1),ap(m2),ap(m3)) bp=rl2ip(n3,p,b) if(bp==0.0e0_rknd) return c c the main loop c do 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>0.0e0_rknd) then do i=1,n3 az(i)=az(i)/zscale enddo endif call solve5(n,ip,ja,ibs,ibp,ibo,a,jua,ua,juac, + jp,uac,h,g,jug,ug,jbo,jugc,ugc,su,sm, 1 z(m1),z(m2),z(m3),az(m1),az(m2),az(m3)) 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(n,ip,ja,ibs,ibp,a,h,g,su,sm, + z(m1),z(m2),z(m3),az(m1),az(m2),az(m3)) zaz=rl2ip(n3,z,az) c c decide on pivoting strategy c if(abs(pap)*rnormepsi) go to 200 cycle 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(ihist,itnum,-rnorm) relerr=rnorm/bnorm cc write(6,*) -itnum,relerr if(relerr<=eps) return if(relerr>epsi) go to 200 c c compute next direction c call solve5(n,ip,ja,ibs,ibp,ibo,a,jua,ua,juac, + jp,uac,h,g,jug,ug,jbo,jugc,ugc,su,sm, 1 ap(m1),ap(m2),ap(m3),b(m1),b(m2),b(m3)) bp=rl2ip(n3,ap,b) betaz=bp/bz do i=1,n3 p(i)=ap(i)+betaz*z(i) enddo call mtxml5(n,ip,ja,ibs,ibp,a,h,g,su,sm, + p(m1),p(m2),p(m3),ap(m1),ap(m2),ap(m3)) enddo if(relerr>epsmin) iflag=10 c return 200 iflag=10 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mtxml5(ndf,ip,ja,ibs,ibp,a,h,g,su,sm, + u,um,uc,au,aum,auc) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp real(kind=rknd), dimension(*) :: u,um,uc,au,aum,auc,a,h,g,su real(kind=rknd), dimension(*) :: sm real(kind=rknd), dimension(ndf) :: z cy c compute norms -- iprob=5 c ispd=ip(8) jspd=1 if(ispd/=1) jspd=-1 nb=ip(91) c c first equation c call mtxmlt(ndf,nb,ja,ibs,ibp,h,u,au,1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,a,um,aum,jspd) call mtxmlt(ndf,nb,ja,ibs,ibp,su,uc,auc,0_iknd) do i=1,ndf au(i)=au(i)+aum(i)+auc(i) enddo c c third equation c call mtxmlt(ndf,nb,ja,ibs,ibp,su,u,z,-1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,sm,um,aum,-1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,g,uc,auc,1_iknd) do i=1,ndf auc(i)=auc(i)+z(i)+aum(i) enddo c c second equation c call mtxmlt(ndf,nb,ja,ibs,ibp,a,u,aum,ispd) call mtxmlt(ndf,nb,ja,ibs,ibp,sm,uc,z,0_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine solve5(ndf,ip,ja,ibs,ibp,ibo,a,jua,ua, + juac,jp,uac,h,g,jug,ug,jbo,jugc,ugc,su,sm, 1 du,dum,duc,bu,bum,buc) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jua, + jug,ibo,juac,jp,jugc,jbo real(kind=rknd), dimension(*) :: du,dum,duc,a,h,g,su,sm,bu, + bum,buc,ua,ug,uac,ugc real(kind=rknd), dimension(ndf) :: r,r2,r3 cy ndf=ip(4) nb=ip(91) cc ising=ip(12) ispd=ip(8) method=ip(9) c jspd=1 if(ispd/=1) jspd=-1 c c first solve for du c do i=1,ndf r(i)=bum(i) enddo call hbslv(ndf,nb,ja,jp,ibs,ibp,ibo,jua,juac, + a,ua,uac,du,r,ispd,method) c c first computation for lagrange multiplier c call mtxmlt(ndf,nb,ja,ibs,ibp,h,du,r,1_iknd) do i=1,ndf r(i)=bu(i)-r(i) enddo call hbslv(ndf,nb,ja,jp,ibs,ibp,ibo,jua,juac, + a,ua,uac,dum,r,jspd,method) c c compute update for control variables c call mtxmlt(ndf,nb,ja,ibs,ibp,sm,dum,r,-1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,su,du,r2,-1_iknd) do i=1,ndf r(i)=buc(i)-r(i)-r2(i) enddo c call hbslv(ndf,nb,ja,jp,ibs,ibp,jbo,jug,jugc, + g,ug,ugc,duc,r,1_iknd,method) c c final computation for solution variables c call mtxmlt(ndf,nb,ja,ibs,ibp,sm,duc,r,0_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,r2,ispd) c do i=1,ndf r(i)=bum(i)-r(i)-r2(i) enddo call hbslv(ndf,nb,ja,jp,ibs,ibp,ibo,jua,juac, + a,ua,uac,r2,r,ispd,method) do i=1,ndf du(i)=du(i)+r2(i) enddo c c final computation for lagrange multiplier c call mtxmlt(ndf,nb,ja,ibs,ibp,h,du,r,1_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,su,duc,r2,0_iknd) call mtxmlt(ndf,nb,ja,ibs,ibp,a,dum,r3,jspd) do i=1,ndf r(i)=bu(i)-r(i)-r2(i)-r3(i) enddo c call hbslv(ndf,nb,ja,jp,ibs,ibp,ibo,jua,juac, + a,ua,uac,r2,r,jspd,method) do i=1,ndf dum(i)=dum(i)+r2(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,x,b,ispd) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ja0,ir0 integer(kind=iknd) :: umtx,lmtx,ushift,lshift integer(kind=iknd), allocatable, dimension(:) :: jap real(kind=rknd), dimension(*) :: a,a0,x,b cy 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 lenja=ja(nb+1) allocate(jap(lenja)) call cjap(nb,ispd,ja,jap,ibs) c lmtx=0 umtx=0 c do i=1,ndf b(i)=0.0e0_rknd enddo c c multiply by a0 c nn=ja0(1)-2 if(ispd==0) lmtx=ja0(nn+1)-ja0(1) if(ispd==-1) umtx=ja0(nn+1)-ja0(1) n1=ir0(1)-1 c c do i=1,ndd i0=ir0(i)-n1 b(i)=a0(i0)*x(i) enddo c c off diagonal part of a0, entry i0 corresponds to irgn c do i=1,ndd i0=ir0(i)-n1 do jj=ja0(i0),ja0(i0+1)-1 if(ja0(jj)<=0) cycle j=i2j(ja0(jj),0_iknd,ndd,newndf,ir0) b(i)=b(i)+a0(jj+umtx)*x(j) b(j)=b(j)+a0(jj+lmtx)*x(i) enddo enddo c lmtx=0 umtx=0 if(ispd==0) lmtx=jap(ja(nb+1))-jap(ja(1)) if(ispd==-1) umtx=jap(ja(nb+1))-jap(ja(1)) c c diagonal block of a c do i=1,nb if(ibp(i)<=ndd.or.ibp(i)>newndf) cycle ni=ibs(i) iv=ibp(i)-1 if(ni==1) then b(ibp(i))=b(ibp(i))+a(jap(i))*x(ibp(i)) else lshift=0 ushift=0 if(ispd==0) lshift=((ni-1)*ni)/2 if(ispd==-1) ushift=((ni-1)*ni)/2 c m=jap(i)-1 do ii=1,ni b(iv+ii)=b(iv+ii)+a(m+ii)*x(iv+ii) enddo k=jap(i)+ni do ii=1,ni-1 do jj=ii+1,ni b(iv+ii)=b(iv+ii)+a(k+ushift)*x(iv+jj) b(iv+jj)=b(iv+jj)+a(k+lshift)*x(iv+ii) k=k+1 enddo enddo endif enddo c c off diagonal blocks of a c do i=1,nb ni=ibs(i) iv=ibp(i)-1 do jj=ja(i),ja(i+1)-1 j=ja(jj) mx=max(ibp(i),ibp(j)) if(mx<=ndd.or.mx>newndf) cycle nj=ibs(j) jv=ibp(j)-1 do mm=1,nj ks=jap(jj)+(mm-1)*ni-1 do ii=1,ni b(jv+mm)=b(jv+mm)+a(ks+lmtx+ii)*x(iv+ii) b(iv+ii)=b(iv+ii)+a(ks+umtx+ii)*x(jv+mm) enddo enddo enddo enddo c deallocate(jap) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine jmpmlt(ip,ja0,a0,ir0,ui,bi,b,ispd,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja0,ir0 integer(kind=iknd), dimension(100) :: ip integer(kind=iknd) :: umtx,lmtx real(kind=rknd), dimension(*) :: a0,ui,bi,b cy 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 ndf=ip(4) newndf=ip(30) ndd=ip(33) ndi=ip(36) irgn=ip(50) c n=ja0(1)-2 lmtx=0 umtx=0 if(ispd==0) lmtx=ja0(n+1)-ja0(1) if(ispd==-1) umtx=ja0(n+1)-ja0(1) n1=ir0(1)-1 if(isw==0) go to 50 c c residual c do i=1,ndd sum=0.0e0_rknd do j=ir0(i),ir0(i+1)-1 sum=sum+bi(j-n1) enddo b(i)=sum enddo do i=newndf+1,ndi ii=i-newndf+ndd sum=0.0e0_rknd do j=ir0(ii),ir0(ii+1)-1 sum=sum+bi(j-n1) enddo b(i)=sum enddo do i=ndi+1,ndf b(i)=0.0e0_rknd enddo if(isw<0) return c c jump contribution to residual c 50 do i=1,ndd c c i is dof in actual coord c ii is dof i, irgn in interface coord c ij is dof i, jrgn in interface coord c c j/-jj is dof in actual coord c jj is dof j, jrgn in interface coord c ji is dof j, irgn in interface coord c ii=ir0(i)-n1 do m=ir0(i)+1,ir0(i+1)-1 ij=m-n1 ujmp=ui(ij)-ui(ii) b(i)=b(i)+a0(ij)*ujmp do kk=ja0(ij),ja0(ij+1)-1 jj=ja0(kk) if(jj>0) then j=i2j(jj,0_iknd,ndd,newndf,ir0) ji=i2j(j,irgn,ndd,newndf,ir0) ujmp1=ui(jj)-ui(ji) b(i)=b(i)+a0(kk+umtx)*ujmp1 b(j)=b(j)+a0(kk+lmtx)*ujmp else b(-jj)=b(-jj)+a0(kk+lmtx)*ujmp endif enddo enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine p2q2d(gp,gq,iord,jord,iords,jords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3) ::iords,jords integer(kind=iknd), dimension(5) ::iptr,jptr real(kind=rknd), dimension(3) :: c real(kind=rknd), dimension(100) ::gv,gp,gq common /pltmg1/ic(3,363),jc(12) cy c c convert 2-d function from order iord to order jord c call mkgptr(iord,iords,iptr) call mkgptr(jord,jords,jptr) c c vertices and edges c npts=iptr(5)-1 do iside=1,3 gq(iside)=gp(iside) if(iords(iside)==jords(iside)) then ishift=jptr(iside)-iptr(iside) do ipt=iptr(iside),iptr(iside+1)-1 gq(ipt+ishift)=gp(ipt) enddo else kord=jords(iside) istrt=jc(kord)+3+(kord-1)*(iside-1) istop=istrt+kord-2 ishift=jptr(iside)-istrt do ipt=istrt,istop do j=1,3 c(j)=real(ic(j,ipt),rknd)/real(kord,rknd) enddo call beval1(c,gv,iord,iords) gq(ipt+ishift)=rl2ip(npts,gv,gp) enddo endif enddo c c interior c if(iord==jord) then ishift=jptr(4)-iptr(4) do ipt=iptr(4),iptr(5)-1 gq(ipt+ishift)=gp(ipt) enddo else istrt=jc(jord)+3*jord istop=istrt+((jord-1)*(jord-2))/2-1 ishift=jptr(4)-istrt do ipt=istrt,istop do j=1,3 c(j)=real(ic(j,ipt),rknd)/real(jord,rknd) enddo call beval1(c,gv,iord,iords) gq(ipt+ishift)=rl2ip(npts,gv,gp) enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine p2q1d(gp,gq,iordp,iordq) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: ifirst=1 integer(kind=iknd), save, dimension(12) :: iptr real(kind=rknd), save, dimension(65,65) :: cb real(kind=rknd), dimension(2) :: c real(kind=rknd), dimension(20) :: v real(kind=rknd), dimension(*) :: gp,gq cy c c set up data c if(ifirst==1) then ifirst=0 mxord=10 iptr(1)=1 do mord=1,mxord iptr(mord+1)=iptr(mord)+mord+1 enddo c c evaluate all edge nodal basis functions at all edge nodes c do mord=1,mxord nfun=mord+1 do ipts=1,mxord npts=ipts+1 do ipt=1,npts c(2)=real(ipt-1,rknd)/real(npts-1,rknd) c(1)=1.0e0_rknd-c(2) call bevale(c,v,mord) do ifn=1,nfun idx=iptr(ipts)+ipt-1 jfn=iptr(mord)+ifn-1 cb(idx,jfn)=v(ifn) enddo enddo enddo enddo endif c c convert 1-d function from order iordp to order iordq c (v necessary since gp/gq may be same in calling program) c if(iordp==iordq) then do i=1,iordp+1 gq(i)=gp(i) enddo else c do i=1,iordp+1 v(i)=gp(i) enddo do ipt=iptr(iordq),iptr(iordq+1)-1 jpt=ipt-iptr(iordq)+1 gq(jpt)=0.0e0_rknd do ifun=iptr(iordp),iptr(iordp+1)-1 jfun=ifun-iptr(iordp)+1 gq(jpt)=gq(jpt)+cb(ifun,ipt)*v(jfun) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine p2p1d(g,g0,g1,iord) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: ifirst=1 integer(kind=iknd), save, dimension(12) :: iptr real(kind=rknd), save, dimension(11,55) :: cf real(kind=rknd), dimension(20) :: v1,v2 real(kind=rknd), dimension(100) :: g,g0,g1,s cy c c evaluate 1-dimensional interpolation coefficients c if(ifirst==1) then ifirst=0 mxord=10 iptr(1)=1 do mord=1,mxord m=iptr(mord) do k=1,mord do i=1,mxord+1 cf(i,m)=0.0e0_rknd enddo v1(1)=1.0e0_rknd v2(1)=1.0e0_rknd do j=1,mord v1(j+1)=v1(j)*real(2*(k-j)+1,rknd)/ + real(2*j,rknd) v2(j+1)=v2(j)*real(2*(mord-k-j)+3,rknd)/ + real(2*j,rknd) enddo do i=1,mord+1 cf(i,m)=v1(i)*v2(mord+2-i) enddo m=m+1 enddo iptr(mord+1)=m enddo endif c c interpolate from child edges onto father (fixed order) c if(g0(iord+1)/=g1(1)) stop 7723 do i=1,iord+1 s(i)=g0(i) s(iord+i)=g1(i) enddo do i=1,iord+1 g(i)=s(2*i-1) enddo do i=1,iord do j=1,iord+1 kk=i+iptr(iord)-1 g(j)=g(j)+s(2*i)*cf(j,kk) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine predct(ip,ntf,ndf,itnode,ibndry,vx,vy,sf, + u0,u0dot,rp,ibedge,idsp,mxfail,itdof, 1 a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip,ib integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,ntf) :: icurv integer(kind=iknd), dimension(ndf) :: mark integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy,u0,u0dot real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(ndf) :: u,b,gm real(kind=rknd), dimension(100) :: rp,fb,fd real(kind=rknd), dimension(200) :: fp,fdl real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu real(kind=rknd), dimension(2) :: vx0,vy0,um,uc,d1u,d2u cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c compute the step size for the next continuation step c nbf=ip(3) iprob=ip(6) ispd=ip(8) c bias=100.0e0_rknd ratmax=25.0e0_rknd step=0.25e0_rknd sh=rp(45) rl0dot=rp(33) rl0=rp(31) r0=rp(32) eps=1.0e2_rknd*epsilon(1.0e0_rknd) ratio=2.0e0_rknd*ratmax scale=1.0e0_rknd c c compute theta c call mkgm(ndf,ntf,vx,vy,gm,itnode,itdof) call ccurv(ntf,nbf,ibndry,ibedge,icurv) call ctheta(ip,rp,iflag) if(iflag/=0) then idsp=mxfail+1 return endif thetal=rp(69) thetar=rp(70) sigma=rp(71) seqdot=rp(74) if(seqdot==0.0e0_rknd.or.idsp>mxfail) then idsp=mxfail+1 return endif c isw=0 iter=-1 c c initialize c 10 iter=iter+1 if(sigma*seqdot<=0.0e0_rknd) then q=rl0dot*sigma/(seqdot-sigma/bias) else q=rl0dot*sigma/(seqdot+sigma/bias) endif if(ratio<=ratmax) q=step*q rl=rl0+q do i=1,ndf u(i)=u0(i)+q*u0dot(i) b(i)=0.0e0_rknd enddo rr=0.0e0_rknd anorm=0.0e0_rknd c c compute integrals on elements c do i=1,ntf call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,u,um,uc,d1u, + d2u,vx0,vy0,u0,u0,u0,rl,sh,sh,fa,fh,fg,fsm,fsu,fb, 1 fd,fp,fdl,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) call l2gmap(i,ib,ndof,iord,iords,itdof) rr=rr+fp(ndof+2) do k=1,ndof ivk=ib(k) anorm=max(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)<=0) then do j=1,2 if(ibedge(j,i)<=0) cycle call elebdi(i,j,itnode,ibndry,ibedge, + itdof,vx,vy,sf,u,uc,rl,fa,fh,fg, 1 fsm,fsu,fb,fd,fp,fdl,iprob,p2xy,sxy) call locord(i,ndof,iord,iords,itdof) rr=rr+fp(ndof+2) enddo endif if(ibndry(4,i)/=1) cycle call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd, 1 fp,fdl,iprob,gnxy,sxy) it=ibedge(1,i)/4 call l2gmap(it,ib,ndof,iord,iords,itdof) do k=1,ndof ivk=ib(k) b(ivk)=b(ivk)-fb(k) enddo enddo c c scalar function c scleqn=thetar*(rr-r0)+thetal*(rl-rl0)-sigma c c norm of residual c call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark) do i=1,ndf if(mark(i)/=0) b(i)=0.0e0_rknd enddo bnorm=dl2nrm(ndf,b,gm,-1_iknd) c c compute scaling c if(ratio>ratmax) then unorm=dl2nrm(ndf,u,gm,1_iknd) scale=bias d1=bnorm+anorm*unorm*10.0e0_rknd d2=abs(sigma)+abs(r0)*abs(thetar)+abs(rl0)*abs(thetal) if(min(d1,d2)>0.0e0_rknd.and.bnorm>anorm*0.001e0_rknd) + scale=bias*d1/d2 endif q=scleqn*scale bmax=max(abs(q),bnorm) if(bmax>0.0e0_rknd) then bnorm=bmax*sqrt((bnorm/bmax)**2+(q/bmax)**2) endif ratio=0.0e0_rknd if(sigma/=0.0e0_rknd) ratio=bnorm/abs(scale*sigma) c c test for sufficient decrease c if(1.0e0_rknd-ratio>eps*step.or.iter>=mxfail) then rp(71)=sigma rp(68)=scale idsp=max(idsp,iter) return else if(isw==0.and.ratio<=ratmax) then isw=1 iter=iter-1 else sigma=sigma/2.0e0_rknd endif go to 10 endif c end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine swbrch(ndf,ntf,nbf,itnode,ibndry,itdof,vx,vy, + sf,evl,evr,udot,u,u0dot,rp,ibedge, 1 ispd,a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,ntf) :: icurv integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(100) :: idof real(kind=rknd), dimension(*) :: vx,vy,u,udot,evr,evl,u0dot real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(ndf) :: p,zr,phi,zp,gm real(kind=rknd), dimension(200) :: ptm,dtm,pzr,pzp real(kind=rknd), dimension(100) :: rp,f,fzr,frl,fzp,ucm, + btm,utm real(kind=rknd), dimension(100,100) :: a,azr,atm,azp,gtm,htm cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c initialize c rl=rp(21) rldot=rp(23) rl0dot=rp(33) delta=1.0e-4_rknd sh=rp(45) iprob=3 call mkgm(ndf,ntf,vx,vy,gm,itnode,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_iknd) evld=dl2ip(ndf,evl,udot,gm,1_iknd) 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_rknd 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_rknd b11=0.0e0_rknd c1=0.0e0_rknd drdrl=0.0e0_rknd rrl=rl+delta do i=1,ntf c c compute element stiffness matrix c call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,u,utm,utm, + utm,utm,vx,vy,u,u,u,rl,sh,sh,a,htm,gtm,gtm,gtm,btm, 1 f,ptm,dtm,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,zr,utm,utm, + utm,utm,vx,vy,zr,u,u,rl,sh,sh,azr,htm,gtm,gtm,gtm,btm, 1 fzr,pzr,dtm,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,zp,utm,utm, + utm,utm,vx,vy,zp,u,u,rl,sh,sh,azp,htm,gtm,gtm,gtm,btm, 1 fzp,pzp,dtm,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,u,utm,utm, + utm,utm,vx,vy,u,u,u,rrl,sh,sh,atm,htm,gtm,gtm,gtm,btm, 1 frl,ptm,dtm,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) c c form element inner products c call l2gmap(i,idof,ndof,iord,iords,itdof) drdrl=drdrl+pzp(ndof+1)+pzr(ndof+1) do j=1,ndof ivj=idof(j) p(ivj)=p(ivj)+pzp(j)+pzr(j) s=0.0e0_rknd ss=0.0e0_rknd 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_rknd*(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)<=0) then do j=1,2 if(ibedge(j,i)<=0) cycle call elebdi(i,j,itnode,ibndry,ibedge, + itdof,vx,vy,sf,zr,ucm,rl,atm,htm,gtm, 1 gtm,gtm,btm,dtm,pzr,dtm,iprob,p2xy,sxy) call elebdi(i,j,itnode,ibndry,ibedge, + itdof,vx,vy,sf,zp,ucm,rl,atm,htm,gtm, 1 gtm,gtm,btm,dtm,pzp,dtm,iprob,p2xy,sxy) it=ibedge(j,i)/4 call l2gmap(it,idof,ndof,iord,iords,itdof) drdrl=drdrl+pzp(ndof+1)+pzr(ndof+1) do k=1,ndof ivk=idof(k) p(ivk)=p(ivk)+pzp(k)+pzr(k) enddo enddo endif c c neumann edge c if(ibndry(4,i)==1) then call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,utm,ucm,rl,a,htm,gtm,gtm,gtm,btm, 1 f,ptm,dtm,iprob,gnxy,sxy) call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,zr,utm,ucm,rl,azr,htm,gtm,gtm,gtm,btm, 1 fzr,ptm,dtm,iprob,gnxy,sxy) call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,zp,utm,ucm,rl,azp,htm,gtm,gtm,gtm,btm, 1 fzp,ptm,dtm,iprob,gnxy,sxy) call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,utm,ucm,rrl,atm,htm,gtm,gtm,gtm,btm, 1 frl,ptm,dtm,iprob,gnxy,sxy) it=ibedge(1,i)/4 call l2gmap(it,idof,ndof,iord,iords,itdof) do j=1,ndof ivj=idof(j) s=0.0e0_rknd ss=0.0e0_rknd 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_rknd*(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/=0.0e0_rknd) then if(b11>0.0e0_rknd) 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_rknd enddo endif zrnorm=dl2nrm(ndf,zr,gm,1_iknd) zpnorm=dl2nrm(ndf,zp,gm,1_iknd) ibrch=0 c c here we are trying to stay on current branch c if(isw==1) then udnorm=dl2nrm(ndf,u0dot,gm,1_iknd)*abs(rl0dot) if(udnorm>1.0e-2_rknd) then zrd=dl2ip(ndf,zr,u0dot,gm,1_iknd) zpd=dl2ip(ndf,zp,u0dot,gm,1_iknd) if(abs(zpd)*zrnorm>abs(zrd)*zpnorm) ibrch=1 else if(zrnorm>zpnorm) ibrch=1 endif else c c here we are trying to switch branches c udnorm=dl2nrm(ndf,udot,gm,1_iknd)*abs(rldot) if(udnorm>1.0e-2_rknd) then zrd=dl2ip(ndf,zr,udot,gm,1_iknd) zpd=dl2ip(ndf,zp,udot,gm,1_iknd) if(abs(zpd)*zrnorm0.0e0_rknd) then bup=bup*tol else bup=tol endif if(blw>0.0e0_rknd) then blw=blw*tol else blw=tol endif do i=1,ndf if(bdlwr(i)+blw<=bdupr(i)-bup) then u(i)=max(u(i),bdlwr(i)+blw) u(i)=min(u(i),bdupr(i)-bup) else rr=tol*(bdupr(i)-bdlwr(i)) u(i)=max(u(i),bdlwr(i)+rr) u(i)=min(u(i),bdupr(i)-rr) endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setbdl(rp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(100) :: rp cy 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_rknd uu=0.0e0_rknd if(rl>rllwr) then ru=ru+rmu/(rl-rllwr) uu=uu+rmu/(rl-rllwr)**2 endif if(rl0.0e0_rknd) return c call ccurv(ntf,nbf,ibndry,ibedge,icurv) rl=rp(21) if(iprob==7) then rl=rp(46) if(itask==10) rl=rl+max(rp(47),rp(48)) endif c do i=1,ndf u(i)=0.0e0_rknd gm(i)=0.0e0_rknd enddo if(iprob==4.or.iprob==6) then do i=1,ndf um(i)=0.0e0_rknd enddo else if(iprob==5) then do i=1,ndf um(i)=0.0e0_rknd uc(i)=0.0e0_rknd enddo endif do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) call cnode2(i,itnode,ibndry,itdof,icurv,vx,vy,sf, + xp,yp,isw,sxy) 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 xx=xp(j) yy=yp(j) do m=1,8 g(m)=0.0e0_rknd 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==4.or.iprob==6) then um(ivj)=um(ivj)+area*g(7) else if(iprob==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==4.or.iprob==6) then do i=1,ndf um(i)=um(i)/gm(i) enddo else if(iprob==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rgnsys(ntf,ndf,ip,rp,vx,vy,sf,itnode,ibndry, + ibedge,u,u0,udot,um,uc,vx0,vy0,itdof,ja, 1 ibs,ibp,a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,ir0,map0,ipath, 2 ja0,a0,h0,g0,su0,sm0,nn,a1xy,a2xy, 3 fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ja0,ir0,map0 integer(kind=iknd), dimension(ndf) :: mark,map integer(kind=iknd) :: amtx0,smtx0 integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,ntf) :: icurv integer(kind=iknd), dimension(nn+ndf) :: imark integer(kind=iknd), allocatable, dimension(:) :: js,jns real(kind=rknd), dimension(100) :: rp,fb,fd real(kind=rknd), dimension(200) :: fp,fdl real(kind=rknd), dimension(ndf) :: d1u,d2u real(kind=rknd), dimension(*) :: vx0,vy0,a,h,g,su,sm,b,d, + rd,p,dl,bdlwr,bdupr,h0,g0,su0,sm0,vx,vy,u,u0,udot,um, 1 uc,a0 real(kind=rknd), dimension(nn,6) :: gf real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu real(kind=rknd), dimension(25) :: t cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c compute stiffness matrix, right hand side, and c the derivative of the rhs with respect to lamda c c initialize c ntf=ip(1) nvf=ip(2) nbf=ip(3) irgn=ip(50) ndf=ip(4) newndf=ip(30) ndd=ip(33) ndi=ip(36) iprob=abs(ip(6)) ispd=ip(8) itask=ip(7) nm=ja0(1)-2 nb=ip(91) lenas=ip(93)+ip(94)+1 lenans=(ip(93)+ip(94))*2-ndf+1 c lenja=ja(nb+1) allocate(js(lenja),jns(lenja)) call cjap(nb,1_iknd,ja,js,ibs) call cjap(nb,0_iknd,ja,jns,ibs) c if(ispd==1) then amtx0=0 lena=lenas else amtx0=ja0(nm+1)-ja0(1) lena=lenans endif c c initialize c do i=1,lena a(i)=0.0e0_rknd enddo do i=1,ja0(nm+1)-1+amtx0 a0(i)=0.0e0_rknd enddo c c this loop inverts the ibs/ibp arrays c do i=1,nb do j=1,ibs(i) map(j+ibp(i)-1)=i enddo enddo c if(iprob==6) call cmark6(nvf,nbf,ibndry,mark) c rl=rp(21) if(abs(iprob)==7) then rl=rp(46) if(itask==10) rl=rl+max(rp(47),rp(48)) endif sh=rp(45) rmu=rp(63) do i=1,ndf b(i)=0.0e0_rknd enddo if(iprob==1) then do i=1,ndf p(i)=0.0e0_rknd enddo else if(iprob==4.or.iprob==6) then sh=rp(64) do i=1,ndf+ndd d(i)=0.0e0_rknd dl(i)=0.0e0_rknd enddo do i=1,ndf p(i)=0.0e0_rknd d1u(i)=0.0e0_rknd d2u(i)=0.0e0_rknd enddo do i=1,lenas h(i)=0.0e0_rknd enddo do i=1,ja0(nm+1)-1 h0(i)=0.0e0_rknd enddo else if(iprob==5) then sh=rp(64) smtx0=ja0(nm+1)-ja0(1) do i=1,ndf+ndd p(i)=0.0e0_rknd dl(i)=0.0e0_rknd enddo do i=1,ndf d1u(i)=0.0e0_rknd d2u(i)=0.0e0_rknd enddo do i=1,lenas g(i)=0.0e0_rknd h(i)=0.0e0_rknd enddo do i=1,lenans su(i)=0.0e0_rknd sm(i)=0.0e0_rknd enddo do i=1,ja0(nm+1)-1 g0(i)=0.0e0_rknd h0(i)=0.0e0_rknd enddo do i=1,ja0(nm+1)-1+smtx0 su0(i)=0.0e0_rknd sm0(i)=0.0e0_rknd enddo else if(iprob==3) then do i=1,ndf+ndd p(i)=0.0e0_rknd d(i)=0.0e0_rknd enddo endif c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i)/=2) cycle call eledbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,um,uc,rl,d1u,d2u,udot,iprob,gdxy,sxy) enddo c r=0.0e0_rknd drdrl=0.0e0_rknd scleqn=0.0e0_rknd seqdot=0.0e0_rknd c c assemble and update elements c call ccurv(ntf,nbf,ibndry,ibedge,icurv) do i=1,ntf call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,u,um,uc,d1u, + d2u,vx0,vy0,u0,bdlwr,bdupr,rl,sh,rmu,fa,fh,fg,fsm,fsu, 1 fb,fd,fp,fdl,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) if(iprob==6) call eleas6(i,itnode,ibndry,itdof,mark,vx,vy, + sf,u,um,rl,fp,fd,fdl,ispd,icurv,a1xy,a2xy,fxy,p1xy,sxy) jrgn=itnode(4,i) call l2gd(i,ip,itnode,itdof,map,ir0,ja,js,jns, + ibs,ja0,a,h,g,su,sm,a0,h0,g0,su0,sm0, 1 b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 2 r,drdrl,scleqn,seqdot) enddo c c boundary edges c do i=1,nbf c c functional rho c if(ibndry(5,i)<=0) then do j=1,2 if(ibedge(j,i)<=0) cycle it=ibedge(j,i)/4 jrgn=itnode(4,it) if(irgn/=jrgn) cycle if(iprob==6) then call elebd6(i,j,itnode,ibndry,ibedge, + itdof,mark,vx,vy,sf,u,rl,fa,fh,fg, 1 fsm,fsu,fb,fd,fp,fdl,p2xy,sxy) else call elebdi(i,j,itnode,ibndry,ibedge, + itdof,vx,vy,sf,u,uc,rl,fa,fh,fg,fsm, 1 fsu,fb,fd,fp,fdl,iprob,p2xy,sxy) endif call l2gd(it,ip,itnode,itdof,map,ir0,ja,js,jns, + ibs,ja0,a,h,g,su,sm,a0,h0,g0,su0,sm0, 1 b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 2 r,drdrl,scleqn,seqdot) enddo endif c c neumann edge c if(ibndry(4,i)==1) then call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd, 1 fp,fdl,iprob,gnxy,sxy) it=ibedge(1,i)/4 call l2gd(it,ip,itnode,itdof,map,ir0,ja,js,jns, + ibs,ja0,a,h,g,su,sm,a0,h0,g0,su0,sm0, 1 b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 2 r,drdrl,scleqn,seqdot) endif enddo c c modifications for bordered systems c c residual form of d-vector c if(iprob==3.or.iprob==4.or.iprob==6) then call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp, + a,ir0,ja0,a0,udot,rd,ispd) do i=1,newndf rd(i)=d(i)-rd(i) enddo do i=newndf+1,ndf rd(i)=0.0e0_rknd enddo endif c c set dirichlet boundary conditions c call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark) call cdbc0(ir0,mark,imark,ndd,newndf,ndi) do i=1,ndf if(mark(i)==1) b(i)=0.0e0_rknd enddo c c scalar function c if(iprob==4.or.iprob==6) then t(1)=r t(2)=drdrl t(3)=scleqn t(4)=seqdot call pl2ip(t,4_iknd) r=t(1) drdrl=t(2) scleqn=t(3) seqdot=t(4) else if(iprob==3) then t(1)=r t(2)=drdrl call pl2ip(t,2_iknd) r=t(1) drdrl=t(2) else t(1)=r call pl2ip(t,1_iknd) r=t(1) endif rp(22)=r c if(iprob==1.and.itask==9) then do i=1,ndf if(mark(i)==1) p(i)=0.0e0_rknd enddo else if(iprob==4.or.iprob==6) then do i=1,ndf if(mark(i)/=1) cycle d(i)=0.0e0_rknd rd(i)=0.0e0_rknd dl(i)=0.0e0_rknd p(i)=0.0e0_rknd if(i>ndd) cycle d(i+ndf)=0.0e0_rknd dl(i+ndf)=0.0e0_rknd enddo rp(67)=scleqn rp(74)=seqdot call setbdl(rp) else if(iprob==5) then do i=1,ndf if(mark(i)==1) p(i)=0.0e0_rknd enddo else if(iprob==3) then do i=1,ndf if(mark(i)/=1) cycle d(i)=0.0e0_rknd rd(i)=0.0e0_rknd p(i)=0.0e0_rknd if(i>ndd) cycle d(i+ndf)=0.0e0_rknd p(i+ndf)=0.0e0_rknd 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 matrix boundary conditions c anorm=0.0e0_rknd if(ispd==1) then do i=1,nb do m=1,ibs(i) anorm=max(anorm,abs(a(js(i)+m-1))) enddo enddo else do i=1,nb do m=1,ibs(i) anorm=max(anorm,abs(a(jns(i)+m-1))) enddo enddo endif if(anorm<=0.0e0_rknd) anorm=1.0e0_rknd rp(55)=anorm c call cdbcb(nb,nbf,itdof,ibndry,ibedge,mark,map) call mtxdbc(nb,ja,ibs,a,anorm,mark,ispd,1_iknd) call mt0dbc(nm,ja0,a0,amtx0,mark,imark,1_iknd) c if(iprob==4.or.iprob==6) then call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,mark,1_iknd,1_iknd) call mt0dbc(nm,ja0,h0,0_iknd,mark,imark,1_iknd) else if(iprob==5) then call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,mark,1_iknd,1_iknd) call mtxdbc(nb,ja,ibs,sm,0.0e0_rknd,mark,0_iknd,0_iknd) call mtxdbc(nb,ja,ibs,su,0.0e0_rknd,mark,0_iknd,0_iknd) call mt0dbc(nm,ja0,h0,0_iknd,mark,imark,1_iknd) call mt0dbc(nm,ja0,sm0,smtx0,mark,imark,0_iknd) call mt0dbc(nm,ja0,su0,smtx0,mark,imark,0_iknd) endif c c finish rhs c ii=ipath(3,irgn)-1 if(iprob==1.and.itask==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==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==4.or.iprob==6) 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==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 c call exbdy(ipath,ir0,map0,gf,nn,num) call jmpmlt(ip,ja0,a0,ir0,gf(1,2),gf(1,1),b,ispd,1_iknd) jspd=1 if(ispd/=1) jspd=-1 if(iprob==1.and.itask==9) then call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),p,jspd,1_iknd) else if(iprob==3) then call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),rd,ispd,1_iknd) else if(iprob==4.or.iprob==6) then call jmpmlt(ip,ja0,h0,ir0,gf(1,2),gf(1,3),p,1_iknd,0_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),p,jspd,1_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,6),gf(1,5),rd,ispd,1_iknd) else if(iprob==5) then call jmpmlt(ip,ja0,sm0,ir0,gf(1,6),gf(1,1),b,0_iknd,0_iknd) call jmpmlt(ip,ja0,g0,ir0,gf(1,6),gf(1,5),dl,1_iknd,1_iknd) call jmpmlt(ip,ja0,sm0,ir0,gf(1,4),gf(1,5),dl, + -1_iknd,0_iknd) call jmpmlt(ip,ja0,su0,ir0,gf(1,2),gf(1,5),dl, + -1_iknd,0_iknd) call jmpmlt(ip,ja0,a0,ir0,gf(1,4),gf(1,3),p,jspd,1_iknd) call jmpmlt(ip,ja0,h0,ir0,gf(1,2),gf(1,3),p,1_iknd,0_iknd) call jmpmlt(ip,ja0,su0,ir0,gf(1,6),gf(1,3),p,0_iknd,0_iknd) endif c deallocate(js,jns) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2gd(itri,ip,itnode,itdof,map,ir0,ja,js,jns, + ibs,ja0,a,h,g,su,sm,a0,h0,g0,su0,sm0,b,d,p,dl,fa,fh,fg, 1 fsm,fsu,fb,fd,fp,fdl,r,drdrl,scleqn,seqdot) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,js,jns,ibs,map, + ir0,ja0 integer(kind=iknd) :: amtx0 integer(kind=iknd), dimension(5) :: iptr integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: ib,ib0,ip integer(kind=iknd), dimension(100,100) :: is,ins,ia0 integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(*) :: a,h,b,d,p,dl,a0,h0,g,g0,su real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu real(kind=rknd), dimension(100) :: fb,fd real(kind=rknd), dimension(200) :: fp,fdl real(kind=rknd), dimension(*) :: su0,sm,sm0 cy c update global matrices/vectors from element matrices/vectors c irgn=ip(50) jrgn=itnode(4,itri) ndf=ip(4) ispd=ip(8) newndf=ip(30) ndd=ip(33) iprob=abs(ip(6)) c call l2g0(itri,ip,itdof,map,ja,js,jns,ibs,iptr,ib,is,ins) ndof=iptr(5)-1 c c interface matrices c nm=ja0(1)-2 amtx0=ja0(nm+1)-ja0(1) if(irgn==jrgn) then do k=1,ndof ib0(k)=ib(k) enddo else do k=1,ndof ivk=ib(k) if(ivk<=ndd) then ib0(k)=-(ivk+ndf) else ib0(k)=-ivk endif enddo endif c do k=1,ndof ivk=ib(k) if(ivk<=ndd) then ivkb=i2j(ivk,jrgn,ndd,newndf,ir0) ia0(k,k)=ivkb else ivkb=-ivk ia0(k,k)=0 endif do j=k+1,ndof ivj=ib(j) if(ivj<=ndd) then ivjb=i2j(ivj,jrgn,ndd,newndf,ir0) else ivjb=-ivj endif if(max(ivjb,ivkb)>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 c if(irgn==jrgn) r=r+fp(ndof+2) if(iprob==2) then do k=1,ndof kk=ib0(k) if(kk>0) then b(kk)=b(kk)-fp(k) else if (-kk<=ndf) then b(-kk)=b(-kk)-fp(ndof+2+k) endif if(ispd==1) then do j=k,ndof a(is(j,k))=a(is(j,k))+fh(j,k) jk=min(ia0(k,j),ia0(j,k)) if(jk>0) a0(jk)=a0(jk)+fh(j,k) enddo else do j=1,ndof a(ins(j,k))=a(ins(j,k))+fh(j,k) jk=ia0(j,k) if(jk>0) a0(jk)=a0(jk)+fh(j,k) enddo endif enddo else do k=1,ndof if(ib0(k)>0) b(ib0(k))=b(ib0(k))-fb(k) if(ispd==1) then do j=k,ndof a(is(j,k))=a(is(j,k))+fa(j,k) jk=min(ia0(k,j),ia0(j,k)) if(jk>0) a0(jk)=a0(jk)+fa(j,k) enddo else do j=1,ndof a(ins(j,k))=a(ins(j,k))+fa(j,k) jk=ia0(j,k) if(jk>0) a0(jk)=a0(jk)+fa(j,k) enddo endif enddo endif c if(iprob==1) then do k=1,ndof if(ib0(k)>0) p(ib0(k))=p(ib0(k))+fp(k) enddo else if(iprob==4.or.iprob==6) then if(irgn==jrgn) then scleqn=scleqn-fp(ndof+1) seqdot=seqdot-fdl(ndof+1) endif do k=1,ndof kk=ib0(k) if(kk>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 h(is(j,k))=h(is(j,k))+fh(j,k) jk=min(ia0(k,j),ia0(j,k)) if(jk>0) h0(jk)=h0(jk)+fh(j,k) enddo enddo else if(iprob==5) then do k=1,ndof kk=ib0(k) if(kk>0) then p(kk)=p(kk)-fp(k) dl(kk)=dl(kk)-fdl(k) else if (-kk<=ndf) then dl(-kk)=dl(-kk)-fdl(ndof+2+k) endif do j=1,ndof sm(ins(j,k))=sm(ins(j,k))+fsm(j,k) su(ins(j,k))=su(ins(j,k))+fsu(j,k) jk=ia0(j,k) if(jk>0) then sm0(jk)=sm0(jk)+fsm(j,k) su0(jk)=su0(jk)+fsu(j,k) endif enddo do j=k,ndof h(is(j,k))=h(is(j,k))+fh(j,k) g(is(j,k))=g(is(j,k))+fg(j,k) jk=min(ia0(k,j),ia0(j,k)) if(jk>0) then h0(jk)=h0(jk)+fh(j,k) g0(jk)=g0(jk)+fg(j,k) endif enddo enddo else if(iprob==3) then if(irgn==jrgn) drdrl=drdrl+fp(ndof+1) do k=1,ndof kk=ib0(k) if(kk>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine linsys(ntf,ndf,ip,rp,vx,vy,sf,itnode,ibndry,ibedge, + u,u0,udot,um,uc,vx0,vy0,itdof,ja,ibs,ibp, 1 a,h,g,su,sm,b,d,rd,p,dl,bdlwr,bdupr,a1xy,a2xy, 2 fxy,gnxy,gdxy,p1xy,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: ja,ibs,ibp integer(kind=iknd), dimension(ndf) :: mark,map integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,ntf) :: icurv integer(kind=iknd), allocatable, dimension(:) :: js,jns real(kind=rknd), dimension(100) :: rp,fb,fd real(kind=rknd), dimension(200) :: fp,fdl real(kind=rknd), dimension(ndf) :: d1u,d2u real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(*) :: vx,vy,u,u0,udot,um,uc, + vx0,vy0,a,h,g,su,sm,b,p,dl,bdlwr,bdupr,d,rd real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu cy external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy c c compute stiffness matrix, right hand side, and c the derivative of the rhs with respect to lamda c c initialize c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) iprob=ip(6) ispd=ip(8) itask=ip(7) nb=ip(91) lenas=ip(93)+ip(94) lenans=(ip(93)+ip(94))*2-ndf c lenja=ja(nb+1) allocate(js(lenja),jns(lenja)) call cjap(nb,1_iknd,ja,js,ibs) call cjap(nb,0_iknd,ja,jns,ibs) c if(ispd==1) then lena=lenas else lena=lenans endif c c initialize c do i=1,lena a(i)=0.0e0_rknd enddo c c this loop inverts the ibs/ibp arrays c do i=1,nb do j=1,ibs(i) map(j+ibp(i)-1)=i enddo enddo c if(iprob==6) call cmark6(nvf,nbf,ibndry,mark) c rl=rp(21) if(abs(iprob)==7) then rl=rp(46) if(itask==10) rl=rl+max(rp(47),rp(48)) endif sh=rp(45) rmu=rp(63) do i=1,ndf b(i)=0.0e0_rknd enddo if(iprob==1) then do i=1,ndf p(i)=0.0e0_rknd enddo else if(iprob==4.or.iprob==6) then sh=rp(64) do i=1,ndf p(i)=0.0e0_rknd d(i)=0.0e0_rknd dl(i)=0.0e0_rknd d1u(i)=0.0e0_rknd d2u(i)=0.0e0_rknd enddo do i=1,lenas h(i)=0.0e0_rknd enddo else if(iprob==5) then sh=rp(64) do i=1,ndf dl(i)=0.0e0_rknd p(i)=0.0e0_rknd d1u(i)=0.0e0_rknd d2u(i)=0.0e0_rknd enddo do i=1,lenas h(i)=0.0e0_rknd g(i)=0.0e0_rknd enddo do i=1,lenans su(i)=0.0e0_rknd sm(i)=0.0e0_rknd enddo elseif(iprob==3) then do i=1,ndf p(i)=0.0e0_rknd d(i)=0.0e0_rknd enddo endif c c dirichlet boundary conditions c do i=1,nbf if(ibndry(4,i)/=2) cycle call eledbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,um,uc,rl,d1u,d2u,udot,iprob,gdxy,sxy) enddo c r=0.0e0_rknd drdrl=0.0e0_rknd scleqn=0.0e0_rknd seqdot=0.0e0_rknd c c assemble and update elements c call ccurv(ntf,nbf,ibndry,ibedge,icurv) do i=1,ntf call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,u,um,uc,d1u, + d2u,vx0,vy0,u0,bdlwr,bdupr,rl,sh,rmu,fa,fh,fg,fsm,fsu, 1 fb,fd,fp,fdl,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) if(iprob==6) call eleas6(i,itnode,ibndry,itdof,mark,vx,vy, + sf,u,um,rl,fp,fd,fdl,ispd,icurv,a1xy,a2xy,fxy,p1xy,sxy) call l2g(i,ip,itdof,map,ja,js,jns,ibs,a,h,g, + su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 r,drdrl,scleqn,seqdot) enddo c c boundary edges c do i=1,nbf c c functional rho c if(ibndry(5,i)<=0) then do j=1,2 if(ibedge(j,i)<=0) cycle it=ibedge(j,i)/4 if(iprob==6) then call elebd6(i,j,itnode,ibndry,ibedge, + itdof,mark,vx,vy,sf,u,rl,fa,fh,fg, 1 fsm,fsu,fb,fd,fp,fdl,p2xy,sxy) else call elebdi(i,j,itnode,ibndry,ibedge, + itdof,vx,vy,sf,u,uc,rl,fa,fh,fg,fsm, 1 fsu,fb,fd,fp,fdl,iprob,p2xy,sxy) endif call l2g(it,ip,itdof,map,ja,js,jns,ibs,a,h,g, + su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 r,drdrl,scleqn,seqdot) enddo endif c c neumann edge c if(ibndry(4,i)==1) then call elenbc(i,itnode,ibndry,ibedge,itdof,vx,vy, + sf,u,um,uc,rl,fa,fh,fg,fsm,fsu,fb,fd, 1 fp,fdl,iprob,gnxy,sxy) it=ibedge(1,i)/4 call l2g(it,ip,itdof,map,ja,js,jns,ibs,a,h,g, + su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 r,drdrl,scleqn,seqdot) c endif enddo c c modifications for bordered systems c c residual form of d-vector c if(iprob==3.or.iprob==4.or.iprob==6) then call mtxmlt(ndf,nb,ja,ibs,ibp,a,udot,rd,ispd) do i=1,ndf rd(i)=d(i)-rd(i) enddo endif c c coarse grid matrix c c set dirichlet boundary conditions c rp(22)=r call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark) do i=1,ndf if(mark(i)==1) b(i)=0.0e0_rknd enddo if(iprob==1.and.itask==9) then do i=1,ndf if(mark(i)==1) p(i)=0.0e0_rknd enddo else if(iprob==4.or.iprob==6) then do i=1,ndf if(mark(i)/=1) cycle d(i)=0.0e0_rknd rd(i)=0.0e0_rknd dl(i)=0.0e0_rknd p(i)=0.0e0_rknd enddo rp(67)=scleqn rp(74)=seqdot call setbdl(rp) elseif(iprob==5) then do i=1,ndf if(mark(i)==1) p(i)=0.0e0_rknd enddo elseif(iprob==3) then do i=1,ndf if(mark(i)/=1) cycle d(i)=0.0e0_rknd rd(i)=0.0e0_rknd p(i)=0.0e0_rknd 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 matrix boundary conditions c anorm=0.0e0_rknd if(ispd==1) then do i=1,nb do m=1,ibs(i) anorm=max(anorm,abs(a(js(i)+m-1))) enddo enddo else do i=1,nb do m=1,ibs(i) anorm=max(anorm,abs(a(jns(i)+m-1))) enddo enddo endif if(anorm<=0.0e0_rknd) anorm=1.0e0_rknd rp(55)=anorm c call cdbcb(nb,nbf,itdof,ibndry,ibedge,mark,map) call mtxdbc(nb,ja,ibs,a,anorm,mark,ispd,1_iknd) if(iprob==4.or.iprob==6) then call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,mark,1_iknd,1_iknd) elseif(iprob==5) then call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,mark,1_iknd,1_iknd) call mtxdbc(nb,ja,ibs,sm,0.0e0_rknd,mark,0_iknd,0_iknd) call mtxdbc(nb,ja,ibs,su,0.0e0_rknd,mark,0_iknd,0_iknd) endif c deallocate(js,jns) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdbc(ndf,nbf,itdof,ibndry,ibedge,mark) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(*) :: mark cy 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)/=2) cycle call l2gmpe(i,ibedge,iord,idof,itdof) do j=1,iord+1 mark(idof(j))=1 enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdbcb(nb,nbf,itdof,ibndry,ibedge,mark,map) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(*) :: mark,map cy c this routine marks dirichlet boundary points c do i=1,nb mark(i)=0 enddo c do i=1,nbf if(ibndry(4,i)/=2) cycle call l2gmpe(i,ibedge,iord,idof,itdof) do j=1,iord+1 mark(map(idof(j)))=1 enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mtxdbc(nb,ja,ibs,a,anorm,mark,ispd,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja,mark,ibs integer(kind=iknd), allocatable, dimension(:) :: jap integer(kind=iknd) :: amtx real(kind=rknd), dimension(*) :: a cy c set matrix dirichlet boundary conditions c c isw= 1 do both rows and columns c isw= 0 do just rows c isw=-1 do just columns c lenja=ja(nb+1) allocate(jap(lenja)) call cjap(nb,ispd,ja,jap,ibs) c if(ispd==1) then amtx=0 else amtx=jap(ja(nb+1))-jap(ja(1)) endif c do i=1,nb ni=ibs(i) if(mark(i)==1) then do m=jap(i),jap(i+1)-1 a(m)=0.0e0_rknd enddo if(isw==1) then do m=jap(i),jap(i)+ni-1 a(m)=anorm enddo endif endif do jj=ja(i),ja(i+1)-1 j=ja(jj) if(mark(i)==1) then if(isw/=-1) then do m=jap(jj),jap(jj+1)-1 a(m)=0.0e0_rknd enddo endif if(isw/=0) then do m=jap(jj)+amtx,jap(jj+1)-1+amtx a(m)=0.0e0_rknd enddo endif endif if(mark(j)==1) then if(isw/=0) then do m=jap(jj),jap(jj+1)-1 a(m)=0.0e0_rknd enddo endif if(isw/=-1) then do m=jap(jj)+amtx,jap(jj+1)-1+amtx a(m)=0.0e0_rknd enddo endif endif enddo enddo deallocate(jap) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdbc0(ir0,mark,imark,ndd,newndf,ndi) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: mark,ir0,imark cy c set matrix dirichlet boundary conditions for interface matrix c n1=ndd+ndi-newndf n=ir0(n1+1)-ir0(1) do i=1,n imark(i)=0 enddo do i=1,n1 if(i<=ndd) then if(mark(i)/=1) cycle else if(mark(i-ndd+newndf)/=1) cycle endif do j=ir0(i),ir0(i+1)-1 imark(j)=1 enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mt0dbc(n,ja0,a0,amtx,mark,imark,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja0,mark,imark integer(kind=iknd) :: amtx real(kind=rknd), dimension(*) :: a0 cy c set matrix dirichlet boundary conditions for interface matrix c c isw= 1 do both rows and columns c isw= 0 do just rows c isw=-1 do just columna c do i=1,n if(imark(i)==1) a0(i)=0.0e0_rknd do jj=ja0(i),ja0(i+1)-1 if(imark(i)==1) then if(isw/=-1) a0(jj)=0.0e0_rknd if(isw/=0) a0(jj+amtx)=0.0e0_rknd endif if(ja0(jj)>0) then mj=imark(ja0(jj)) else mj=mark(-ja0(jj)) endif if(mj==1) then if(isw/=0) a0(jj)=0.0e0_rknd if(isw/=-1) a0(jj+amtx)=0.0e0_rknd endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2g(itri,ip,itdof,map,ja,js,jns,ibs,a,h,g, + su,sm,b,d,p,dl,fa,fh,fg,fsm,fsu,fb,fd,fp,fdl, 1 r,drdrl,scleqn,seqdot) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ib,ip integer(kind=iknd), dimension(100,100) :: is,ins integer(kind=iknd), dimension(*) :: ja,map,ibs,js,jns integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(5) :: iptr real(kind=rknd), dimension(*) :: a,h,b,d,p,dl,g,su,sm real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu real(kind=rknd), dimension(100) :: fb,fd real(kind=rknd), dimension(200) :: fp,fdl cy c update global matrices/vectors from element matrices/vectors c iprob=ip(6) ispd=ip(8) c call l2g0(itri,ip,itdof,map,ja,js,jns,ibs,iptr,ib,is,ins) ndof=iptr(5)-1 c r=r+fp(ndof+2) if(iprob==2) then do k=1,ndof b(ib(k))=b(ib(k))-fp(k) if(ispd==1) then do j=k,ndof a(is(j,k))=a(is(j,k))+fh(j,k) enddo else do j=1,ndof a(ins(j,k))=a(ins(j,k))+fh(j,k) enddo endif enddo else do k=1,ndof b(ib(k))=b(ib(k))-fb(k) if(ispd==1) then do j=k,ndof a(is(j,k))=a(is(j,k))+fa(j,k) enddo else do j=1,ndof a(ins(j,k))=a(ins(j,k))+fa(j,k) enddo endif enddo endif c if(iprob==1) then do k=1,ndof p(ib(k))=p(ib(k))+fp(k) enddo else if(iprob==4.or.iprob==6) then scleqn=scleqn-fp(ndof+1) seqdot=seqdot-fdl(ndof+1) 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 h(is(j,k))=h(is(j,k))+fh(j,k) enddo enddo else if(iprob==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(ins(j,k))=sm(ins(j,k))+fsm(j,k) su(ins(j,k))=su(ins(j,k))+fsu(j,k) enddo do j=k,ndof h(is(j,k))=h(is(j,k))+fh(j,k) g(is(j,k))=g(is(j,k))+fg(j,k) enddo enddo else if(iprob==3) then drdrl=drdrl+fp(ndof+1) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2g0(itri,ip,itdof,map,ja,js,jns,ibs,iptr,ib,is,ins) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ib,ip integer(kind=iknd), dimension(100,100) :: is,ins integer(kind=iknd), dimension(*) :: ja,map,js,jns,ibs integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: iptr integer(kind=iknd) :: amtx cy c local to global mapping for interger arrays c nb=ip(91) c call l2gmap(itri,ib,ndof,iord,iords,itdof) amtx=jns(ja(nb+1))-jns(ja(1)) c iptr(1)=4 do j=1,3 iptr(j+1)=iptr(j)+iords(j)-1 enddo iptr(5)=iptr(4)+((iord-1)*(iord-2))/2 c do k=1,3 c c vertex-vertex blocks c kd=map(ib(k)) call setdia(is,ins,k,1_iknd,1_iknd,js(kd),jns(kd)) do j=k+1,3 jd=map(ib(j)) call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx) if(kdib(iptr(j))) then inc=1 else inc=-1 endif if(kd2) then jd=map(ib(iptr(4))) call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx) if(kd1) then kd=map(ib(iptr(k))) if(ib(iptr(k+1)-1)>ib(iptr(k))) then kinc=1 else kinc=-1 endif call setdia(is,ins,iptr(k),ibs(kd),kinc,js(kd),jns(kd)) do j=k+1,3 if(iords(j)<2) cycle jd=map(ib(iptr(j))) if(ib(iptr(j+1)-1)>ib(iptr(j))) then jinc=1 else jinc=-1 endif call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx) if(kd2) then jd=map(ib(iptr(4))) call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx) if(kd2) then kd=map(ib(iptr(4))) call setdia(is,ins,iptr(4),ibs(kd),1_iknd,js(kd),jns(kd)) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setia(is,ins,iak,iaj,klen,jlen,kinc,jinc,kjs,kj,jk) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100,100) :: is,ins cy if(jlen==1) then c c the case jlen=klen=1 c if(klen==1) then ins(iak,iaj)=kj ins(iaj,iak)=jk is(iak,iaj)=kjs is(iaj,iak)=kjs c c the case jlen=1 c else if(kinc==1) then krow=iak else krow=iak+klen-1 endif do kk=1,klen ins(krow,iaj)=kj+kk-1 ins(iaj,krow)=jk+kk-1 is(krow,iaj)=kjs+kk-1 is(iaj,krow)=kjs+kk-1 krow=krow+kinc enddo endif else c c the case klen=1 c if(klen==1) then if(jinc==1) then jcol=iaj else jcol=iaj+jlen-1 endif do jj=1,jlen ins(iak,jcol)=kj+jj-1 ins(jcol,iak)=jk+jj-1 is(iak,jcol)=kjs+jj-1 is(jcol,iak)=kjs+jj-1 jcol=jcol+jinc enddo else c c the general case c ii=0 do jj=1,jlen if(jinc==1) then jcol=iaj+jj-1 else jcol=iaj+jlen-jj endif if(kinc==1) then krow=iak else krow=iak+klen-1 endif do kk=1,klen ins(krow,jcol)=kj+ii ins(jcol,krow)=jk+ii is(krow,jcol)=kjs+ii is(jcol,krow)=kjs+ii ii=ii+1 krow=krow+kinc enddo enddo endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setdia(is,ins,iak,klen,kinc,kd,knd) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100,100) :: is,ins,js,jns cy c row i, col j of lower triangle c col i, row j of upper triangle c i+(j-1)*n-((j+1)*j)/2 (+n to shift for diag) c if(klen==1) then ins(iak,iak)=knd is(iak,iak)=kd else c ishift=((klen-1)*klen)/2 c k=knd m=kd do i=1,klen jns(i,i)=k k=k+1 js(i,i)=m m=m+1 enddo do i=1,klen-1 do j=i+1,klen jns(i,j)=k jns(j,i)=k+ishift k=k+1 js(i,j)=m js(j,i)=m m=m+1 enddo enddo c if(kinc==1) then do i=1,klen do j=1,klen ins(iak+i-1,iak+j-1)=jns(i,j) is(iak+i-1,iak+j-1)=js(i,j) enddo enddo else do i=1,klen do j=1,klen ins(iak+i-1,iak+j-1)=jns(klen+1-i,klen+1-j) is(iak+i-1,iak+j-1)=js(klen+1-i,klen+1-j) enddo enddo endif endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkdof(ntf,nvf,nbf,ip,itnode,ibndry,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(nvf) :: mark,iequv integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), save, dimension(3,3) :: index cy data index/1,2,3,2,3,1,3,1,2/ c ntf=ip(1) nvf=ip(2) nbf=ip(3) iord=ip(5) c c label vertices c ndf=0 call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) call cequv1(nvf,nbf,ibndry,iequv,1_iknd) do i=1,nvf if(iequv(i)==i) then ndf=ndf+1 mark(i)=ndf else mark(i)=mark(iequv(i)) endif enddo c itdof8=iord+16*iord+256*iord+4096*iord do i=1,ntf do j=1,3 itdof(j,i)=mark(itnode(j,i)) enddo do j=4,7 itdof(j,i)=0 enddo itdof(8,i)=itdof8 if(iord==1) cycle c c check edges c do j=1,3 if(itedge(j,i)>0) then k=itedge(j,i)/4 if(k>i) then itdof(3+j,i)=ndf+1 ndf=ndf+iord-1 cycle endif m=itedge(j,i)-4*k else if(itedge(j,i)<0) then iedge=-itedge(j,i) if(ibndry(4,iedge)>=1) then itdof(3+j,i)=ndf+1 ndf=ndf+iord-1 cycle endif js=1 if(ibndry(4,iedge)==0) then if(ibedge(js,iedge)/4==i) js=2 else iedge=-ibndry(4,iedge) endif k=ibedge(js,iedge)/4 if(k>i) then itdof(3+j,i)=ndf+1 ndf=ndf+iord-1 cycle endif m=ibedge(js,iedge)-4*k else stop 6432 endif c if(itdof(index(3,m),k)/=itdof(index(2,j),i)) stop 6434 if(itdof(index(2,m),k)/=itdof(index(3,j),i)) stop 6435 c itdof(3+j,i)=-(itdof(3+m,k)+iord-2) enddo if(iord<3) cycle itdof(7,i)=ndf+1 ndf=ndf+((iord-1)*(iord-2))/2 enddo c ip(4)=ndf return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2gmpl(itri,idof,ndof,itldof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: idof integer(kind=iknd), dimension(4,*) :: itldof cy c compute degree of freedom for element itri c ndof=3 do j=1,3 idof(j)=itldof(j,itri) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine locord(itri,ndof,iord,iords,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords cy c compute degree of freedom for element itri c k=itdof(8,itri)/16 iord=itdof(8,itri)-16*k ndof=((iord-1)*(iord-2))/2 do j=1,3 kk=k/16 iords(j)=k-16*kk ndof=ndof+iords(j) k=kk enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2gmap(itri,idof,ndof,iord,iords,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: idof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: iptr cy c compute degree of freedom for element itri c k=itdof(8,itri)/16 iord=itdof(8,itri)-16*k iptr(1)=4 c do j=1,3 kk=k/16 iords(j)=k-16*kk iptr(j+1)=iptr(j)+iords(j)-1 idof(j)=itdof(j,itri) k=kk enddo iptr(5)=iptr(4)+((iord-1)*(iord-2))/2 ndof=iptr(5)-1 c if(ndof<=3) return do j=1,3 jstrt=iptr(j) jstop=iptr(j+1)-1 if(itdof(3+j,itri)>0) then do jj=jstrt,jstop idof(jj)=itdof(3+j,itri)+jj-jstrt enddo else do jj=jstrt,jstop idof(jj)=-(itdof(3+j,itri)+jj-jstrt) enddo endif enddo jstrt=iptr(4) do jj=jstrt,ndof idof(jj)=itdof(7,itri)+jj-jstrt enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine g2lmap(itri,idof,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: idof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: iptr integer(kind=iknd), save, dimension(3,3) :: index cy data index/1,2,3,2,3,1,3,1,2/ c c global to local map of degrees of freedom c k=itdof(8,itri)/16 iord=itdof(8,itri)-16*k iptr(1)=4 c do j=1,3 kk=k/16 iords(j)=k-16*kk itdof(j,itri)=idof(j) iptr(j+1)=iptr(j)+iords(j)-1 k=kk enddo iptr(5)=iptr(4)+((iord-1)*(iord-2))/2 ndof=iptr(5)-1 if(ndof<=3) return c do j=1,3 jstrt=iptr(j) jstop=iptr(j+1)-1 if(iords(j)<2) then cycle else if(iords(j)==2) then j2=index(2,j) j3=index(3,j) if(itdof(j2,itri)=idof(jstrt)) then if(idof(jstop)-idof(jstrt)/=iords(j)-2) stop 5264 itdof(3+j,itri)=idof(jstrt) else if(idof(jstrt)-idof(jstop)/=iords(j)-2) stop 5265 itdof(3+j,itri)=-idof(jstrt) endif endif enddo if(iptr(5)>iptr(4)) then itdof(7,itri)=idof(iptr(4)) else itdof(7,itri)=0 endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2bmap(itri,idof,ndof,iord,iords,map,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: idof,map integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords cy c compute block degrees of freedom for element itri c k=itdof(8,itri)/16 iord=itdof(8,itri)-16*k c ndof=3 do j=1,3 idof(j)=map(itdof(j,itri)) kk=k/16 iords(j)=k-16*kk k=kk if(iords(j)>=2) then ndof=ndof+1 idof(ndof)=map(abs(itdof(j+3,itri))) if(itdof(3+j,itri)<0) iords(j)=-iords(j) endif enddo if(iord>=3) then ndof=ndof+1 idof(ndof)=map(itdof(7,itri)) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine l2gmpe(iedge,ibedge,iord,idof,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), save, dimension(3,3) :: index cy 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) call locord(it,ndof,jord,iords,itdof) iord=iords(ied) c idof(1)=itdof(i2,it) idof(iord+1)=itdof(i3,it) if(iord==1) return if(itdof(3+ied,it)>0) then do j=2,iord idof(j)=itdof(3+ied,it)+j-2 enddo else do j=2,iord idof(j)=-(itdof(3+ied,it)+j-2) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkgptr(iord,iords,iptr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5) :: iptr integer(kind=iknd), dimension(3) :: iords c c make iptr from iords c iptr(1)=4 do iside=1,3 if(iords(iside)0) then do i=2,iord idof(i)=is is=is+1 enddo else do i=2,iord idof(i)=-is is=is+1 enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine g2lpth(iseg,idof,ndof,ipath) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: idof integer(kind=iknd), dimension(6,*) :: ipath cy c compute degree of freedom for edge iseg c iord=ndof-1 ipath(3,iseg)=idof(1) ipath(4,iseg)=idof(ndof) ipath(5,iseg)=0 ipath(6,iseg)=iord if(iord>1) then ipath(5,iseg)=idof(2) if(idof(3)2) ipath(5,iseg)=-idof(2) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eleasm(itri,itnode,ibndry,itdof,vx,vy,sf,u,um,uc,d1u, + d2u,vx0,vy0,u0,bdlwr,bdupr,rl,sh,rmu,a,h,g,sm,su,b,d,p,dl, 1 ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(5,5) :: map integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: icurv integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy,u,um,uc,d1u,d2u real(kind=rknd), dimension(*) :: vx0,vy0,u0,bdlwr,bdupr real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100,100) :: a,h,g,sm,su real(kind=rknd), dimension(100) :: b,d,gv,gx,gy,gxx,gxy real(kind=rknd), dimension(100) :: gyy,xp,yp real(kind=rknd), dimension(200) :: p,dl real(kind=rknd), dimension(15) :: ca1,ca2,cf,cp1 real(kind=rknd), dimension(3) :: tx,ty,x,y,xn,yn real(kind=rknd), dimension(5) :: bx1,by1,bx2,by2,d11,d12,d21 real(kind=rknd), dimension(5) :: d22,a10,s,a11,a12,a20,a21 real(kind=rknd), dimension(5) :: a22,b1,b2,r common /pltmg3/c(3,746),wt(746),np2(22) cy external a1xy,a2xy,fxy,p1xy,sxy data map/1,2,3,4,5,2,6,9,10,12,3,9,7,11,13, + 4,10,11,8,14,5,12,13,14,15/ c c this routine computes the element stiffness matrix and c right hand side c c 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 call l2gmap(itri,idof,ndof,iord,iords,itdof) irule=2*max(iord,iords(1),iords(2),iords(3)) 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 cnode2(itri,itnode,ibndry,itdof,icurv,vx,vy,sf, + xp,yp,isw,sxy) c do i=1,ndof b(i)=0.0e0_rknd d(i)=0.0e0_rknd p(i)=0.0e0_rknd dl(i)=0.0e0_rknd do j=1,ndof a(i,j)=0.0e0_rknd h(i,j)=0.0e0_rknd g(i,j)=0.0e0_rknd sm(i,j)=0.0e0_rknd su(i,j)=0.0e0_rknd enddo enddo p(ndof+1)=0.0e0_rknd p(ndof+2)=0.0e0_rknd dl(ndof+1)=0.0e0_rknd dl(ndof+2)=0.0e0_rknd c det=abs(det)/2.0e0_rknd c do i=np2(irule),np2(irule+1)-1 c c evaluate basis functions c call beval(c(1,i),x,y,gv,gx,gy,iord,iords) if(isw==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_rknd p12=0.0e0_rknd p21=0.0e0_rknd p22=0.0e0_rknd xx=0.0e0_rknd yy=0.0e0_rknd 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,iords) we=wt(i)*det*abs(detn) endif c c function evaluations c uu=0.0e0_rknd ux=0.0e0_rknd uy=0.0e0_rknd 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>=4.and.iprob<=6) then umu=0.0e0_rknd umx=0.0e0_rknd umy=0.0e0_rknd d1=0.0e0_rknd d1x=0.0e0_rknd d1y=0.0e0_rknd d2=0.0e0_rknd d2x=0.0e0_rknd d2y=0.0e0_rknd 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==5) then ucu=0.0e0_rknd ucx=0.0e0_rknd ucy=0.0e0_rknd 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 cc we1=we*det*sh*rmu we1=we*det*sh we2=we1*det else rr=rl endif do k=1,15 ca1(k)=0.0e0_rknd ca2(k)=0.0e0_rknd cp1(k)=0.0e0_rknd cf(k)=0.0e0_rknd 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==7) 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_rknd 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_rknd if(ispd==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_rknd a11(k)=0.0e0_rknd a12(k)=0.0e0_rknd a20(k)=0.0e0_rknd a21(k)=0.0e0_rknd a22(k)=0.0e0_rknd b1(k)=0.0e0_rknd b2(k)=0.0e0_rknd 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 qq=sqrt(a11(1)**2+a12(1)**2+a21(1)**2+a22(1)**2) rr=sqrt(ca1(2)**2+ca2(2)**2+cf(3)**2+cf(4)**2) dd=sqrt(det) qq=qq*dd/(1.0e0_rknd+qq/(rr*dd)+(dd*rr)/qq) 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 c 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==5.or.qq>0.0e0_rknd) then if(isw==0) then call beval2(c(1,i),x,y,gxx,gxy,gyy,iord,iords) else call beval2(c(1,i),xn,yn,gxx,gxy,gyy,iord,iords) endif endif c c update rho c p(ndof+2)=p(ndof+2)+cp1(1)*we c c adjust derivatives c if(iprob>=4.and.iprob<=6) 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(ndof+2)=dl(ndof+2)+cp1(1)*we p(ndof+1)=p(ndof+1)+cp1(5)*we dl(ndof+1)=dl(ndof+1)+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>0.0e0_rknd.and.iord>1) then uxx=0.0e0_rknd uxy=0.0e0_rknd uyy=0.0e0_rknd 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==5) then dl(k)=dl(k)+cp1(5)*qv cc + +we1*(qx*ucx+qy*ucy) 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) cc + +we1*(qx*gx(j)+qy*gy(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>1) then ucxx=0.0e0_rknd ucxy=0.0e0_rknd ucyy=0.0e0_rknd 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 rr2=we2*abs(cp1(15)) qxx=rr2*gxx(k) qxy=rr2*gxy(k) qyy=rr2*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==2.or.iprob==4.or.iprob==6) 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==1) then do k=1,ndof ss=0.0e0_rknd do j=1,ndof ss=ss+a(j,k)*um(idof(j)) enddo p(k)=p(k)-ss enddo else if(iprob==2) then det=det/6.0e0_rknd do k=1,ndof ru=0.0e0_rknd uu=0.0e0_rknd j=idof(k) if(u(j)>bdlwr(j)) then ru=ru+rmu/(u(j)-bdlwr(j)) uu=uu+rmu/(u(j)-bdlwr(j))**2 endif if(u(j)bdlwr(j)) then ru=ru+rmu/(uc(j)-bdlwr(j)) uu=uu+rmu/(uc(j)-bdlwr(j))**2 endif if(uc(j)0) isw=isw+1 enddo if(iord>1) then call cnode0(c,iord,iords) do j=4,ndof xp(j)=xp(1)*c(1,j)+xp(2)*c(2,j)+xp(3)*c(3,j) yp(j)=yp(1)*c(1,j)+yp(2)*c(2,j)+yp(3)*c(3,j) enddo else isw=0 endif if(isw==0) return c call mkgptr(iord,iords,lptr) c c c curved edge c pi=3.141592653589793e0_rknd do j=1,3 if(icurv(j,itri)==0) cycle j2=index(2,j) j3=index(3,j) iedge=icurv(j,itri) if(ibndry(3,iedge)>0) then call arc(xp(j2),yp(j2),xp(j3),yp(j3), + sf(1,iedge),sf(2,iedge),theta2,theta3,rad,hh) do k=lptr(j),lptr(j+1)-1 tt=(c(j2,k)*theta2+c(j3,k)*theta3)*pi xp(k)=sf(1,iedge)+rad*cos(tt) yp(k)=sf(2,iedge)+rad*sin(tt) enddo else itag=-ibndry(3,iedge) k2=1 if(ibndry(1,iedge)/=itnode(j2,itri)) k2=2 k3=3-k2 theta2=sf(k2,iedge) theta3=sf(k3,iedge) do k=lptr(j),lptr(j+1)-1 tt=c(j2,k)*theta2+c(j3,k)*theta3 do m=1,12 values(m)=0.0e0_rknd enddo call sxy(rl,tt,itag,values) xp(k)=values(1) yp(k)=values(2) enddo endif enddo if(iord<=2) return c c compute node locations (for iso-parametric mapping) c do j=1,3 iords0(j)=iord enddo call cnode0(c,iord,iords0) nndof=((iord+1)*(iord+2))/2 do j=1,nndof xt(j)=xp(1)*c(1,j)+xp(2)*c(2,j)+xp(3)*c(3,j) yt(j)=yp(1)*c(1,j)+yp(2)*c(2,j)+yp(3)*c(3,j) enddo c c process curved edge c do j=1,3 if(icurv(j,itri)<=0) cycle j2=index(2,j) j3=index(3,j) iedge=icurv(j,itri) if(ibndry(3,iedge)>0) then call arc(xp(j2),yp(j2),xp(j3),yp(j3), + sf(1,iedge),sf(2,iedge),theta2,theta3,rad,hh) kstrt=4+(j-1)*(iord-1) kstop=kstrt+iord-2 do k=kstrt,kstop tt=(c(j2,k)*theta2+c(j3,k)*theta3)*pi xt(k)=sf(1,iedge)+rad*cos(tt) yt(k)=sf(2,iedge)+rad*sin(tt) enddo else itag=-ibndry(3,iedge) k2=1 if(ibndry(1,iedge)/=itnode(j2,itri)) k2=2 k3=3-k2 theta2=sf(k2,iedge) theta3=sf(k3,iedge) kstrt=4+(j-1)*(iord-1) kstop=kstrt+iord-2 do k=kstrt,kstop tt=c(j2,k)*theta2+c(j3,k)*theta3 do m=1,12 values(m)=0.0e0_rknd enddo call sxy(rl,tt,itag,values) xt(k)=values(1) yt(k)=values(2) enddo endif enddo c c smooth interior points c do i=jc(iord),jc(iord+1)-1 map(ic(2,i)+1,ic(3,i)+1)=i-jc(iord)+1 enddo itmax=iord do itnum=1,itmax do j=2,iord-1 do i=2,iord-j+1 xt(map(i,j))=(xt(map(i+1,j))+xt(map(i-1,j))+ + xt(map(i,j+1))+xt(map(i,j-1))+ 1 xt(map(i-1,j+1))+xt(map(i+1,j-1)))/6.0e0_rknd yt(map(i,j))=(yt(map(i+1,j))+yt(map(i-1,j))+ + yt(map(i,j+1))+yt(map(i,j-1))+ 1 yt(map(i-1,j+1))+yt(map(i+1,j-1)))/6.0e0_rknd enddo enddo enddo c c move smoothed points back to xp and yp c ishift=nndof-ndof do i=lptr(4),ndof xp(i)=xt(i+ishift) yp(i)=yt(i+ishift) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cnode1(iedge,iside,itnode,ibndry,ibedge,vx,vy,sf, + rl,npts,c,xp,yp,xn,yn,h,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(*) :: vx,vy,xp,yp,xn,yn real(kind=rknd), dimension(3,*) :: c cy data index/1,2,3,2,3,1,3,1,2/ external sxy c c compute node locations for edge iedge c ktri=ibedge(iside,iedge)/4 kside=ibedge(iside,iedge)-4*ktri k1=index(2,kside) k2=index(3,kside) iv1=itnode(k1,ktri) iv2=itnode(k2,ktri) kc=ibndry(3,iedge) pi=3.141592653589793e0_rknd dx=vx(iv2)-vx(iv1) dy=vy(iv2)-vy(iv1) c c c if(kc==0) then h=sqrt(dx**2+dy**2) do i=1,npts c1=c(1,i) c2=c(2,i) xp(i)=c1*vx(iv1)+c2*vx(iv2) yp(i)=c(1,i)*vy(iv1)+c(2,i)*vy(iv2) xn(i)=dy/h yn(i)=-dx/h c(k1,i)=c1 c(k2,i)=c2 c(kside,i)=0.0e0_rknd enddo else if(kc>0) then call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + sf(1,iedge),sf(2,iedge),theta1,theta2,rad,h) do i=1,npts tt=(c(1,i)*theta1+c(2,i)*theta2)*pi xn(i)=cos(tt) yn(i)=sin(tt) xp(i)=sf(1,iedge)+rad*xn(i) yp(i)=sf(2,iedge)+rad*yn(i) call bari(xp(i),yp(i),vx,vy,itnode(1,ktri),c(1,i)) if(dx*xn(i)+dy*yn(i)<0.0e0_rknd) then xn(i)=-xn(i) yn(i)=-yn(i) endif enddo else itag=-kc if(ibndry(1,iedge)==iv1) then theta1=sf(1,iedge) theta2=sf(2,iedge) else theta1=sf(2,iedge) theta2=sf(1,iedge) endif do i=1,npts tt=c(1,i)*theta1+c(2,i)*theta2 do m=1,12 values(i)=0.0e0 enddo call sxy(rl,tt,itag,values) xp(i)=values(1) yp(i)=values(2) ss=sqrt(values(3)**2+values(4)**2) xn(i)=values(4)/ss yn(i)=-values(3)/ss call bari(xp(i),yp(i),vx,vy,itnode(1,ktri),c(1,i)) if(dx*xn(i)+dy*yn(i)<0.0e0_rknd) then xn(i)=-xn(i) yn(i)=-yn(i) endif enddo h=sqrt((xp(1)-vx(iv2))**2+(yp(1)-vy(iv2))**2) do i=1,npts-1 h=h+sqrt((xp(i+1)-xp(i))**2+(yp(i+1)-yp(i))**2) enddo h=h+sqrt((xp(npts)-vx(iv1))**2+(yp(npts)-vy(iv1))**2) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cnode0(c,iord,iords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: lptr real(kind=rknd), dimension(3,100) :: c common /pltmg1/ic(3,363),jc(12) cy c compute nodes on unit triangle c call mkgptr(iord,iords,lptr) c c vertices c istart=jc(iord) ishift=1-jc(iord) do j=istart,istart+2 do k=1,3 c(k,j+ishift)=real(ic(k,j),rknd)/real(iord,rknd) enddo enddo c c interior c istart=jc(iord)+3*iord istop=jc(iord+1)-1 ishift=lptr(4)-istart do j=istart,istop do k=1,3 c(k,j+ishift)=real(ic(k,j),rknd)/real(iord,rknd) enddo enddo c c edges c do iside=1,3 jord=iords(iside) istart=jc(jord)+3+(iside-1)*(jord-1) ishift=lptr(iside)-istart do j=istart,istart+jord-2 do k=1,3 c(k,j+ishift)=real(ic(k,j),rknd)/real(jord,rknd) enddo enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine edvals cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(2) :: c real(kind=rknd), dimension(20) :: x,y,v common /pltmg5/cb(65,65),cd(12,65),cs(12,45), + iptr(12),jptr(12) cy c mxord=10 c iptr(1)=1 jptr(1)=1 do iord=1,mxord iptr(iord+1)=iptr(iord)+iord+1 jptr(iord+1)=jptr(iord)+mxord-iord enddo c c evaluate all edge nodal basis functions at all edge nodes c do iord=1,mxord nfun=iord+1 do ipts=1,mxord npts=ipts+1 do ipt=1,npts c(2)=real(ipt-1,rknd)/real(npts-1,rknd) c(1)=1.0e0_rknd-c(2) call bevale(c,v,iord) do ifn=1,nfun idx=iptr(ipts)+ipt-1 jfn=iptr(iord)+ifn-1 cb(idx,jfn)=v(ifn) enddo enddo enddo enddo c c evaluate all derivatives of nodal basis at edge midpoint c do iord=1,mxord npts=iord+1 nfun=iord+1 do i=1,npts x(i)=real(i-1,rknd)/real(npts-1,rknd) enddo do jfn=iptr(iord),iptr(iord+1)-1 ifn=jfn-iptr(iord)+1 cd(1,jfn)=1.0e0_rknd do k=2,mxord+1 cd(k,jfn)=0.0e0_rknd enddo do k=1,npts if(k==ifn) cycle q=1.0e0_rknd/(x(ifn)-x(k)) s=(0.5e0_rknd-x(k))*q do m=nfun+1,2,-1 cd(m,jfn)=cd(m,jfn)*s + +cd(m-1,jfn)*real(m-1,rknd)*q enddo cd(1,jfn)=cd(1,jfn)*s enddo enddo c c evaluate special basis functions/derivatives at midpoint c if(iord==mxord) cycle c c reoder vertices, and emulate beval c ii=(iord+1)/2 v(1)=1.0e0_rknd y(npts)=0.5e0_rknd do m=1,ii y(2*m-1)=x(m) y(2*m)=x(npts+1-m) v(m+1)=v(m)*(0.5e0_rknd-x(m))/x(m+1) enddo jfn=jptr(iord) cs(1,jfn)=1.0e0_rknd do m=2,mxord+1 cs(m,jfn)=0.0e0_rknd enddo do k=1,npts s=(0.5e0_rknd-y(k)) do m=iord+2,2,-1 cs(m,jfn)=cs(m,jfn)*s + +cs(m-1,jfn)*real(m-1,rknd) enddo csv=cs(1,jfn) cs(1,jfn)=cs(1,jfn)*s enddo c c compute scaling factor based on beval algorithm c if(2*ii==iord+1) then qq=v(ii+1)**2/cs(1,jfn) else qq=v(ii+1)**2/csv endif c do jfn=jptr(iord)+1,jptr(iord+1)-1 jord=mxord+1+jfn-jptr(iord+1) do m=1,mxord+1 cs(m,jfn)=cs(m,jfn-1) enddo do m=jord+1,2,-1 cs(m,jfn)=cs(m-1,jfn)*real(m-1,rknd) enddo cs(1,jfn)=0.0e0_rknd enddo c c replace not useful derivatives with zero and c replace round-off zero with zero c scale everything else to align with ss in beval c do jfn=jptr(iord),jptr(iord+1)-1 ii=(iord-1)/2 do m=1,iord+1 cs(m,jfn)=0.0e0_rknd enddo j=jfn-jptr(iord)+1 if((j/2)*2==j) then do m=iord+2,mxord+1,2 cs(m,jfn)=0.0e0_rknd enddo do m=iord+3,mxord+1,2 cs(m,jfn)=cs(m,jfn)*qq enddo else do m=iord+3,mxord+1,2 cs(m,jfn)=0.0e0_rknd enddo do m=iord+2,mxord+1,2 cs(m,jfn)=cs(m,jfn)*qq enddo endif enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine upwind(bx,by,d11,d12,d21,d22,tx,ty,x,y, + a10,a11,a12,a20,a21,a22) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(3) :: tx,ty,x,y,bp,bm,g,r,rm,rp,s real(kind=rknd), dimension(3) :: gp real(kind=rknd), dimension(5) :: bx,by,d11,d12,d21,d22,a10 real(kind=rknd), dimension(5) :: a11,a12,a20,a21,a22 cy data index/1,2,3,2,3,1,3,1,2/ c c c if(abs(bx(1))+abs(by(1))==0.0e0_rknd) return dd=(d12(1)+d21(1))/2.0e0_rknd det=d11(1)*d22(1)-dd**2 if(abs(det)==0.0e0_rknd) 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)=0.0e0_rknd) cycle cc e2=3.0e0_rknd*c2-(bx(k)*x(2)+by(k)*y(2)) cc e3=3.0e0_rknd*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 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bexp(beta,dbeta,bp,bm,dbp,dbm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) cy c careful bernoulli evaluation c if(beta>10.0e0_rknd) then ez=exp(-beta) ezp=-ez*dbeta bm=beta/(1.0e0_rknd-ez) dbm=(dbeta+bm*ezp)/(1.0e0_rknd-ez) bp=ez*bm dbp=ezp*bm+ez*dbm else if(beta<-10.0e0_rknd) then ez=exp(beta) ezp=ez*dbeta bp=beta/(ez-1.0e0_rknd) dbp=(dbeta-bp*ezp)/(ez-1.0e0_rknd) bm=ez*bp dbm=ezp*bp+ez*dbp else z=beta/2.0e0_rknd zp=dbeta/2.0e0_rknd ezp=exp(z) ezpp=ezp*zp ezm=1.0e0_rknd/ezp ezmp=-ezm*zp if(abs(z)<=1.0e-4_rknd) then zz=z**2 zzp=2.0e0_rknd*z*zp sz=1.0e0_rknd+zz/6.0e0_rknd*(1.0e0_rknd+zz/20.0e0_rknd) szp=zzp/6.0e0_rknd*(1.0e0_rknd+zz/10.0e0_rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine elenbc(iedge,itnode,ibndry,ibedge,itdof,vx,vy,sf, + u,um,uc,rl,a,h,g,sm,su,b,d,p,dl,iprob,gnxy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy,u,um,uc real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100,100) :: a,h,g,sm,su real(kind=rknd), dimension(100) :: b,d,gv real(kind=rknd), dimension(200) :: p,dl real(kind=rknd), dimension(6) :: gg,r real(kind=rknd), dimension(3,20) :: cc real(kind=rknd), dimension(20) :: xp,yp,xn,yn common /pltmg2/c(2,78),wt(78),np1(13) cy external gnxy,sxy c c c this routine computes the contribution to the element c from the natural boundary conditions. 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 ktri=ibedge(1,iedge)/4 kside=ibedge(1,iedge)-4*ktri call l2gmap(ktri,idof,ndof,iord,iords,itdof) irule=iords(kside)+1 c c npts=np1(irule+1)-np1(irule) do i=1,npts k=np1(irule)+i-1 cc(1,i)=c(1,k) cc(2,i)=c(2,k) cc(3,i)=0.0e0_rknd enddo call cnode1(iedge,1_iknd,itnode,ibndry,ibedge,vx,vy,sf, + rl,npts,cc,xp,yp,xn,yn,hh,sxy) c c do basis function and gnxy evaluations c itag=ibndry(7,iedge) c do i=1,ndof b(i)=0.0e0_rknd d(i)=0.0e0_rknd p(i)=0.0e0_rknd dl(i)=0.0e0_rknd do j=1,ndof a(i,j)=0.0e0_rknd h(i,j)=0.0e0_rknd g(i,j)=0.0e0_rknd sm(i,j)=0.0e0_rknd su(i,j)=0.0e0_rknd enddo enddo p(ndof+1)=0.0e0_rknd p(ndof+2)=0.0e0_rknd dl(ndof+1)=0.0e0_rknd dl(ndof+2)=0.0e0_rknd c do i=1,npts call beval1(cc(1,i),gv,iord,iords) uu=0.0e0_rknd do j=1,ndof uu=uu+gv(j)*u(idof(j)) enddo do k=1,6 gg(k)=0.0e0_rknd r(k)=0.0e0_rknd enddo if(iprob==5) then rr=0.0e0_rknd do j=1,ndof rr=rr+gv(j)*uc(idof(j)) enddo else rr=rl endif call gnxy(xp(i),yp(i),uu,rr,itag,gg) we=wt(i-1+np1(irule))*hh if(iprob>=4.and.iprob<=6) then umu=0.0e0_rknd do j=1,ndof umu=umu+gv(j)*um(idof(j)) enddo do j=1,6 r(j)=umu*gg(j) enddo endif p(ndof+1)=p(ndof+1)+r(3)*we dl(ndof+1)=dl(ndof+1)+r(6)*we dl(ndof+2)=dl(ndof+2)+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==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==4.or.iprob==6) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine elebdi(iedge,iside,itnode,ibndry,ibedge,itdof, + vx,vy,sf,u,uc,rl,a,h,g,sm,su,b,d,p,dl,iprob,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(5,5) :: map integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,u,uc real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100,100) :: a,h,g,su,sm real(kind=rknd), dimension(100) :: b,d,gv,gx,gy real(kind=rknd), dimension(200) :: p,dl real(kind=rknd), dimension(15) :: cp real(kind=rknd), dimension(5) :: r real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(3,20) :: cc real(kind=rknd), dimension(20) :: xp,yp,xn,yn common /pltmg2/c(2,78),wt(78),np1(13) cy external p2xy,sxy 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 ktri=ibedge(iside,iedge)/4 kside=ibedge(iside,iedge)-4*ktri call l2gmap(ktri,idof,ndof,iord,iords,itdof) irule=iords(kside)+1 c c npts=np1(irule+1)-np1(irule) do i=1,npts k=np1(irule)+i-1 cc(1,i)=c(1,k) cc(2,i)=c(2,k) cc(3,i)=0.0e0_rknd enddo call cnode1(iedge,iside,itnode,ibndry,ibedge,vx,vy,sf, + rl,npts,cc,xp,yp,xn,yn,hh,sxy) c do i=1,ndof b(i)=0.0e0_rknd d(i)=0.0e0_rknd p(i)=0.0e0_rknd dl(i)=0.0e0_rknd do j=1,ndof a(i,j)=0.0e0_rknd h(i,j)=0.0e0_rknd g(i,j)=0.0e0_rknd su(i,j)=0.0e0_rknd sm(i,j)=0.0e0_rknd enddo enddo p(ndof+1)=0.0e0_rknd p(ndof+2)=0.0e0_rknd dl(ndof+1)=0.0e0_rknd dl(ndof+2)=0.0e0_rknd c itag=ibndry(7,iedge) ktag=itnode(5,ktri) c c compute tangent and normal vectors c call afmap(ktri,itnode,vx,vy,tx,ty,x,y,det) c do i=1,npts c c evaluate basis functions c call beval(cc(1,i),x,y,gv,gx,gy,iord,iords) c uu=0.0e0_rknd ux=0.0e0_rknd uy=0.0e0_rknd 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-1+np1(irule))*hh do k=1,15 cp(k)=0.0e0_rknd enddo if(iprob==5) then rr=0.0e0_rknd do j=1,ndof rr=rr+gv(j)*uc(idof(j)) enddo else rr=rl endif call p2xy(xp(i),yp(i),xn(i),yn(i),uu,ux,uy,rr,itag,ktag,cp) c p(ndof+1)=p(ndof+1)+cp(5)*we dl(ndof+1)=dl(ndof+1)+cp(15)*we p(ndof+2)=p(ndof+2)+cp(1)*we dl(ndof+2)=dl(ndof+2)+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==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==4.or.iprob==2.or.iprob==6) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eledbc(iedge,itnode,ibndry,ibedge,itdof,vx,vy,sf, + u,um,uc,rl,d1u,d2u,udot,iprob,gdxy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,u,um,uc,udot real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(*) :: d1u,d2u real(kind=rknd), dimension(50) :: g real(kind=rknd), dimension(3,20) :: cc real(kind=rknd), dimension(20) :: xp,yp,xn,yn cy external gdxy,sxy c c this routine computes the contribution to the element c from the dirichlet boundary conditions. c c gg( 1) = g c gg( 2) = dg/drl c gg( 3) = d2g/drl drl c c do basis function and gnxy evaluations c call l2gmpe(iedge,ibedge,iord,idof,itdof) c itag=ibndry(7,iedge) c npts=iord+1 do i=1,npts cc(2,i)=real(i-1,rknd)/real(iord,rknd) cc(1,i)=1.0e0_rknd-cc(2,i) cc(3,i)=0.0e0_rknd enddo call cnode1(iedge,1_iknd,itnode,ibndry,ibedge,vx,vy,sf, + rl,npts,cc,xp,yp,xn,yn,hh,sxy) c do i=1,iord+1 do k=1,8 g(k)=0.0e0_rknd enddo ivk=idof(i) if(iprob==5) then rr=uc(ivk) else rr=rl endif call gdxy(xp(i),yp(i),rr,itag,g) u(ivk)=g(1) if(abs(iprob)==1) um(ivk)=0.0e0_rknd if(abs(iprob)==3.or.abs(iprob)==4.or.abs(iprob)==6) then udot(ivk)=g(2) endif if(abs(iprob)>=4.and.abs(iprob)<=6) then um(ivk)=0.0e0_rknd 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eleas6(itri,itnode,ibndry,itdof,mark,vx,vy,sf,u,um, + rl,p,d,dl,ispd,icurv,a1xy,a2xy,fxy,p1xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(5,5) :: map integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,*) :: icurv integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(*) :: mark integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy,u,um real(kind=rknd), dimension(100) :: d,gv,gx,gy,xp,yp, + gxl,gyl,gxll,gyll real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(200) :: dl,p real(kind=rknd), dimension(15) :: ca1,ca2,cf,cp1 real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(3) :: tx,ty,x,y,detd real(kind=rknd), dimension(3,3) :: xd,yd,xn,yn real(kind=rknd), dimension(4,3) :: r real(kind=rknd), dimension(5) :: bx1,by1,bx2,by2,d11,d12,d21 real(kind=rknd), dimension(5) :: d22,a10,a11,a12,a20,a21 real(kind=rknd), dimension(5) :: a22,b1,b2 common /pltmg3/c(3,746),wt(746),np2(22) cy external a1xy,a2xy,fxy,p1xy,sxy 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 the block matrix/rhs c c | h a^t dl | | du | | p | c | a 0 d | | dum | = - | b | c | dl^t d^t dl+1 | | drl | | dl+2| c c call l2gmap(itri,idof,ndof,iord,iords,itdof) do i=1,ndof d(i)=0.0e0_rknd dl(i)=0.0e0_rknd enddo dl(ndof+1)=0.0e0_rknd p(ndof+1)=0.0e0_rknd do j=1,3 if(mark(itnode(j,itri))>0) go to 10 enddo return c c 10 irule=2*max(iord,iords(1),iords(2),iords(3)) itag=itnode(5,itri) c c compute tangent and normal vectors c do j=1,3 ivj=itnode(j,itri) do k=1,4 r(k,j)=0.0e0_rknd enddo if(mark(ivj)<=0) cycle iedge=mark(ivj)/2 ii=mark(ivj)-2*iedge+1 jtag=-ibndry(3,iedge) ss=sf(ii,iedge) do k=1,12 values(k)=0.0e0_rknd enddo call sxy(rl,ss,jtag,values) r(1,j)=values(5) r(2,j)=values(6) r(3,j)=values(9) r(4,j)=values(10) enddo call afmapd(r,itri,itnode,vx,vy,tx,ty,xd,yd,detd) do j=1,3 x(j)=xd(1,j) y(j)=yd(1,j) enddo c call cnode2(itri,itnode,ibndry,itdof,icurv,vx,vy,sf, + xp,yp,isw,sxy) c if(detd(1)>0.0e0_rknd) then det=detd(1)/2.0e0_rknd detl=detd(2)/2.0e0_rknd detll=detd(3)/2.0e0_rknd else det=-detd(1)/2.0e0_rknd detl=-detd(2)/2.0e0_rknd detll=-detd(3)/2.0e0_rknd endif c do i=np2(irule),np2(irule+1)-1 c c evaluate basis functions c call bevald(c(1,i),xd,yd,gv,gx,gy,gxl,gyl,gxll,gyll, + iord,iords) if(isw==0) then we=wt(i)*det wel=wt(i)*detl well=wt(i)*detll 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_rknd p12=0.0e0_rknd p21=0.0e0_rknd p22=0.0e0_rknd xx=0.0e0_rknd yy=0.0e0_rknd 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 do k=1,3 xn(j,k)=(p22*xd(j,k)-p21*yd(j,k))/detn yn(j,k)=(p11*yd(j,k)-p12*xd(j,k))/detn enddo enddo call bevald(c(1,i),xn,yn,gv,gx,gy,gxl,gyl,gxll,gyll, + iord,iords) we=wt(i)*det*abs(detn) wel=wt(i)*detl*abs(detn) well=wt(i)*detll*abs(detn) endif c c function evaluations c uu=0.0e0_rknd ux=0.0e0_rknd uy=0.0e0_rknd uxl=0.0e0_rknd uyl=0.0e0_rknd uxll=0.0e0_rknd uyll=0.0e0_rknd umu=0.0e0_rknd umx=0.0e0_rknd umy=0.0e0_rknd umxl=0.0e0_rknd umyl=0.0e0_rknd umxll=0.0e0_rknd umyll=0.0e0_rknd 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)) uxl=uxl+gxl(j)*u(idof(j)) uyl=uyl+gyl(j)*u(idof(j)) uxll=uxll+gxll(j)*u(idof(j)) uyll=uyll+gyll(j)*u(idof(j)) umu=umu+gv(j)*um(idof(j)) umx=umx+gx(j)*um(idof(j)) umy=umy+gy(j)*um(idof(j)) umxl=umxl+gxl(j)*um(idof(j)) umyl=umyl+gyl(j)*um(idof(j)) umxll=umxll+gxll(j)*um(idof(j)) umyll=umyll+gyll(j)*um(idof(j)) enddo rr=rl do k=1,15 ca1(k)=0.0e0_rknd ca2(k)=0.0e0_rknd cp1(k)=0.0e0_rknd cf(k)=0.0e0_rknd 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 sharfetter gummel upwinding c if(ispd==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_rknd a11(k)=0.0e0_rknd a12(k)=0.0e0_rknd a20(k)=0.0e0_rknd a21(k)=0.0e0_rknd a22(k)=0.0e0_rknd b1(k)=0.0e0_rknd b2(k)=0.0e0_rknd 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 c 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 adjust derivatives c p10 =cp1(map(1,1)) p1l =cp1(map(3,1))*uxl+cp1(map(4,1))*uyl p1ll=cp1(map(3,1))*uxll+cp1(map(4,1))*uyll + +(cp1(map(3,3))*uxl+cp1(map(3,4))*uyl)*uxl 1 +(cp1(map(4,3))*uxl+cp1(map(4,4))*uyl)*uyl c aa10 =ca1(map(1,1)) aa1l =ca1(map(3,1))*uxl+ca1(map(4,1))*uyl aa1ll=ca1(map(3,1))*uxll+ca1(map(4,1))*uyll + +(ca1(map(3,3))*uxl+ca1(map(3,4))*uyl)*uxl 1 +(ca1(map(4,3))*uxl+ca1(map(4,4))*uyl)*uyl c aa20 =ca2(map(1,1)) aa2l =ca2(map(3,1))*uxl+ca2(map(4,1))*uyl aa2ll=ca2(map(3,1))*uxll+ca2(map(4,1))*uyll + +(ca2(map(3,3))*uxl+ca2(map(3,4))*uyl)*uxl 1 +(ca2(map(4,3))*uxl+ca2(map(4,4))*uyl)*uyl c ff0 =cf(map(1,1)) ffl =cf(map(3,1))*uxl+cf(map(4,1))*uyl ffll =cf(map(3,1))*uxll+cf(map(4,1))*uyll + +(cf(map(3,3))*uxl+cf(map(3,4))*uyl)*uxl 1 +(cf(map(4,3))*uxl+cf(map(4,4))*uyl)*uyl c pp=p10+umu*ff0+umx*aa10+umy*aa20 pl=p1l+umu*ffl+umx*aa1l+umxl*aa10+umy*aa2l+umyl*aa20 pll=p1ll+umu*ffll+umx*aa1ll+2.0e0_rknd*umxl*aa1l+ + umxll*aa10+umy*aa2ll+2.0e0_rknd*umyl*aa2l+umyll*aa20 c c element assembly c ccccc q=pp*we ql=pl*we+pp*wel qll=pll*we+2.0e0_rknd*pl*wel+pp*well p(ndof+1)=p(ndof+1)+ql dl(ndof+1)=dl(ndof+1)+qll do k=1,ndof c p1u=cp1(map(2,1))*gv(k)+cp1(map(3,1))*gx(k)+ + cp1(map(4,1))*gy(k) p1lu=(cp1(map(3,2))*uxl+cp1(map(4,2))*uyl)*gv(k) + +(cp1(map(3,3))*uxl+cp1(map(4,3))*uyl)*gx(k) 1 +(cp1(map(3,4))*uxl+cp1(map(4,4))*uyl)*gy(k) 2 + cp1(map(3,1))*gxl(k)+cp1(map(4,1))*gyl(k) c a1u=ca1(map(2,1))*gv(k)+ca1(map(3,1))*gx(k)+ + ca1(map(4,1))*gy(k) a1lu=(ca1(map(3,2))*uxl+ca1(map(4,2))*uyl)*gv(k) + +(ca1(map(3,3))*uxl+ca1(map(4,3))*uyl)*gx(k) 1 +(ca1(map(3,4))*uxl+ca1(map(4,4))*uyl)*gy(k) 2 + ca1(map(3,1))*gxl(k)+ca1(map(4,1))*gyl(k) c a2u=ca2(map(2,1))*gv(k)+ca2(map(3,1))*gx(k)+ + ca2(map(4,1))*gy(k) a2lu=(ca2(map(3,2))*uxl+ca2(map(4,2))*uyl)*gv(k) + +(ca2(map(3,3))*uxl+ca2(map(4,3))*uyl)*gx(k) 1 +(ca2(map(3,4))*uxl+ca2(map(4,4))*uyl)*gy(k) 2 + ca2(map(3,1))*gxl(k)+ca2(map(4,1))*gyl(k) c ffu=cf(map(2,1))*gv(k)+cf(map(3,1))*gx(k)+ + cf(map(4,1))*gy(k) fflu =(cf(map(3,2))*uxl+cf(map(4,2))*uyl)*gv(k) + +(cf(map(3,3))*uxl+cf(map(4,3))*uyl)*gx(k) 1 +(cf(map(3,4))*uxl+cf(map(4,4))*uyl)*gy(k) 2 + cf(map(3,1))*gxl(k)+cf(map(4,1))*gyl(k) c dl(k)=dl(k)+(p1lu+umu*fflu+umx*a1lu+umy*a2lu)*we + +(p1u+umu*ffu+umx*a1u+umy*a2u)*wel c pv=ff0*gv(k)+aa10*gx(k)+aa20*gy(k) plv=ffl*gv(k)+aa1l*gx(k)+aa10*gxl(k)+ + aa2l*gy(k)+aa20*gyl(k) c d(k)=pv*wel+plv*we enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine elebd6(iedge,iside,itnode,ibndry,ibedge,itdof,mark, + vx,vy,sf,u,rl,a,h,g,sm,su,b,d,p,dl,p2xy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), save, dimension(5,5) :: map integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(*) :: mark integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,u real(kind=rknd), dimension(100) :: b,d,gv,gx,gy, + gxl,gyl,gxll,gyll,xp,yp,xn,yn real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100,100) :: a,h,g,su,sm real(kind=rknd), dimension(200) :: dl,p real(kind=rknd), dimension(15) :: cp2 real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(4,3) :: r real(kind=rknd), dimension(3) :: tx,ty,detd real(kind=rknd), dimension(3,20) :: cc real(kind=rknd), dimension(3,3) :: xd,yd common /pltmg2/c(2,78),wt(78),np1(13) cy external p2xy,sxy 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 ktri=ibedge(iside,iedge)/4 kside=ibedge(iside,iedge)-4*ktri call l2gmap(ktri,idof,ndof,iord,iords,itdof) irule=iords(kside)+1 c do i=1,ndof b(i)=0.0e0_rknd d(i)=0.0e0_rknd p(i)=0.0e0_rknd dl(i)=0.0e0_rknd do j=1,ndof a(i,j)=0.0e0_rknd h(i,j)=0.0e0_rknd g(i,j)=0.0e0_rknd su(i,j)=0.0e0_rknd sm(i,j)=0.0e0_rknd enddo enddo p(ndof+1)=0.0e0_rknd p(ndof+2)=0.0e0_rknd dl(ndof+1)=0.0e0_rknd dl(ndof+2)=0.0e0_rknd do j=1,3 if(mark(itnode(j,ktri))>0) go to 10 enddo return c 10 k1=index(2,kside) k2=index(3,kside) itag=ibndry(7,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 do j=1,3 ivj=itnode(j,ktri) do k=1,4 r(k,j)=0.0e0_rknd enddo if(mark(ivj)<=0) cycle jedge=mark(ivj)/2 ii=mark(ivj)-2*jedge+1 jtag=-ibndry(3,jedge) ss=sf(ii,jedge) do k=1,12 values(k)=0.0e0_rknd enddo call sxy(rl,ss,jtag,values) r(1,j)=values(5) r(2,j)=values(6) r(3,j)=values(9) r(4,j)=values(10) enddo call afmapd(r,ktri,itnode,vx,vy,tx,ty,xd,yd,detd) c tx1=vx(iv2)-vx(iv1) ty1=vy(iv2)-vy(iv1) tx1l=r(1,k2)-r(1,k1) ty1l=r(2,k2)-r(2,k1) tx1ll=r(3,k2)-r(3,k1) ty1ll=r(4,k2)-r(4,k1) hh=sqrt(tx1**2+ty1**2) hhl=(tx1*tx1l+ty1*ty1l)/hh hhll=(tx1ll*tx1+tx1l**2+ty1ll*ty1+ty1l**2-hhl**2)/hh c npts=np1(irule+1)-np1(irule) do i=1,npts k=np1(irule)+i-1 cc(1,i)=c(1,k) cc(2,i)=c(2,k) cc(3,i)=0.0e0_rknd enddo call cnode1(iedge,iside,itnode,ibndry,ibedge,vx,vy,sf, + rl,npts,cc,xp,yp,xn,yn,hh,sxy) c c do i=1,npts c call bevald(cc(1,i),xd,yd,gv,gx,gy,gxl,gyl, + gxll,gyll,iord,iords) c uu=0.0e0_rknd ux=0.0e0_rknd uy=0.0e0_rknd uxl=0.0e0_rknd uyl=0.0e0_rknd uxll=0.0e0_rknd uyll=0.0e0_rknd 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)) uxl=uxl+gxl(j)*u(idof(j)) uyl=uyl+gyl(j)*u(idof(j)) uxll=uxll+gxll(j)*u(idof(j)) uyll=uyll+gyll(j)*u(idof(j)) enddo c c function evaluations c do k=1,15 cp2(k)=0.0e0_rknd enddo call p2xy(xx,yy,dx,dy,uu,ux,uy,rl,itag,ktag,cp2) c c adjust derivatives c p20 =cp2(map(1,1)) p2l =cp2(map(3,1))*uxl+cp2(map(4,1))*uyl p2ll=cp2(map(3,1))*uxll+cp2(map(4,1))*uyll + +(cp2(map(3,3))*uxl+cp2(map(3,4))*uyl)*uxl 1 +(cp2(map(4,3))*uxl+cp2(map(4,4))*uyl)*uyl c c element assembly c we=wt(i-1+np1(irule))*hh wel=wt(i-1+np1(irule))*hhl well=wt(i-1+np1(irule))*hhll c ccccc q=p20*we ql=p2l*we+p20*wel qll=p2ll*we+2.0e0_rknd*p2l*wel+p20*well p(ndof+1)=p(ndof+1)+ql dl(ndof+1)=dl(ndof+1)+qll do k=1,ndof c p2u=cp2(map(2,1))*gv(k)+cp2(map(3,1))*gx(k)+ + cp2(map(4,1))*gy(k) p2lu=(cp2(map(3,2))*uxl+cp2(map(4,2))*uyl)*gv(k) + +(cp2(map(3,3))*uxl+cp2(map(4,3))*uyl)*gx(k) 1 +(cp2(map(3,4))*uxl+cp2(map(4,4))*uyl)*gy(k) 2 + cp2(map(3,1))*gxl(k)+cp2(map(4,1))*gyl(k) c dl(k)=dl(k)+p2lu*we+p2u*wel enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cmark6(nvf,nbf,ibndry,mark) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: mark cy c mark parameterized boundary points c do i=1,nvf mark(i)=0 enddo c do i=1,nbf if(ibndry(3,i)>=0) cycle mark(ibndry(1,i))=2*i mark(ibndry(2,i))=2*i+1 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cquad2 cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), save, dimension(179) :: m integer(kind=iknd), save, dimension(22) :: ic real(kind=rknd), save, dimension(179) :: s,w,t common /pltmg3/c(3,746),wt(746),np2(22) cy data index/1,2,3,2,3,1,3,1,2/ c c order 2; 1 point c data m(1),w(1),s(1)/ 1, + 01.000000000000000000000000000000000e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ c c order 3; 3 points c data m(2),w(2),s(2)/ 3, + 0.3333333333333333333333333333333333e0_rknd, 1 0.1666666666666666666666666666666667e0_rknd/ c c order 4; 6 points c data m(3),w(3),s(3)/ 3, + 0.2811498024409796482535143227020770e0_rknd, 1 0.1628828503958919109001618041849063e0_rknd/ data m(4),w(4),s(4)/ 3, + 0.0521835308923536850798190106312564e0_rknd, 1 0.4779198835675637000000000000000000e0_rknd/ c c order 5; 6 points c data m(5),w(5),s(5)/ 3, + 0.2233815896780114656950070084331228e0_rknd, 1 0.4459484909159648863183292538830519e0_rknd/ data m(6),w(6),s(6)/ 3, + 0.1099517436553218676383263249002105e0_rknd, 1 0.0915762135097707434595714634022015e0_rknd/ c c order 6; 7 points c data m(7),w(7),s(7)/ 3, + 0.1259391805448271525956839455001813e0_rknd, 1 0.1012865073234563388009873619151238e0_rknd/ data m(8),w(8),s(8)/ 3, + 0.1323941527885061807376493878331519e0_rknd, 1 0.4701420641051150897704412095134476e0_rknd/ data m(9),w(9),s(9)/ 1, + 0.2250000000000000000000000000000000e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ c c order 7; 12 points c data m(10),w(10),s(10)/ 3, + 0.0508449063702068169209368091068690e0_rknd, 1 0.0630890144915022283403316028708192e0_rknd/ data m(11),w(11),s(11)/ 3, + 0.1167862757263793660252896113855794e0_rknd, 1 0.2492867451709104212916385531070191e0_rknd/ data m(12),w(12),s(12),t(12)/ 6, + 0.0828510756183735751935534564204425e0_rknd, 1 0.0531450498448169473532496716313981e0_rknd, 2 0.3103524510337844054166077339565522e0_rknd/ c c order 8; 15 points c data m(13),w(13),s(13)/ 3, + 0.0135338625156655615668230924525939e0_rknd, 1 0.0282639241560763402235960069132400e0_rknd/ data m(14),w(14),s(14)/ 3, + 0.0789512544320109813765214502977033e0_rknd, 1 0.4743113232672225752752252279318165e0_rknd/ data m(15),w(15),s(15)/ 3, + 0.1286079278189060745566555330895234e0_rknd, 1 0.2411433258498488102541435126703621e0_rknd/ data m(16),w(16),s(16),t(16)/ 6, + 0.0561201442833753579166666287467563e0_rknd, 1 0.7612227480245238000000000000000000e0_rknd, 2 0.0462708777988089106409255939170205e0_rknd/ c c order 9; 16 points c data m(17),w(17),s(17)/ 1, + 0.1443156076777871682510911104890646e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(18),w(18),s(18)/ 3, + 0.1032173705347182502817915502921290e0_rknd, 1 0.1705693077517602066222935014914645e0_rknd/ data m(19),w(19),s(19)/ 3, + 0.0324584976231980803109259283417806e0_rknd, 1 0.0505472283170309754584235505965989e0_rknd/ data m(20),w(20),s(20)/ 3, + 0.0950916342672846247938961043885843e0_rknd, 1 0.4592925882927231560288155144941693e0_rknd/ data m(21),w(21),s(21),t(21)/ 6, + 0.0272303141744349942648446900739089e0_rknd, 1 0.2631128296346381134217857862846436e0_rknd, 2 0.0083947774099576053372138345392944e0_rknd/ c c order 10; 19 points c data m(22),w(22),s(22)/ 1, + 0.0971357962827988338192419825072886e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(23),w(23),s(23)/ 3, + 0.0313347002271390705368548312872093e0_rknd, 1 0.4896825191987376277837069248361928e0_rknd/ data m(24),w(24),s(24)/ 3, + 0.0255776756586980312616787985589998e0_rknd, 1 0.0447295133944527098651065899662764e0_rknd/ data m(25),w(25),s(25)/ 3, + 0.0778275410047742793167393562994040e0_rknd, 1 0.4370895914929366372699303644353550e0_rknd/ data m(26),w(26),s(26)/ 3, + 0.0796477389272102530328917742640453e0_rknd, 1 0.1882035356190327302409612804673356e0_rknd/ data m(27),w(27),s(27),t(27)/ 6, + 0.0432835393772893772893772893772894e0_rknd, 1 0.7411985987844980206900798735234238e0_rknd, 2 0.2219629891607656956751025276931911e0_rknd/ c c order 11; 25 points c data m(28),w(28),s(28)/ 1, + 0.0809374287976228802571131238165019e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(29),w(29),s(29)/ 3, + 0.0772985880029631216825069823803434e0_rknd, 1 0.4272731788467755380904427175154472e0_rknd/ data m(30),w(30),s(30)/ 3, + 0.0784576386123717313680939208343967e0_rknd, 1 0.1830992224486750205215743848502200e0_rknd/ data m(31),w(31),s(31)/ 3, + 0.0174691679959294869176071632906781e0_rknd, 1 0.4904340197011305874539712223768484e0_rknd/ data m(32),w(32),s(32)/ 3, + 0.0042923741848328280304804020901319e0_rknd, 1 0.0125724455515805327313290850210413e0_rknd/ data m(33),w(33),s(33),t(33)/ 6, + 0.0374688582104676429790207654850445e0_rknd, 1 0.6542686679200661406665700955876279e0_rknd, 2 0.3080460016852477000000000000000000e0_rknd/ data m(34),w(34),s(34),t(34)/ 6, + 0.0269493525918799596454494795810967e0_rknd, 1 0.1228045770685592734301298174812812e0_rknd, 2 0.0333718337393047862408164417747804e0_rknd/ c c order 12; 28 points c data m(35),w(35),s(35)/ 1, + 0.0811779602968671595154759687498236e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(36),w(36),s(36)/ 3, + 0.0123240435069094941184739010162328e0_rknd, 1 0.0309383552454307848951950149913047e0_rknd/ data m(37),w(37),s(37)/ 3, + 0.0628280097444101072833394281602940e0_rknd, 1 0.4364981811341288419176152765599732e0_rknd/ data m(38),w(38),s(38)/ 3, + 0.0122203790493645297552122150039379e0_rknd, 1 0.4989847637025932662879869838313909e0_rknd/ data m(39),w(39),s(39)/ 3, + 0.0677013489528115099209888618232256e0_rknd, 1 0.2146881979585943366068758138782509e0_rknd/ data m(40),w(40),s(40)/ 3, + 0.0402196936288516904235668896075687e0_rknd, 1 0.1136831040421133902052931562283618e0_rknd/ data m(41),w(41),s(41),t(41)/ 6, + 0.0147622727177161013362930655877821e0_rknd, 1 0.8256187661648629043588062003083580e0_rknd, 2 0.1597423045918501898008607882250075e0_rknd/ data m(42),w(42),s(42),t(42)/ 6, + 0.0407279964582990396603369584816179e0_rknd, 1 0.6404723101348652676770365908189668e0_rknd, 2 0.3117837157095990000000000000000000e0_rknd/ c c order 13; 33 points c data m(43),w(43),s(43)/ 3, + 0.0061662610515590172338664837852304e0_rknd, 1 0.0213173504532103702468569755157282e0_rknd/ data m(44),w(44),s(44)/ 3, + 0.0628582242178851003542705130928825e0_rknd, 1 0.2712103850121159223459513403968947e0_rknd/ data m(45),w(45),s(45)/ 3, + 0.0347961129307089429893283972949994e0_rknd, 1 0.1275761455415859246738963251542836e0_rknd/ data m(46),w(46),s(46)/ 3, + 0.0436925445380384021354572625574750e0_rknd, 1 0.4397243922944602729797366234843611e0_rknd/ data m(47),w(47),s(47)/ 3, + 0.0257310664404553354177909230715644e0_rknd, 1 0.4882173897738048825646620652588110e0_rknd/ data m(48),w(48),s(48),t(48)/ 6, + 0.0223567732023034457118390767023200e0_rknd, 1 0.6958360867878034221416355232360725e0_rknd, 2 0.2813255809899395482481306929745527e0_rknd/ data m(49),w(49),s(49),t(49)/ 6, + 0.0173162311086588923716421008110341e0_rknd, 1 0.8580140335440726305905366166261782e0_rknd, 2 0.1162519159075971412413541478426018e0_rknd/ data m(50),w(50),s(50),t(50)/ 6, + 0.0403715577663809295178286992522368e0_rknd, 1 0.6089432357797878068561924377637101e0_rknd, 2 0.2757132696855141939747963460797640e0_rknd/ c c order 14; 37 points c data m(51),w(51),s(51)/ 1, + 0.0679600365868316442817744246808849e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(52),w(52),s(52)/ 3, + 0.0556019675304533287072574660104615e0_rknd, 1 0.4269414142598004060208125350313742e0_rknd/ data m(53),w(53),s(53)/ 3, + 0.0582784851191999814047670835133398e0_rknd, 1 0.2213722862918329006548125547050791e0_rknd/ data m(54),w(54),s(54)/ 3, + 0.0060523371035391718417928000322908e0_rknd, 1 0.0215096811088431838692913135340521e0_rknd/ data m(55),w(55),s(55)/ 3, + 0.0239944019288947307737107994509597e0_rknd, 1 0.4890769464525393499006897190902044e0_rknd/ data m(56),w(56),s(56),t(56)/ 6, + 0.0346412761408483704659868285109182e0_rknd, 1 0.6235459955536755708158543531862366e0_rknd, 2 0.3084417608921177746584718525412453e0_rknd/ data m(57),w(57),s(57),t(57)/ 6, + 0.0149654011051656672632458571329034e0_rknd, 1 0.8647077702954427753025459508956932e0_rknd, 2 0.1109220428034633954128695452216745e0_rknd/ data m(58),w(58),s(58),t(58)/ 6, + 0.0241790398115938191374457455730608e0_rknd, 1 0.7485071158999521951730185957887097e0_rknd, 2 0.1635974010678504802338879017109572e0_rknd/ data m(59),w(59),s(59),t(59)/ 6, + 0.0095906810035432627225950901661109e0_rknd, 1 0.7223577931241879652606201323047840e0_rknd, 2 0.2725158177734296661800504643540868e0_rknd/ c c order 15; 46 points c data m(60),w(60),s(60)/ 1, + 0.0585962852260285941278938063477560e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(61),w(61),s(61)/ 3, + 0.0017351512297252675680618638808094e0_rknd, 1 0.0099797608064584324152935295820524e0_rknd/ data m(62),w(62),s(62)/ 3, + 0.0261637825586145217778288591819783e0_rknd, 1 0.4799778935211883898105528650883899e0_rknd/ data m(63),w(63),s(63)/ 3, + 0.0039197292424018290965208275701454e0_rknd, 1 0.1538119591769669000000000000000000e0_rknd/ data m(64),w(64),s(64)/ 3, + 0.0122473597569408660972869899262505e0_rknd, 1 0.0740234771169878100000000000000000e0_rknd/ data m(65),w(65),s(65)/ 3, + 0.0281996285032579601073663071515657e0_rknd, 1 0.1303546825033300000000000000000000e0_rknd/ data m(66),w(66),s(66)/ 3, + 0.0508870871859594852960348275454540e0_rknd, 1 0.2306172260266531342996053700983831e0_rknd/ data m(67),w(67),s(67)/ 3, + 0.0504534399016035991910208971341189e0_rknd, 1 0.4223320834191478241144087137913939e0_rknd/ data m(68),w(68),s(68),t(68)/ 6, + 0.0170636442122334512900253993849472e0_rknd, 1 0.7862373859346610033296221140330900e0_rknd, 2 0.1906163600319009042461432828653034e0_rknd/ data m(69),w(69),s(69),t(69)/ 6, + 0.0096834664255066004075209630934194e0_rknd, 1 0.6305521436606074416224090755688129e0_rknd, 2 0.3623231377435471446183267343597729e0_rknd/ data m(70),w(70),s(70),t(70)/ 6, + 0.0363857559284850056220113277642717e0_rknd, 1 0.6265773298563063142335123137534265e0_rknd, 2 0.2907712058836674150248168174816732e0_rknd/ data m(71),w(71),s(71),t(71)/ 6, + 0.0069646633735184124253997225042413e0_rknd, 1 0.9142099849296254122399670993850469e0_rknd, 2 0.0711657108777507625475924502924336e0_rknd/ c c order 16; 52 points c data m(72),w(72),s(72)/ 1, + 0.0440387108784342798530173272149339e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(73),w(73),s(73)/ 3, + 0.0461847871820269799487156676019167e0_rknd, 1 0.2273322188191428742025043684922941e0_rknd/ data m(74),w(74),s(74)/ 3, + 0.0064989066173327165268828034928102e0_rknd, 1 0.4971625774318874298738098000160233e0_rknd/ data m(75),w(75),s(75)/ 3, + 0.0179936142526584032446699241671566e0_rknd, 1 0.4788497353489545833392292001438526e0_rknd/ data m(76),w(76),s(76)/ 3, + 0.0417731050391413541196860605641460e0_rknd, 1 0.4049860390982719916972446423426920e0_rknd/ data m(77),w(77),s(77)/ 3, + 0.0030595476091164665484301699283448e0_rknd, 1 0.0159312166717444321134277329412690e0_rknd/ data m(78),w(78),s(78)/ 3, + 0.0020124350525586473440903187565405e0_rknd, 1 0.1655832624260814000000000000000000e0_rknd/ data m(79),w(79),s(79)/ 3, + 0.0167756109305091223261114568879588e0_rknd, 1 0.0731336047192287277268738121073244e0_rknd/ data m(80),w(80),s(80),t(80)/ 6, + 0.0154607491897142748660880304092474e0_rknd, 1 0.6652607330722139390623644133856912e0_rknd, 2 0.3163528393449472300863381309502453e0_rknd/ data m(81),w(81),s(81),t(81)/ 6, + 0.0284998903395474233927395587533020e0_rknd, 1 0.7125219872425455330488490116233878e0_rknd, 2 0.0934607511499175300000000000000005e0_rknd/ data m(82),w(82),s(82),t(82)/ 6, + 0.0320943504834895956420992357370957e0_rknd, 1 0.5596483622353932184122484540192300e0_rknd, 2 0.3442290175821932000000000000000016e0_rknd/ data m(83),w(83),s(83),t(83)/ 6, + 0.0115085816368707112840232437732419e0_rknd, 1 0.8104765976190768630468327302905713e0_rknd, 2 0.1710472483142579515476503319255848e0_rknd/ data m(84),w(84),s(84),t(84)/ 6, + 0.0046143065289671031435871760918541e0_rknd, 1 0.9160756440317311885646088387783200e0_rknd, 2 0.0730559964791864896129490819274250e0_rknd/ c c order 17; 55 points c data m(85),w(85),s(85)/ 1, + 0.0480221886803770905518394045805199e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(86),w(86),s(86)/ 3, + 0.0147091003068019271034036428618692e0_rknd, 1 0.0817949831313738726414655931188610e0_rknd/ data m(87),w(87),s(87)/ 3, + 0.0295445865493192559953097267964641e0_rknd, 1 0.1653006019697796506267619329335566e0_rknd/ data m(88),w(88),s(88)/ 3, + 0.0261250173510883774985975654917156e0_rknd, 1 0.4685921053494613866946028972966056e0_rknd/ data m(89),w(89),s(89)/ 3, + 0.0027803873523900069750030161386621e0_rknd, 1 0.0144388134454166826141089566956602e0_rknd/ data m(90),w(90),s(90)/ 3, + 0.0318217730005366495034272900559496e0_rknd, 1 0.2417842853917833534068944592932077e0_rknd/ data m(91),w(91),s(91)/ 3, + 0.0086458343495096599011737341698489e0_rknd, 1 0.4953103429877699640654950868774055e0_rknd/ data m(92),w(92),s(92),t(92)/ 6, + 0.0143003329044953651466164253682521e0_rknd, 1 0.6505134026613522994311446848416867e0_rknd, 2 0.3313997445370895565813231681825939e0_rknd/ data m(93),w(93),s(93),t(93)/ 6, + 0.0278497772036008299522298734239535e0_rknd, 1 0.6040112814959970398494041030359670e0_rknd, 2 0.3032471627499421850415521780783469e0_rknd/ data m(94),w(94),s(94),t(94)/ 6, + 0.0070416734066360975623701880892807e0_rknd, 1 0.8021682575747416636168619478116671e0_rknd, 2 0.1880280595212371734441821142939888e0_rknd/ data m(95),w(95),s(95),t(95)/ 6, + 0.0178998382599337286017702090758108e0_rknd, 1 0.7565056064428283965511540757580608e0_rknd, 2 0.1835046685222968636823802774370004e0_rknd/ data m(96),w(96),s(96),t(96)/ 6, + 0.0274582003843497630724700381009172e0_rknd, 1 0.4659384387141181848838107335915464e0_rknd, 2 0.3596459487975046000000000000000100e0_rknd/ data m(97),w(97),s(97),t(97)/ 6, + 0.0072997969394317620841125440877777e0_rknd, 1 0.9063948439920415013624996618653400e0_rknd, 2 0.0771943712957554322825152250527139e0_rknd/ c c order 18; 61 points c data m(98),w(98),s(98)/ 1, + 0.0447568714443446293718364767042551e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(99),w(99),s(99)/ 3, + 0.0173668850267477964504911176477604e0_rknd, 1 0.0956985088627109399431625786023763e0_rknd/ data m(100),w(100),s(100)/ 3, + 0.0305993480761035327226656472689570e0_rknd, 1 0.1701386396787754467232472307956844e0_rknd/ data m(101),w(101),s(101)/ 3, + 0.0285877085785997802070400912176892e0_rknd, 1 0.4180206858679549762226346423934278e0_rknd/ data m(102),w(102),s(102)/ 3, + 0.0066474319297536932323184955454668e0_rknd, 1 0.4965814805066249549705403530622792e0_rknd/ data m(103),w(103),s(103)/ 3, + 0.0074761894020185118222455734708010e0_rknd, 1 0.0416621148288076427920788515983419e0_rknd/ data m(104),w(104),s(104)/ 3, + 0.0250499865038387453145589519055078e0_rknd, 1 0.4679329057294235782681900853617119e0_rknd/ data m(105),w(105),s(105),t(105)/ 6, + 0.0014798108921196449448095368275048e0_rknd, 1 0.9695311989037220561945405830595324e0_rknd, 2 0.0289250916202182460715280477140682e0_rknd/ data m(106),w(106),s(106),t(106)/ 6, + 0.0051211362467481060658943504057326e0_rknd, 1 0.7597243875386241295553271953226612e0_rknd, 2 0.2344417552635687745426605309129788e0_rknd/ data m(107),w(107),s(107),t(107)/ 6, + 0.0273173593695928059185316898423957e0_rknd, 1 0.2954993169683015000000000000000100e0_rknd, 2 0.4959112466607535754230345000437552e0_rknd/ data m(108),w(108),s(108),t(108)/ 6, + 0.0140057286759092815978663321140118e0_rknd, 1 0.6256063821576970270701920926669370e0_rknd, 2 0.3534176945414970676263249907709938e0_rknd/ data m(109),w(109),s(109),t(109)/ 6, + 0.0078092756974583600981098732328800e0_rknd, 1 0.8721744472331847929031830014156074e0_rknd, 2 0.1127286418142197686188888676807420e0_rknd/ data m(110),w(110),s(110),t(110)/ 6, + 0.0181657284597916721760720775172237e0_rknd, 1 0.7475123194400060400624067817608753e0_rknd, 2 0.1990702787978578813133914398155831e0_rknd/ data m(111),w(111),s(111),t(111)/ 6, + 0.0274443739924583277620834554147845e0_rknd, 1 0.5988687908832380598061676972635110e0_rknd, 2 0.3035851830713260765320205120458494e0_rknd/ c c order 19; 72 points c data m(112),w(112),s(112)/ 3, + 0.0139778616452860209795840079905549e0_rknd, 1 0.0732708864643828315786196714876895e0_rknd/ data m(113),w(113),s(113)/ 3, + 0.0005549069792132137850684555152509e0_rknd, 1 0.0039177489832282316427840744195806e0_rknd/ data m(114),w(114),s(114)/ 3, + 0.0210268138197046690284298685162450e0_rknd, 1 0.4675973189887110616515129966229624e0_rknd/ data m(115),w(115),s(115)/ 3, + 0.0340182121799276997472265274182211e0_rknd, 1 0.4179162109674113120121268105139935e0_rknd/ data m(116),w(116),s(116),t(116)/ 6, + 0.0279101658047749951418434740078169e0_rknd, 1 0.1653816933602894800544902692391766e0_rknd, 2 0.5636967056608707538051458939380737e0_rknd/ data m(117),w(117),s(117),t(117)/ 6, + 0.0182146861271508661267339566206858e0_rknd, 1 0.2875008944057839899961939131396606e0_rknd, 2 0.2860423261392047491209581074803029e0_rknd/ data m(118),w(118),s(118),t(118)/ 6, + 0.0142670236581097930775198241095567e0_rknd, 1 0.1258893143198247960170648399490380e0_rknd, 2 0.6960432186424611957925748602819539e0_rknd/ data m(119),w(119),s(119),t(119)/ 6, + 0.0142371230906750507043127637741560e0_rknd, 1 0.0632219159465026144935750801169980e0_rknd, 2 0.7605455518876824326145947637978687e0_rknd/ data m(120),w(120),s(120),t(120)/ 6, + 0.0192575838546747877991373836820213e0_rknd, 1 0.0789102274540205177520722103754889e0_rknd, 2 0.5920196312717585633226205754022254e0_rknd/ data m(121),w(121),s(121),t(121)/ 6, + 0.0097051322843806411487822763323902e0_rknd, 1 0.0380580535067857143261189915962621e0_rknd, 2 0.6836812596359998524801240874538131e0_rknd/ data m(122),w(122),s(122),t(122)/ 6, + 0.0076297881343321289957824556338534e0_rknd, 1 0.0142903521304540256499241103130749e0_rknd, 2 0.8517040371370558150285216534427664e0_rknd/ data m(123),w(123),s(123),t(123)/ 6, + 0.0106187391363503447944635436705283e0_rknd, 1 0.0129672723432531723123416343300903e0_rknd, 2 0.5747324928881490288994509386896897e0_rknd/ data m(124),w(124),s(124),t(124)/ 6, + 0.0057106698032758388134142143826895e0_rknd, 1 0.0076485948208408993307926288182273e0_rknd, 2 0.7355104408307292987031352244816406e0_rknd/ data m(125),w(125),s(125),t(125)/ 6, + 0.0043268574608764182945223447328327e0_rknd, 1 0.0127104605722554679311424918135822e0_rknd, 2 0.9393450876437317887074042026828225e0_rknd/ c c order 20; 73 points c data m(126),w(126),s(126)/ 1, + 0.0329063313889186520836143448464750e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(127),w(127),s(127)/ 3, + 0.0103307318912720533670399635717483e0_rknd, 1 0.4896099870730063319661310657482982e0_rknd/ data m(128),w(128),s(128)/ 3, + 0.0223872472630163925291845560351627e0_rknd, 1 0.4545368926978926620467593905357283e0_rknd/ data m(129),w(129),s(129)/ 3, + 0.0302661258694680708652801909825912e0_rknd, 1 0.4014166806494311873939956238106886e0_rknd/ data m(130),w(130),s(130)/ 3, + 0.0304909678021977810000315865785204e0_rknd, 1 0.2555516544030976113221817681092679e0_rknd/ data m(131),w(131),s(131)/ 3, + 0.0241592127416409049118480309866400e0_rknd, 1 0.1770779421521295516426752065159011e0_rknd/ data m(132),w(132),s(132)/ 3, + 0.0160508035868008752916227702764295e0_rknd, 1 0.1100610532279518613000849516773740e0_rknd/ data m(133),w(133),s(133)/ 3, + 0.0080845802617840604818056732421944e0_rknd, 1 0.0555286242518396712486784124713557e0_rknd/ data m(134),w(134),s(134)/ 3, + 0.0020793620274847807513475016743984e0_rknd, 1 0.0126218637772286684902347667787060e0_rknd/ data m(135),w(135),s(135),t(135)/ 6, + 0.0038848769049813897567049919927727e0_rknd, 1 0.6006337947946450000000000000000000e0_rknd, 2 0.3957547873569428623047946940658279e0_rknd/ data m(136),w(136),s(136),t(136)/ 6, + 0.0255741606120219038929297019526003e0_rknd, 1 0.1344667545307797856120431989326469e0_rknd, 2 0.5576032615887839683639532425011810e0_rknd/ data m(137),w(137),s(137),t(137)/ 6, + 0.0088809035733380577455259247035175e0_rknd, 1 0.7209870258173650552166529023382789e0_rknd, 2 0.2645669484065202080403017349012149e0_rknd/ data m(138),w(138),s(138),t(138)/ 6, + 0.0161245467617313912197852693278377e0_rknd, 1 0.5945270689558709246138892880265067e0_rknd, 2 0.3585393522059505884249269906459009e0_rknd/ data m(139),w(139),s(139),t(139)/ 6, + 0.0024919418174906754405846475759496e0_rknd, 1 0.8393314736808385786174900771484052e0_rknd, 2 0.1578074059685947447376736033595065e0_rknd/ data m(140),w(140),s(140),t(140)/ 6, + 0.0182428401189505783776657132097361e0_rknd, 1 0.2238614240979156913033693895065364e0_rknd, 2 0.7010879789261733673232883365595116e0_rknd/ data m(141),w(141),s(141),t(141)/ 6, + 0.0102585637361985213080480700423581e0_rknd, 1 0.8229313240698566316274715591605332e0_rknd, 2 0.1424216011133834373155747568772374e0_rknd/ data m(142),w(142),s(142),t(142)/ 6, + 0.0037999288553019139790731537136397e0_rknd, 1 0.9243442526207840294558591379015631e0_rknd, 2 0.0654946280829377033923265249859256e0_rknd/ c c order 21; 88 points c data m(143),w(143),s(143)/ 1, + 0.0125376079944966565735856367723948e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(144),w(144),s(144)/ 3, + 0.0274718698764242137484535496073598e0_rknd, 1 0.2158743059329919731902545438401828e0_rknd/ data m(145),w(145),s(145)/ 3, + 0.0097652722770514230413646914294237e0_rknd, 1 0.0753767665297472780972854309459163e0_rknd/ data m(146),w(146),s(146)/ 3, + 0.0013984195353918235239233631597867e0_rknd, 1 0.0103008281372217921136862160096969e0_rknd/ data m(147),w(147),s(147)/ 3, + 0.0092921026251851826304282034030330e0_rknd, 1 0.4936022112987001655119208321450536e0_rknd/ data m(148),w(148),s(148)/ 3, + 0.0165778760323669253260236250351840e0_rknd, 1 0.4615509381069252967410487102915180e0_rknd/ data m(149),w(149),s(149),t(149)/ 6, + 0.0206677623486650769614219700129729e0_rknd, 1 0.3286214064242369933034974609509133e0_rknd, 2 0.4293405702582103752139588004663984e0_rknd/ data m(150),w(150),s(150),t(150)/ 6, + 0.0208222355211545073068785561993297e0_rknd, 1 0.2604803617865687564195930170811535e0_rknd, 2 0.1015775342809694461687550061961797e0_rknd/ data m(151),w(151),s(151),t(151)/ 6, + 0.0095686384198490606888758450458320e0_rknd, 1 0.1370742358464553000000000000000000e0_rknd, 2 0.7100659730011301599879040745464079e0_rknd/ data m(152),w(152),s(152),t(152)/ 6, + 0.0244527709689724638856439207024089e0_rknd, 1 0.1467269458722997843041609884874530e0_rknd, 2 0.4985454776784148493896226967076119e0_rknd/ data m(153),w(153),s(153),t(153)/ 6, + 0.0031557306306305340038264003207296e0_rknd, 1 0.0269989777425532900000000000000000e0_rknd, 2 0.0491867226725820016197037125775872e0_rknd/ data m(154),w(154),s(154),t(154)/ 6, + 0.0121367963653212969370133090807574e0_rknd, 1 0.0618717859336170268417124700122339e0_rknd, 2 0.7796601465405693953603506190768108e0_rknd/ data m(155),w(155),s(155),t(155)/ 6, + 0.0149664801438864490365249118515707e0_rknd, 1 0.0477243674276219962083526801042934e0_rknd, 2 0.3704915391495476369201496202567388e0_rknd/ data m(156),w(156),s(156),t(156)/ 6, + 0.0063275933217777395693240327504398e0_rknd, 1 0.1206005151863643799672337870400794e0_rknd, 2 0.8633469487547526484979879960925217e0_rknd/ data m(157),w(157),s(157),t(157)/ 6, + 0.0013425603120636958849798512981433e0_rknd, 1 0.0026971477967097876716489145012827e0_rknd, 2 0.0561949381877455029878923019865887e0_rknd/ data m(158),w(158),s(158),t(158)/ 6, + 0.0027760769163475540677293561558015e0_rknd, 1 0.0030156332779423626572762598234710e0_rknd, 2 0.2086750067484213509575944630613577e0_rknd/ data m(159),w(159),s(159),t(159)/ 6, + 0.0107398444741849415551734474479517e0_rknd, 1 0.0299053757884570188069287738643386e0_rknd, 2 0.7211512409120340910281041502050941e0_rknd/ data m(160),w(160),s(160),t(160)/ 6, + 0.0053678057381874532052474100212697e0_rknd, 1 0.0067566542224609885399458175192278e0_rknd, 2 0.6400554419405418899040536682721647e0_rknd/ c c order 22; 91 points c data m(161),w(161),s(161)/ 1, + 0.0275622569528764809669070448245143e0_rknd, 1 0.3333333333333333333333333333333333e0_rknd/ data m(162),w(162),s(162)/ 3, + 0.0220602154134885011913507340331164e0_rknd, 1 0.2009352770650852798729618515641637e0_rknd/ data m(163),w(163),s(163)/ 3, + 0.0234600159386714884930134449523000e0_rknd, 1 0.4376591659619271797318338441880541e0_rknd/ data m(164),w(164),s(164)/ 3, + 0.0003268895950471905462145575015465e0_rknd, 1 0.0034339564905961768509599122096049e0_rknd/ data m(165),w(165),s(165)/ 3, + 0.0032653194629399682343353040958667e0_rknd, 1 0.0466434847753067534951762404321419e0_rknd/ data m(166),w(166),s(166)/ 3, + 0.0117564629154127977043079692133821e0_rknd, 1 0.3864222517630714909403520241677264e0_rknd/ data m(167),w(167),s(167)/ 3, + 0.0117807684199115168455575790986761e0_rknd, 1 0.0954354711085309101085716810414760e0_rknd/ data m(168),w(168),s(168),t(168)/ 6, + 0.0022688108188011408053357043343043e0_rknd, 1 0.9555138033504563605013147251467712e0_rknd, 2 0.0357186278731633582380416089754387e0_rknd/ data m(169),w(169),s(169),t(169)/ 6, + 0.0025960109644363200606737836654882e0_rknd, 1 0.8866388134288682261249005746914376e0_rknd, 2 0.1081432249156462115273886110463127e0_rknd/ data m(170),w(170),s(170),t(170)/ 6, + 0.0046345297858718602123478905615969e0_rknd, 1 0.7842628458804341542966439903981954e0_rknd, 2 0.2074644495998764568243804295157274e0_rknd/ data m(171),w(171),s(171),t(171)/ 6, + 0.0047943360545488579348574487199119e0_rknd, 1 0.8829239550502000327113489873168897e0_rknd, 2 0.0856847087203169400000000000000100e0_rknd/ data m(172),w(172),s(172),t(172)/ 6, + 0.0057124788367236115672506383429634e0_rknd, 1 0.6689919644410772404913224832098946e0_rknd, 2 0.3214940030142888168816832126834860e0_rknd/ data m(173),w(173),s(173),t(173)/ 6, + 0.0058658276043221216369557987000023e0_rknd, 1 0.5520721210355609641571609652527788e0_rknd, 2 0.4379422187933413835523680769629170e0_rknd/ data m(174),w(174),s(174),t(174)/ 6, + 0.0094137630590915875898182685203471e0_rknd, 1 0.7975929655965685676293142232957258e0_rknd, 2 0.1619164530635778567510067702038591e0_rknd/ data m(175),w(175),s(175),t(175)/ 6, + 0.0134149437966564249100220266108931e0_rknd, 1 0.6775147151197714846349911663441326e0_rknd, 2 0.2745047674019949038590029729073332e0_rknd/ data m(176),w(176),s(176),t(176)/ 6, + 0.0157169180920832459435000011378462e0_rknd, 1 0.5429974155890916053311361168391934e0_rknd, 2 0.4053359980750069279498908953763256e0_rknd/ data m(177),w(177),s(177),t(177)/ 6, + 0.0168636830144369045916509638861999e0_rknd, 1 0.7054599055699685616588563415406017e0_rknd, 2 0.1877376806564353427728167439451200e0_rknd/ data m(178),w(178),s(178),t(178)/ 6, + 0.0213900270853200983778322980803590e0_rknd, 1 0.5748005730665084622159824505498500e0_rknd, 2 0.3056968347660551665127925566498432e0_rknd/ data m(179),w(179),s(179),t(179)/ 6, + 0.0230767921894926813678808755218915e0_rknd, 1 0.4717788085046148166039770401349242e0_rknd, 2 0.3121444668708908816708046058155764e0_rknd/ c data ic/1,2,3,5,7,10,13,17,22,28,35,43,51,60, + 72,85,98,112,126,143,161,180/ c nrule=21 k=1 np2(1)=1 do n=1,nrule do i=ic(n),ic(n+1)-1 if (m(i)==1) then wt(k)=w(i) cc=1.0e0_rknd/3.0e0_rknd c(1,k)=cc c(2,k)=cc c(3,k)=cc k=k+1 else if (m(i)==3) then ss=s(i) cc=1.0e0_rknd-2.0e0_rknd*ss do j=1,3 wt(k)=w(i) c(index(1,j),k)=ss c(index(2,j),k)=ss c(index(3,j),k)=cc k=k+1 enddo else if (m(i)==6) then ss=s(i) tt=t(i) cc=1.0e0_rknd-tt-ss do j=1,3 wt(k)=w(i) c(index(1,j),k)=ss c(index(2,j),k)=tt c(index(3,j),k)=cc k=k+1 wt(k)=w(i) c(index(1,j),k)=ss c(index(2,j),k)=cc c(index(3,j),k)=tt k=k+1 enddo endif enddo np2(n+1)=k enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eleufn(itri,itnode,vx,vy,maxd,ngf,u,rl, + npts,qv,c,itdof,qxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(maxd,*) :: u real(kind=rknd), dimension(4,*) :: qv real(kind=rknd), dimension(3,*) :: c real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(100) :: gv,gx,gy,uu,uux,uuy cy external qxy c c compute tangent and normal vectors c call l2gmap(itri,idof,ndof,iord,iords,itdof) call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) c iv1=itnode(1,itri) iv2=itnode(2,itri) iv3=itnode(3,itri) itag=itnode(5,itri) do i=1,npts call beval(c(1,i),x,y,gv,gx,gy,iord,iords) 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_rknd sx=0.0e0_rknd sy=0.0e0_rknd 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,4 qv(m,i)=0.0e0_rknd 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine elel2p(itri,jord,itnode,ibndry,icurv,itdof,vx,vy,sf, + u,b,scale,jsw,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3,*) :: icurv integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords,jords real(kind=rknd), dimension(*) :: vx,vy,u,scale real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(100) :: b,xp,yp,up,gv,ur real(kind=rknd), dimension(3,100) :: c real(kind=rknd), dimension(12,100) :: g cy external sxy 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 l2gmap(itri,idof,ndof,iord,iords,itdof) call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) call cnode2(itri,itnode,ibndry,itdof,icurv,vx,vy,sf, + xp,yp,isw,sxy) do i=1,ndof up(i)=u(idof(i)) enddo if(isw>0) then call cnode0(c,iord,iords) do i=1,ndof call barinl(c(1,i),xp,yp,gv,iord,iords) up(i)=0.0e0_rknd do j=1,ndof up(i)=up(i)+u(idof(j))*gv(j) enddo enddo endif c do j=1,3 jords(j)=jord enddo call p2q2d(up,ur,iord,jord,iords,jords) c call deval(itri,itnode,vx,vy,g,scale1,jord) c ss=scale1/scale(jord) cc if(jsw==1) ss=ss*abs(det)/6.0e0_rknd jdof=((jord+1)*(jord+2))/2 do i=1,jord+1 b(i)=0.0e0_rknd do j=1,jdof b(i)=b(i)+ur(j)*g(i,j) enddo b(i)=b(i)*ss enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine barinl(c,xp,yp,gv,iord,iords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(3) :: c,c0,d real(kind=rknd), dimension(2) :: r,p,p0 real(kind=rknd), dimension(2,2) :: a real(kind=rknd), dimension(100) :: xp,yp,gv,rp cy c c compute the barycentric coordinates that hit the point c given by the input barycentric coords for affine map c p0(1)=xp(1)*c(1)+xp(2)*c(2)+xp(3)*c(3) p0(2)=yp(1)*c(1)+yp(2)*c(2)+yp(3)*c(3) c itmax=100 step0=1.0e0_rknd step=1.0e0_rknd rp(52)=step eps=epsilon(1.0e0_rknd)*4096.0e0_rknd c c set up newton equations c call bsys(c,xp,yp,gv,iord,iords,p0,p,r,a) c c main newton loop c do itnum=1,itmax c c solve newton equations c det= a(1,1)*a(2,2)-a(2,1)*a(1,2) d(2)=-( r(1)*a(2,2)- r(2)*a(1,2))/det d(3)=-(a(1,1)*r(2)- a(2,1)*r(1) )/det relerr=sqrt(d(2)**2+d(3)**2) c c convergence test c if(relerr<=eps) return c c cstep parameters c bnorm=sqrt(r(1)**2+r(2)**2) bnorm0=bnorm blast=bnorm z1=a(1,1)*d(2)+a(1,2)*d(3) z2=a(2,1)*d(2)+a(2,2)*d(3) dnew=z1*r(1)+z2*r(2) rp(54)=relerr rp(58)=dnew rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast isw=0 iter=0 call cstep(rp,0_iknd,isw,step0) do j=1,3 c0(j)=c(j) enddo c c line search loop c 10 iter=iter+1 if(iter>10) stop 6161 step=rp(52) c(2)=c0(2)+d(2)*step c(3)=c0(3)+d(3)*step c(1)=1.0e0_rknd-c(2)-c(3) call bsys(c,xp,yp,gv,iord,iords,p0,p,r,a) blast=bnorm bnorm=sqrt(r(1)**2+r(2)**2) z1=a(1,1)*d(2)+a(1,2)*d(3) z2=a(2,1)*d(2)+a(2,2)*d(3) dnew=z1*r(1)+z2*r(2) rp(58)=dnew rp(56)=bnorm/bnorm0 rp(57)=bnorm/blast call cstep(rp,0_iknd,isw,step0) if(isw>0) go to 10 enddo if(itnum>0) stop 4141 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bsys(c,xp,yp,gv,iord,iords,p0,p,r,a) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(3) :: c real(kind=rknd), dimension(3), save :: x,y real(kind=rknd), dimension(2) :: r,p,p0 real(kind=rknd), dimension(2,2) :: a real(kind=rknd), dimension(100) :: xp,yp,gv,gx,gy cy data x/-1.0e0_rknd,1.0e0_rknd,0.0e0_rknd/ data y/-1.0e0_rknd,0.0e0_rknd,1.0e0_rknd/ c c set up newton equations c ndof=(iord-1)*(iord-2)/2+iords(1)+iords(2)+iords(3) call beval(c,x,y,gv,gx,gy,iord,iords) a(1,1)=0.0e0_rknd a(1,2)=0.0e0_rknd a(2,1)=0.0e0_rknd a(2,2)=0.0e0_rknd p(1)=0.0e0_rknd p(2)=0.0e0_rknd do j=1,ndof p(1)=p(1)+xp(j)*gv(j) p(2)=p(2)+yp(j)*gv(j) a(1,1)=a(1,1)+xp(j)*gx(j) a(1,2)=a(1,2)+xp(j)*gy(j) a(2,1)=a(2,1)+yp(j)*gx(j) a(2,2)=a(2,2)+yp(j)*gy(j) enddo r(1)=p(1)-p0(1) r(2)=p(2)-p0(2) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine elenrm(it,itnode,vx,vy,nef,maxd,u, + itdof,uh1nrm,ul2nrm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(maxd,*) :: u real(kind=rknd), dimension(100) :: gx,gy,gv real(kind=rknd), dimension(20) :: u1,u0 common /pltmg3/c(3,746),wt(746),np2(22) cy call l2gmap(it,idof,ndof,iord,iords,itdof) irule=2*max(iord,iords(1),iords(2),iords(3)) c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) det=abs(det)/2.0e0_rknd do ifn=1,nef u0(ifn)=0.0e0_rknd u1(ifn)=0.0e0_rknd enddo c do i=np2(irule),np2(irule+1)-1 c c evaluate basis functions (isoparametric possibility ignored) c call beval(c(1,i),x,y,gv,gx,gy,iord,iords) do ifn=1,nef uu=0.0e0_rknd ux=0.0e0_rknd uy=0.0e0_rknd do j=1,ndof uu=uu+gv(j)*u(idof(j),ifn) ux=ux+gx(j)*u(idof(j),ifn) uy=uy+gy(j)*u(idof(j),ifn) enddo u0(ifn)=u0(ifn)+wt(i)*uu**2*det u1(ifn)=u1(ifn)+wt(i)*(ux**2+uy**2)*det enddo enddo uh1nrm=0.0e0_rknd ul2nrm=0.0e0_rknd do ifn=1,nef uh1nrm=uh1nrm+u1(ifn) ul2nrm=ul2nrm+u0(ifn) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cquad1 cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(42) :: m integer(kind=iknd), save, dimension(13) :: ic real(kind=rknd), save, dimension(42) :: s,w common /pltmg2/c(2,78),wt(78),np1(13) cy c 1 point, order 2 c data m( 1),w( 1),s( 1)/ + 1,2.0e0_rknd,0.0e0_rknd/ c c 2 points, order 4 c data m( 2),w( 2),s( 2)/ + 2,1.0e0_rknd,0.577350269189626e0_rknd/ c c 3 points, order 6 c data m( 3),w( 3),s( 3)/ + 2,0.555555555555556e0_rknd,0.774596669241483e0_rknd/ data m( 4),w( 4),s( 4)/ + 1,0.888888888888889e0_rknd,0.0e0_rknd/ c c 4 points, order 8 c data m( 5),w( 5),s( 5)/ + 2,0.347854845137454e0_rknd,0.861136311594053e0_rknd/ data m( 6),w( 6),s( 6)/ + 2,0.652145154862546e0_rknd,0.339981043584856e0_rknd/ c c 5 points, order 10 c data m( 7),w( 7),s( 7)/ + 2,0.236926885056189e0_rknd,0.906179845938664e0_rknd/ data m( 8),w( 8),s( 8)/ + 2,0.478628670499366e0_rknd,0.538469310105683e0_rknd/ data m( 9),w( 9),s( 9)/ + 1,0.568888888888889e0_rknd,0.0e0_rknd/ c c 6 points, order 12 c data m(10),w(10),s(10)/ + 2,0.171324492379170e0_rknd,0.932469514203152e0_rknd/ data m(11),w(11),s(11)/ + 2,0.360761573048139e0_rknd,0.661209386466265e0_rknd/ data m(12),w(12),s(12)/ + 2,0.467913934572691e0_rknd,0.238619186083197e0_rknd/ c c 7 points, order 14 c data m(13),w(13),s(13)/ + 2,0.129484966168870e0_rknd,0.949107912342759e0_rknd/ data m(14),w(14),s(14)/ + 2,0.279705391489277e0_rknd,0.741531185599394e0_rknd/ data m(15),w(15),s(15)/ + 2,0.381830050505119e0_rknd,0.405845151377397e0_rknd/ data m(16),w(16),s(16)/ + 1,0.417959183673469e0_rknd,0.0e0_rknd/ c c 8 points, order 16 c data m(17),w(17),s(17)/ + 2,0.101228536290376e0_rknd,0.960289856497536e0_rknd/ data m(18),w(18),s(18)/ + 2,0.222381034453374e0_rknd,0.796666477413627e0_rknd/ data m(19),w(19),s(19)/ + 2,0.313706645877887e0_rknd,0.525532409916329e0_rknd/ data m(20),w(20),s(20)/ + 2,0.362683783378362e0_rknd,0.183434642495650e0_rknd/ c c 9 points, order 18 c data m(21),w(21),s(21)/ + 2,0.081274388361574e0_rknd,0.968160239507626e0_rknd/ data m(22),w(22),s(22)/ + 2,0.180648160694857e0_rknd,0.836031107326636e0_rknd/ data m(23),w(23),s(23)/ + 2,0.260610696402935e0_rknd,0.613371432700590e0_rknd/ data m(24),w(24),s(24)/ + 2,0.312347077040003e0_rknd,0.324253423403809e0_rknd/ data m(25),w(25),s(25)/ + 1,0.330239355001260e0_rknd,0.0e0_rknd/ c c 10 points, order 20 c data m(26),w(26),s(26)/ + 2,0.066671344308688e0_rknd,0.973906528517172e0_rknd/ data m(27),w(27),s(27)/ + 2,0.149451349150581e0_rknd,0.865063366688985e0_rknd/ data m(28),w(28),s(28)/ + 2,0.219086362515982e0_rknd,0.679409568299024e0_rknd/ data m(29),w(29),s(29)/ + 2,0.269266719309996e0_rknd,0.433395394129247e0_rknd/ data m(30),w(30),s(30)/ + 2,0.295524224714753e0_rknd,0.148874338981631e0_rknd/ c c 11 points, order 22 c data m(31),w(31),s(31)/ + 2,0.556685663759708e-1_rknd,0.978228688240051e0_rknd/ data m(32),w(32),s(32)/ + 2,0.125580370426178e0_rknd,0.887062549591064e0_rknd/ data m(33),w(33),s(33)/ + 2,0.186290204524994e0_rknd,0.730152010917664e0_rknd/ data m(34),w(34),s(34)/ + 2,0.233193770051003e0_rknd,0.519096136093140e0_rknd/ data m(35),w(35),s(35)/ + 2,0.262804538011551e0_rknd,0.269543170928955e0_rknd/ data m(36),w(36),s(36)/ + 1,0.272925078868866e0_rknd,0.0e0_rknd/ c c 12 points, order 24 c data m(37),w(37),s(37)/ + 2,0.047175336386512e0_rknd,0.981560634246719e0_rknd/ data m(38),w(38),s(38)/ + 2,0.106939325995318e0_rknd,0.904117256370475e0_rknd/ data m(39),w(39),s(39)/ + 2,0.160078328543346e0_rknd,0.769902674194305e0_rknd/ data m(40),w(40),s(40)/ + 2,0.203167426723066e0_rknd,0.587317954286617e0_rknd/ data m(41),w(41),s(41)/ + 2,0.233492536538355e0_rknd,0.367831498998180e0_rknd/ data m(42),w(42),s(42)/ + 2,0.249147045813403e0_rknd,0.125233408511469e0_rknd/ c data ic/1,2,3,5,7,10,13,17,21,26,31,37,43/ c nrule=12 np1(1)=1 k=1 do i=1,nrule do j=ic(i),ic(i+1)-1 k=k+m(j) enddo np1(i+1)=k enddo do i=1,nrule istart=np1(i) istop=np1(i+1)-1 do j=ic(i),ic(i+1)-1 if(m(j)==1) then wt(istart)=w(j)/2.0e0_rknd c(1,istart)=0.5e0_rknd c(2,istart)=0.5e0_rknd else wt(istart)=w(j)/2.0e0_rknd c(1,istart)=0.5e0_rknd-s(j)/2.0e0_rknd c(2,istart)=0.5e0_rknd+s(j)/2.0e0_rknd wt(istop)=wt(istart) c(1,istop)=c(2,istart) c(2,istop)=c(1,istart) endif istart=istart+1 istop=istop-1 enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine trans1(iords,iord,g,ss) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: lptr real(kind=rknd), dimension(100) :: g real(kind=rknd), dimension(20) :: g0,g1,cf real(kind=rknd), dimension(12,3) :: ss common /pltmg5/cb(65,65),cd(12,65),cs(12,45), + iptr(12),jptr(12) cy data index/1,2,3,2,3,1,3,1,2/ c c first rearrange g c call mkgptr(iord,iords,lptr) c c interior c ishift=lptr(4)-(3*iord+1) if(ishift==0) return do k=lptr(5)-1,lptr(4),-1 g(k)=g(k-ishift) g(k-ishift)=0.0e0_rknd enddo do iside=3,1,-1 ishift=lptr(iside)-((iside-1)*(iord-1)+4) if(ishift==0) cycle do k=lptr(iside)+iord-2,lptr(iside),-1 g(k)=g(k-ishift) g(k-ishift)=0.0e0_rknd enddo enddo c c fixup side iside c do iside=1,3 if(iords(iside)==iord) cycle j2=index(2,iside) j3=index(3,iside) c g0(1)=g(j2) do i=lptr(iside),lptr(iside)+iord-2 g0(i-lptr(iside)+2)=g(i) enddo g0(iord+1)=g(j3) c do ifn=1,iords(iside)+1 g1(ifn)=0.0e0_rknd jfn=iptr(iords(iside))+ifn-1 do jord=iords(iside),iord+1,-1 js=jptr(iord)+jord-iord-1 alpha=cd(jord+1,jfn) do kord=jord+2,iords(iside),2 alpha=alpha-cf(kord)*cs(jord+1,js+kord-jord) enddo cf(jord)=alpha/cs(jord+1,js) g1(ifn)=g1(ifn)+cf(jord)*ss(jord-iord,iside) enddo do ipt=1,iord+1 jpt=iptr(iord)+ipt-1 g1(ifn)=g1(ifn)+cb(jpt,jfn)*g0(ipt) enddo enddo c g(j2)=g1(1) do i=lptr(iside),lptr(iside+1)-1 g(i)=g1(i-lptr(iside)+2) enddo g(j3)=g1(lptr(iside+1)-lptr(iside)+2) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine beval(c,x,y,gv,gx,gy,iord,iords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(3) :: c,x,y real(kind=rknd), dimension(100) :: gv,gx,gy real(kind=rknd), dimension(3,20) :: val,valx,valy real(kind=rknd), dimension(12,3) :: ss,sx,sy common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c isw=0 do j=1,3 if(iords(j)/=iord) isw=1 val(j,1)=1.0e0_rknd valx(j,1)=0.0e0_rknd valy(j,1)=0.0e0_rknd enddo do m=1,iord d=real(m,rknd)/real(iord,rknd) q=real(m-1,rknd)/real(iord,rknd) do j=1,3 f=(c(j)-q)/d fx=x(j)/d fy=y(j)/d val(j,m+1)=val(j,m)*f valx(j,m+1)=valx(j,m)*f+val(j,m)*fx valy(j,m+1)=valy(j,m)*f+val(j,m)*fy enddo enddo do i=jc(iord),jc(iord+1)-1 q12=val(1,ic(1,i)+1)*val(2,ic(2,i)+1) q23=val(2,ic(2,i)+1)*val(3,ic(3,i)+1) q31=val(3,ic(3,i)+1)*val(1,ic(1,i)+1) gv(i-jc(iord)+1)=val(3,ic(3,i)+1)*q12 gx(i-jc(iord)+1)=valx(1,ic(1,i)+1)*q23+ + valx(2,ic(2,i)+1)*q31+valx(3,ic(3,i)+1)*q12 gy(i-jc(iord)+1)=valy(1,ic(1,i)+1)*q23+ + valy(2,ic(2,i)+1)*q31+valy(3,ic(3,i)+1)*q12 enddo c if(isw==0) return c do iside=1,3 if(iords(iside)==iord) cycle j2=index(2,iside) j3=index(3,iside) ii=(iord+1)/2 c qq=val(j2,ii+1)*val(j3,ii+1) qx=valx(j2,ii+1)*val(j3,ii+1)+val(j2,ii+1)*valx(j3,ii+1) qy=valy(j2,ii+1)*val(j3,ii+1)+val(j2,ii+1)*valy(j3,ii+1) rr=(c(j3)-c(j2))/2.0e0_rknd rx=(x(j3)-x(j2))/2.0e0_rknd ry=(y(j3)-y(j2))/2.0e0_rknd c if(2*ii/=iord+1) then qx=qq*rx+qx*rr qy=qq*ry+qy*rr qq=qq*rr endif do i=iord+1,iords(iside) ss(i-iord,iside)=qq sx(i-iord,iside)=qx sy(i-iord,iside)=qy qx=qq*rx+qx*rr qy=qq*ry+qy*rr qq=qq*rr enddo enddo c call trans1(iords,iord,gv,ss) call trans1(iords,iord,gx,sx) call trans1(iords,iord,gy,sy) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine beval1(c,gv,iord,iords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(3) :: c real(kind=rknd), dimension(100) :: gv real(kind=rknd), dimension(3,20) :: val real(kind=rknd), dimension(12,3) :: ss common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c isw=0 do j=1,3 if(iords(j)/=iord) isw=1 val(j,1)=1.0e0_rknd enddo do m=1,iord d=real(m,rknd)/real(iord,rknd) q=real(m-1,rknd)/real(iord,rknd) do j=1,3 f=(c(j)-q)/d val(j,m+1)=val(j,m)*f enddo enddo do i=jc(iord),jc(iord+1)-1 q12=val(1,ic(1,i)+1)*val(2,ic(2,i)+1) gv(i-jc(iord)+1)=val(3,ic(3,i)+1)*q12 enddo c if(isw==0) return c do iside=1,3 if(iords(iside)==iord) cycle j2=index(2,iside) j3=index(3,iside) ii=(iord+1)/2 c qq=val(j2,ii+1)*val(j3,ii+1) rr=(c(j3)-c(j2))/2.0e0_rknd c if(2*ii/=iord+1) then qq=qq*rr endif do i=iord+1,iords(iside) ss(i-iord,iside)=qq qq=qq*rr enddo enddo c call trans1(iords,iord,gv,ss) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine beval2(c,x,y,gxx,gxy,gyy,iord,iords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(3) :: c,x,y real(kind=rknd), dimension(100) :: gxx,gxy,gyy real(kind=rknd), dimension(3,20) :: val,valx,valy,valxx real(kind=rknd), dimension(3,20) :: valxy,valyy real(kind=rknd), dimension(12,3) :: sxx,sxy,syy common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c isw=0 do j=1,3 if(iords(j)/=iord) isw=1 val(j,1)=1.0e0_rknd valx(j,1)=0.0e0_rknd valy(j,1)=0.0e0_rknd valxx(j,1)=0.0e0_rknd valxy(j,1)=0.0e0_rknd valyy(j,1)=0.0e0_rknd enddo do m=1,iord d=real(m,rknd)/real(iord,rknd) q=real(m-1,rknd)/real(iord,rknd) do j=1,3 f=(c(j)-q)/d fx=x(j)/d fy=y(j)/d val(j,m+1)=val(j,m)*f valx(j,m+1)=valx(j,m)*f+val(j,m)*fx valy(j,m+1)=valy(j,m)*f+val(j,m)*fy valxx(j,m+1)=valxx(j,m)*f+2.0e0_rknd*valx(j,m)*fx valyy(j,m+1)=valyy(j,m)*f+2.0e0_rknd*valy(j,m)*fy valxy(j,m+1)=valxy(j,m)*f+valx(j,m)*fy+valy(j,m)*fx enddo enddo do i=jc(iord),jc(iord+1)-1 i1=ic(1,i)+1 i2=ic(2,i)+1 i3=ic(3,i)+1 v12=val(1,i1)*val(2,i2) v23=val(2,i2)*val(3,i3) v31=val(3,i3)*val(1,i1) c x12=valx(1,i1)*valx(2,i2)*2.0e0_rknd x23=valx(2,i2)*valx(3,i3)*2.0e0_rknd x31=valx(3,i3)*valx(1,i1)*2.0e0_rknd c y12=valy(1,i1)*valy(2,i2)*2.0e0_rknd y23=valy(2,i2)*valy(3,i3)*2.0e0_rknd y31=valy(3,i3)*valy(1,i1)*2.0e0_rknd c c12=valx(1,i1)*valy(2,i2)+valy(1,i1)*valx(2,i2) c23=valx(2,i2)*valy(3,i3)+valy(2,i2)*valx(3,i3) c31=valx(3,i3)*valy(1,i1)+valy(3,i3)*valx(1,i1) c gxx(i-jc(iord)+1)= + valxx(1,i1)*v23+valxx(2,i2)*v31+valxx(3,i3)*v12 1 +val(1,i1)*x23 +val(2,i2)*x31 +val(3,i3)*x12 gyy(i-jc(iord)+1)= + valyy(1,i1)*v23+valyy(2,i2)*v31+valyy(3,i3)*v12 1 +val(1,i1)*y23 +val(2,i2)*y31 +val(3,i3)*y12 gxy(i-jc(iord)+1)= + valxy(1,i1)*v23+valxy(2,i2)*v31+valxy(3,i3)*v12 1 +val(1,i1)*c23 +val(2,i2)*c31 +val(3,i3)*c12 enddo c if(isw==0) return c do iside=1,3 if(iords(iside)==iord) cycle j2=index(2,iside) j3=index(3,iside) ii=(iord+1)/2 c qq=val(j2,ii+1)*val(j3,ii+1) qx=valx(j2,ii+1)*val(j3,ii+1)+val(j2,ii+1)*valx(j3,ii+1) qy=valy(j2,ii+1)*val(j3,ii+1)+val(j2,ii+1)*valy(j3,ii+1) c qxx=valxx(j2,ii+1)*val(j3,ii+1) + +2.0e0_rknd*valx(j2,ii+1)*valx(j3,ii+1) 1 +val(j2,ii+1)*valxx(j3,ii+1) qxy=valxy(j2,ii+1)*val(j3,ii+1) + +valx(j2,ii+1)*valy(j3,ii+1) 1 +valy(j2,ii+1)*valx(j3,ii+1) 2 +val(j2,ii+1)*valxy(j3,ii+1) qyy=valyy(j2,ii+1)*val(j3,ii+1) + +2.0e0_rknd*valy(j2,ii+1)*valy(j3,ii+1) 1 +val(j2,ii+1)*valyy(j3,ii+1) c rr=(c(j3)-c(j2))/2.0e0_rknd rx=(x(j3)-x(j2))/2.0e0_rknd ry=(y(j3)-y(j2))/2.0e0_rknd c if(2*ii/=iord+1) then qxx=2.0e0_rknd*qx*rx+qxx*rr qxy=qx*ry+qy*rx+qxy*rr qyy=2.0e0_rknd*qy*ry+qyy*rr qx=qq*rx+qx*rr qy=qq*ry+qy*rr qq=qq*rr endif do i=iord+1,iords(iside) sxx(i-iord,iside)=qxx sxy(i-iord,iside)=qxy syy(i-iord,iside)=qyy qxx=2.0e0_rknd*qx*rx+qxx*rr qxy=qx*ry+qy*rx+qxy*rr qyy=2.0e0_rknd*qy*ry+qyy*rr qx=qq*rx+qx*rr qy=qq*ry+qy*rr qq=qq*rr enddo enddo c call trans1(iords,iord,gxx,sxx) call trans1(iords,iord,gxy,sxy) call trans1(iords,iord,gyy,syy) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bevale(c,gv,iord) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(2) :: c real(kind=rknd), dimension(20) :: gv real(kind=rknd), dimension(2,20) :: val cy c evaluate 1-dimensional basis functions c do j=1,2 val(j,1)=1.0e0_rknd enddo do m=1,iord d=real(m,rknd)/real(iord,rknd) q=real(m-1,rknd)/real(iord,rknd) do j=1,2 val(j,m+1)=val(j,m)*(c(j)-q)/d enddo enddo do i=1,iord+1 gv(i)=val(2,i)*val(1,iord+2-i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bevald(c,x,y,gv,gx,gy,gxl,gyl,gxll,gyll,iord,iords) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(3) :: c real(kind=rknd), dimension(3,3) :: x,y real(kind=rknd), dimension(100) :: gxl,gyl,gxll,gyll,gx, + gy,gv real(kind=rknd), dimension(3,20) :: val,valx,valy, + valxl,valyl,valxll,valyll real(kind=rknd), dimension(12,3) :: sxl,syl,sxll,syll, + sx,sy,ss common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c isw=0 do j=1,3 if(iords(j)/=iord) isw=1 val(j,1)=1.0e0_rknd valx(j,1)=0.0e0_rknd valy(j,1)=0.0e0_rknd valxl(j,1)=0.0e0_rknd valyl(j,1)=0.0e0_rknd valxll(j,1)=0.0e0_rknd valyll(j,1)=0.0e0_rknd enddo do m=1,iord d=real(m,rknd)/real(iord,rknd) q=real(m-1,rknd)/real(iord,rknd) do j=1,3 f=(c(j)-q)/d fx=x(1,j)/d fxl=x(2,j)/d fxll=x(3,j)/d fy=y(1,j)/d fyl=y(2,j)/d fyll=y(3,j)/d val(j,m+1)=val(j,m)*f valx(j,m+1)=valx(j,m)*f+val(j,m)*fx valxl(j,m+1)=valxl(j,m)*f+val(j,m)*fxl valxll(j,m+1)=valxll(j,m)*f+val(j,m)*fxll valy(j,m+1)=valy(j,m)*f+val(j,m)*fy valyl(j,m+1)=valyl(j,m)*f+val(j,m)*fyl valyll(j,m+1)=valyll(j,m)*f+val(j,m)*fyll enddo enddo do i=jc(iord),jc(iord+1)-1 q12=val(1,ic(1,i)+1)*val(2,ic(2,i)+1) q23=val(2,ic(2,i)+1)*val(3,ic(3,i)+1) q31=val(3,ic(3,i)+1)*val(1,ic(1,i)+1) gv(i-jc(iord)+1)=val(3,ic(3,i)+1)*q12 gx(i-jc(iord)+1)=valx(1,ic(1,i)+1)*q23+ + valx(2,ic(2,i)+1)*q31+valx(3,ic(3,i)+1)*q12 gxl(i-jc(iord)+1)=valxl(1,ic(1,i)+1)*q23+ + valxl(2,ic(2,i)+1)*q31+valxl(3,ic(3,i)+1)*q12 gxll(i-jc(iord)+1)=valxll(1,ic(1,i)+1)*q23+ + valxll(2,ic(2,i)+1)*q31+valxll(3,ic(3,i)+1)*q12 gy(i-jc(iord)+1)=valy(1,ic(1,i)+1)*q23+ + valy(2,ic(2,i)+1)*q31+valy(3,ic(3,i)+1)*q12 gyl(i-jc(iord)+1)=valyl(1,ic(1,i)+1)*q23+ + valyl(2,ic(2,i)+1)*q31+valyl(3,ic(3,i)+1)*q12 gyll(i-jc(iord)+1)=valyll(1,ic(1,i)+1)*q23+ + valyll(2,ic(2,i)+1)*q31+valyll(3,ic(3,i)+1)*q12 enddo c if(isw==0) return c do iside=1,3 if(iords(iside)==iord) cycle j2=index(2,iside) j3=index(3,iside) ii=(iord+1)/2+1 c qq=val(j2,ii)*val(j3,ii) qx=valx(j2,ii)*val(j3,ii)+val(j2,ii)*valx(j3,ii) qxl=valxl(j2,ii)*val(j3,ii)+val(j2,ii)*valxl(j3,ii) qxll=valxll(j2,ii)*val(j3,ii)+val(j2,ii)*valxll(j3,ii) qy=valy(j2,ii)*val(j3,ii)+val(j2,ii)*valy(j3,ii) qyl=valyl(j2,ii)*val(j3,ii)+val(j2,ii)*valyl(j3,ii) qyll=valyll(j2,ii)*val(j3,ii)+val(j2,ii)*valyll(j3,ii) rr=(c(j3)-c(j2))/2.0e0_rknd rx=(x(1,j3)-x(1,j2))/2.0e0_rknd rxl=(x(2,j3)-x(2,j2))/2.0e0_rknd rxll=(x(3,j3)-x(3,j2))/2.0e0_rknd ry=(y(1,j3)-y(1,j2))/2.0e0_rknd ryl=(y(2,j3)-y(2,j2))/2.0e0_rknd ryll=(y(3,j3)-y(3,j2))/2.0e0_rknd c if(2*(ii-1)/=iord+1) then qx=qq*rx+qx*rr qxl=qq*rxl+qxl*rr qxll=qq*rxll+qxll*rr qy=qq*ry+qy*rr qyl=qq*ryl+qyl*rr qyll=qq*ryll+qyll*rr qq=qq*rr endif do i=iord+1,iords(iside) ss(i-iord,iside)=qq sx(i-iord,iside)=qx sxl(i-iord,iside)=qxl sxll(i-iord,iside)=qxll sy(i-iord,iside)=qy syl(i-iord,iside)=qyl syll(i-iord,iside)=qyll qx=qq*rx+qx*rr qxl=qq*rxl+qxl*rr qxll=qq*rxll+qxll*rr qy=qq*ry+qy*rr qyl=qq*ryl+qyl*rr qyll=qq*ryll+qyll*rr qq=qq*rr enddo enddo c call trans1(iords,iord,gv,ss) call trans1(iords,iord,gx,sx) call trans1(iords,iord,gxl,sxl) call trans1(iords,iord,gxll,sxll) call trans1(iords,iord,gy,sy) call trans1(iords,iord,gyl,syl) call trans1(iords,iord,gyll,syll) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine deval(it,itnode,vx,vy,g,scale,iord) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(3,20) :: x,y real(kind=rknd), dimension(12,100) :: g real(kind=rknd), dimension(3) :: tx,ty real(kind=rknd), dimension(*) :: vx,vy common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c c compute tangent and normal vectors c do j=1,3 x(j,1)=1.0e0_rknd y(j,1)=1.0e0_rknd enddo call afmap(it,itnode,vx,vy,tx,ty,x(1,2),y(1,2),det) scale=max(abs(x(1,2)),abs(x(2,2)),abs(x(3,2))) scale=max(abs(y(1,2)),abs(y(2,2)),abs(y(3,2)),scale) do j=1,3 x(j,2)=x(j,2)/scale y(j,2)=y(j,2)/scale enddo if(iord>1) then do k=2,iord do j=1,3 x(j,k+1)=x(j,k)*x(j,2) y(j,k+1)=y(j,k)*y(j,2) enddo enddo endif c c vertices c scale=(real(iord,rknd)*scale)**iord do j=1,3 do k=1,iord+1 g(k,j)=x(j,iord+2-k)*y(j,k) enddo enddo if(iord<=1) return c c edges c imid=iord/2+1 do i=1,3 ii=3+(i-1)*(iord-1)+jc(iord)-1 jj=3+(i-1)*(iord-1) do j=1,iord-1 c c i2/j2 correspond to the larger power barycentric coordinate c i2=index(2,i) i3=index(3,i) if(ic(i2,ii+j)ic(1,ii+j)) i1=2 if(ic(3,ii+j)>ic(i1,ii+j)) i1=3 i2=(5-i1)/2 i3=6-i1-i2 if(ic(i3,ii+j)>ic(i2,ii+j)) i2=i3 i3=6-i1-i2 c j1=ic(i1,ii+j) j2=ic(i2,ii+j) j3=ic(i3,ii+j) c c0=real(ibic(j1+j2,j2)*ibic(iord,j3),rknd) c c k is the number of y (x) derivatives in sl (sr) c do k=1,imid sl=0.0e0_rknd sr=0.0e0_rknd do n=1,min(k,j1+1) r1=real(ibic(j1,n-1),rknd) do m=max(1,k+1-n-j2,1),min(k-n+1,j3+1) c c c1 contains the coefficient with binomial coeffs c r2=real(ibic(j2,k-m-n+1),rknd) r3=real(ibic(j3,m-1),rknd) rr=real(ibic(iord,k-1),rknd) c1=c0*r1*r2*r3/rr c s1=x(i1,j1-n+2)*y(i1,n) s2=x(i2,j2+m-k+n)*y(i2,k-m-n+2) s3=x(i3,j3-m+2)*y(i3,m) sl=sl+c1*s1*s2*s3 c s1=y(i1,j1-n+2)*x(i1,n) s2=y(i2,j2+m-k+n)*x(i2,k-m-n+2) s3=y(i3,j3-m+2)*x(i3,m) sr=sr+c1*s1*s2*s3 enddo enddo g(k,jj+j)=sl g(iord+2-k,jj+j)=sr enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function ibic(i,j) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(13) :: iptr integer(kind=iknd), save, dimension(78) :: icf integer(kind=iknd) :: ibic cy data icf/1,1,1,1,2,1,1,3,3,1,1,4,6,4,1,1,5,10,10,5,1, + 1,6,15,20,15,6,1,1,7,21,35,35,21,7,1, 1 1,8,28,56,70,56,28,8,1, 2 1,9,36,84,126,126,84,36,9,1, 3 1,10,45,120,210,252,210,120,45,10,1, 4 1,11,55,165,330,462,462,330,165,55,11,1/ data iptr/1,2,4,7,11,16,22,29,37,46,56,67,79/ c c compute binomial coefficient (i=11 is max) c if(i<0.or.i>11) stop 7778 if(j<0.or.j>i) stop 7779 ibic=icf(iptr(i+1)+j) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function ifac(i) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(12) :: ifac0 integer(kind=iknd) :: ifac cy data ifac0/1,1,2,6,24,120,720,5040,40320, + 362880,3628800,39916800/ c c compute factorial function (i=11 is max) c if(i<0.or.i>11) stop 7776 ifac=ifac0(i+1) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eeval(c,x,y,gv,gx,gy,iord) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(3) :: c,x,y real(kind=rknd), dimension(100) :: gv,gx,gy real(kind=rknd), dimension(3,20) :: val,valx,valy common /pltmg1/ic(3,363),jc(12) cy 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 do j=2,3 val(j,1)=1.0e0_rknd valx(j,1)=0.0e0_rknd valy(j,1)=0.0e0_rknd enddo do m=1,iord+1 q=real(m-1,rknd)/real(iord,rknd) do j=2,3 f=(c(j)-q) fx=x(j) fy=y(j) val(j,m+1)=val(j,m)*f valx(j,m+1)=valx(j,m)*f+val(j,m)*fx valy(j,m+1)=valy(j,m)*f+val(j,m)*fy enddo enddo do i=jc(iord+1)+1,jc(iord+1)+iord+2 gv(i-jc(iord+1))=val(3,ic(3,i)+1)*val(2,ic(2,i)+1) gx(i-jc(iord+1))=valx(3,ic(3,i)+1)*val(2,ic(2,i)+1) + +valx(2,ic(2,i)+1)*val(3,ic(3,i)+1) gy(i-jc(iord+1))=valy(3,ic(3,i)+1)*val(2,ic(2,i)+1) + +valy(2,ic(2,i)+1)*val(3,ic(3,i)+1) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eeval1(c,x,y,g,iord) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(12,20) :: g real(kind=rknd), dimension(3) :: x,y,c real(kind=rknd) :: linval cy do j=0,iord+1 n2=iord+1-j c c n2 is number of lines in the direction 2 c do i=0,iord temp=0.0e0_rknd c c apply product rule, c only k-th line is not differentiated c do k=0,iord if (k<=iord-j) then n22=n2-1 q=real(k,rknd)/real(iord,rknd) linval=(c(2)-q) else n22=n2 q=real(iord-k,rknd)/real(iord,rknd) linval=(c(3)-q) endif m1=max(0_iknd,n22-i) m2=min(n22,iord-i) ifacpro=ifac(n22)*ifac(iord-n22) do m=m1,m2 temp=temp+real(ifacpro* + ibic(iord-i,m)*ibic(i,n22-m),rknd)* 1 (x(2)**m)*(y(2)**(n22-m))*(x(3)**(iord-i-m))* 2 (y(3)**(i-n22+m))*linval enddo enddo if (j==iord+1) then g(i+1,2)=temp else if (j==0) then g(i+1,1)=temp else g(i+1,j+2)=temp endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cnodes cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index common /pltmg1/ic(3,363),jc(12) cy 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 max order for elements is 10. c note we need order iord+1 for subr usrfn c so this routine goes up to order 11 c jc(1)=1 mxord=11 do m=1,mxord k=jc(m) c c vertices c do i=1,3 do j=1,3 ic(j,k)=0 enddo ic(i,k)=m k=k+1 enddo c c edges c if(m==1) go to 10 do i=1,3 i2=index(2,i) i3=index(3,i) do j=1,m-1 ic(i,k)=0 ic(i2,k)=m-j ic(i3,k)=j k=k+1 enddo enddo c c interior points c if(m==2) go to 10 do i=1,m-2 do j=1,i ic(1,k)=m-i-1 ic(2,k)=i+1-j ic(3,k)=j k=k+1 enddo enddo 10 jc(m+1)=k enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine afmap(itri,itnode,vx,vy,tx,ty,x,y,det) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(3) :: x,y,tx,ty real(kind=rknd), dimension(*) :: vx,vy cy 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----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine afmapd(r,itri,itnode,vx,vy,tx,ty,x,y,det) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(3) :: tx,ty,det,txl,tyl,txll,tyll real(kind=rknd), dimension(3,3) :: x,y real(kind=rknd), dimension(4,3) :: r real(kind=rknd), dimension(*) :: vx,vy cy 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 i2=index(2,j) i3=index(3,j) j2=itnode(i2,itri) j3=itnode(i3,itri) tx(j)=vx(j3)-vx(j2) ty(j)=vy(j3)-vy(j2) txl(j)=r(1,i3)-r(1,i2) tyl(j)=r(2,i3)-r(2,i2) txll(j)=r(3,i3)-r(3,i2) tyll(j)=r(4,i3)-r(4,i2) enddo det(1)=tx(2)*ty(3)-tx(3)*ty(2) det(2)=txl(2)*ty(3)-txl(3)+ty(2)+tx(2)*tyl(3)-tx(3)*tyl(2) det(3)=txll(2)*ty(3)-txll(3)+ty(2)+tx(2)*tyll(3)-tx(3)*tyll(2) + +2.0e0_rknd*(txl(2)*tyl(3)-txl(3)*tyl(2)) c s1=1.0e0_rknd/det(1) s2=-det(2)*s1**2 s3=-det(3)*s1**2-2.0e0_rknd*det(2)*s1*s2 c do j=1,3 j2=index(2,j) j3=index(3,j) c r1=-ty(j) r2=-tyl(j) r3=-tyll(j) x(1,j)=r1*s1 x(2,j)=r2*s1+r1*s2 x(3,j)=r3*s1+2.0e0_rknd*r2*s2+r1*s3 c r1=tx(j) r2=txl(j) r3=txll(j) y(1,j)=r1*s1 y(2,j)=r2*s1+r1*s2 y(3,j)=r3*s1+2.0e0_rknd*r2*s2+r1*s3 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tstxy(x,y,u,ux,uy,rl,itag,fxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(4) :: d1a,d1b real(kind=rknd), dimension(4,4) :: d2a,d2b real(kind=rknd), dimension(15) :: v0,vu,vux,vuy,vrl common /val0/k0,ku,kx,ky,kl,kuu,kux,kuy,kul, + kxu,kxx,kxy,kxl,kyu,kyx,kyy,kyl,klu,klx,kly,kll external fxy cy c c the routine checks numerically the derivatives of fxy,a1xy,a2xy c p1xy, by comnparing with finite difference approximations c do i=1,15 v0(i)=0.0e0_rknd vu(i)=0.0e0_rknd vux(i)=0.0e0_rknd vuy(i)=0.0e0_rknd vrl(i)=0.0e0_rknd enddo eps=1.e-3_rknd call fxy(x,y,u,ux,uy,rl,itag,v0) call fxy(x,y,u+eps,ux,uy,rl,itag,vu) call fxy(x,y,u,ux+eps,uy,rl,itag,vux) call fxy(x,y,u,ux,uy+eps,rl,itag,vuy) call fxy(x,y,u,ux,uy,rl+eps,itag,vrl) c c first derivatives c d1a(1)=(vu(k0)-v0(k0))/eps d1b(1)=v0(ku) d1a(2)=(vux(k0)-v0(k0))/eps d1b(2)=v0(kx) d1a(3)=(vuy(k0)-v0(k0))/eps d1b(3)=v0(ky) d1a(4)=(vrl(k0)-v0(k0))/eps d1b(4)=v0(kl) c do j=1,4 q1=d1a(j) q2=d1b(j) qq=abs(q1-q2)/(abs(q1)+abs(q2)+eps) if(qq>eps) write(6,*) 'd1:',j,q1,q2,qq enddo c c second derivatives (u) c d2a(1,1)=(vu(ku)-v0(ku))/eps d2b(1,1)=v0(kuu) d2a(2,1)=(vux(ku)-v0(ku))/eps d2b(2,1)=v0(kux) d2a(3,1)=(vuy(ku)-v0(ku))/eps d2b(3,1)=v0(kuy) d2a(4,1)=(vrl(ku)-v0(ku))/eps d2b(4,1)=v0(kul) c c second derivatives (ux) c d2a(1,2)=(vu(kx)-v0(kx))/eps d2b(1,2)=v0(kxu) d2a(2,2)=(vux(kx)-v0(kx))/eps d2b(2,2)=v0(kxx) d2a(3,2)=(vuy(kx)-v0(kx))/eps d2b(3,2)=v0(kxy) d2a(4,2)=(vrl(kx)-v0(kx))/eps d2b(4,2)=v0(kxl) c c second derivatives (uy) c d2a(1,3)=(vu(ky)-v0(ky))/eps d2b(1,3)=v0(kyu) d2a(2,3)=(vux(ky)-v0(ky))/eps d2b(2,3)=v0(kyx) d2a(3,3)=(vuy(ky)-v0(ky))/eps d2b(3,3)=v0(kyy) d2a(4,3)=(vrl(ky)-v0(ky))/eps d2b(4,3)=v0(kyl) c c second derivatives (rl) c d2a(1,4)=(vu(kl)-v0(kl))/eps d2b(1,4)=v0(klu) d2a(2,4)=(vux(kl)-v0(kl))/eps d2b(2,4)=v0(klx) d2a(3,4)=(vuy(kl)-v0(kl))/eps d2b(3,4)=v0(kly) d2a(4,4)=(vrl(kl)-v0(kl))/eps d2b(4,4)=v0(kll) c do i=1,4 do j=1,4 q1=d2a(i,j) q2=d2b(i,j) qq=abs(q1-q2)/(abs(q1)+abs(q2)+eps) if(qq>eps) write(6,*) 'd2:',i,j,q1,q2,qq enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine chksf(vx,vy,ibndry,sf,ip,rp,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(12) :: values cy external sxy c nbf=ip(3) rl=rp(21) diam=rp(78) eps=1.0e2_rknd*epsilon(1.0e0_rknd)*diam do i=1,nbf if(ibndry(3,i)>=0) cycle itag=-ibndry(3,i) do j=1,2 ivj=ibndry(j,i) theta=sf(j,i) do k=1,12 values(k)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) xx=values(1) yy=values(2) dx=vx(ivj)-xx dy=vy(ivj)-yy if(max(abs(dx),abs(dy))>eps) then write(6,*) 'sstsf',i,j,ivj,itag,rl,theta, + xx,yy,vx(ivj),vy(ivj) endif enddo enddo return end c***************************** file: mg2.f ***************************** c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine trigen(vx,vy,sf,itnode,ibndry,itdof,ipath, + e,ip,rp,sp,iu,ru,su,gf,qxy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(100) :: ip,iu integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), allocatable, dimension(:) :: ibmptr real(kind=rknd), allocatable, dimension(:) :: bump real(kind=rknd), dimension(*) :: vx,vy,e,gf real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp,ru character(len=80), dimension(100) :: sp,su cy external qxy,sxy c c user specified ip variables c if(ip(5)<0.or.ip(5)>9) ip(6)=1 if(ip(6)<-6.or.ip(6)>7) ip(7)=1 if(ip(12)/=1) ip(12)=0 if(ip(8)/=1) ip(8)=0 if(ip(20)<-7.or.ip(20)>7) ip(20)=0 if(ip(18)<-1.or.ip(18)>1) ip(18)=0 iadapt=abs(ip(20)) ndtrgt=max(0,ip(22)) ip(22)=ndtrgt ip(25)=0 if(ip(5)/=0) ip(24)=0 c mpisw=ip(48) nproc=ip(49) irgn=ip(50) c if(iadapt==5) then if(itnode(3,1)/=0) then ip(25)=25 go to 60 endif else if(iadapt/=6) then if(itnode(3,1)==0) then ip(25)=25 go to 60 endif endif c call setcom c maxpth=ip(82) maxt=ip(83) maxv=ip(84) maxb=ip(86) maxd=ip(85) c c if(ip(5)/=0) then call stor(ip,rp) call timer(-2_iknd) call hist2(rp,0_iknd,0_iknd) call updpth(1_iknd,1_iknd,rp) else call timer(-1_iknd) endif c c check for mpi status c if(iadapt>=6.and.iadapt<=7) then if(mpisw/=1) then ip(25)=48 go to 60 endif call timer(18_iknd) call exflag(ip(24)) call timer(11_iknd) if(ip(24)/=0) then ip(25)=24 go to 60 endif endif c c generate triangulation c if(iadapt==5) then c c check data c call dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy) if(ip(25)/=0) go to 60 c ntf=ip(1) nvf=ip(2) nbf=ip(3) c c make triangulation from skeleton c call timer(18_iknd) call tgen(ntf,maxt,maxv,ip,rp,vx,vy, + sf,itnode,ibndry,sxy) call timer(1_iknd) c endif c c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) ngf=ip(77) iudl=(ngf-1)*maxd+1 c c initialize triangluation c compute user specified triangulations c isw=0 if(ip(5)/=0.or.iadapt==5) isw=1 if(iadapt==6.and.irgn/=1) isw=0 if(isw==1) then call dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy) if(ip(25)/=0) go to 60 c c setup itdof c call mkdof(ntf,nvf,nbf,ip,itnode,ibndry,itdof) ndf=ip(4) ip(5)=0 c ndf=ip(4) maxt=ip(83) maxd=ip(85) c call gfinit(ip,maxd,gf,maxt,e) endif c c compute error estimates c isw=0 if(iadapt<=4) isw=1 if(iadapt==7) isw=1 if(iadapt==6.and.irgn==1) isw=1 if(isw==1) then c nef=ip(76) call clenbp(ntf,nef,itdof,lenbp) lenbp=lenbp*(maxt/ntf+1) allocate(bump(lenbp),ibmptr(maxt+1)) c call timer(18_iknd) call errest(ntf,nvf,nbf,ndf,ip,rp,itnode,ibndry,vx,vy, + sf,gf,e,ibmptr,bump,gf(iudl),itdof,qxy,sxy) call timer(7_iknd) call hist2(rp,-1_iknd,0_iknd) if(iadapt==0) go to 50 endif c c refine or unrefine c if(iadapt==1) then if(ndtrgt>=ndf) then call timer(18_iknd) call refine(maxt,maxv,maxb,maxd,ip,itnode,ibndry,vx,vy, + sf,gf,e,ibmptr,bump,itdof,rp,sxy) call timer(2_iknd) else call timer(18_iknd) call unrefn(maxt,maxv,maxb,maxd,ip,rp,itnode,ibndry, + vx,vy,sf,gf,e,ibmptr,bump,itdof,sxy) call timer(3_iknd) endif c c unrefine and refine c else if(iadapt==2) then if(ndtrgt>=ndf) go to 50 call timer(18_iknd) call unrefn(maxt,maxv,maxb,maxd,ip,rp,itnode,ibndry, + vx,vy,sf,gf,e,ibmptr,bump,itdof,sxy) ip(22)=ndf call timer(3_iknd) call refine(maxt,maxv,maxb,maxd,ip,itnode,ibndry,vx,vy, + sf,gf,e,ibmptr,bump,itdof,rp,sxy) ip(22)=ndtrgt call timer(2_iknd) c c mesh smoothing c else if(iadapt==3) then call timer(18_iknd) call mvemsh(ntf,nvf,nbf,ip,rp,itnode,ibndry,vx,vy, + sf,ibmptr,bump,maxt,e,itdof,sxy) call timer(6_iknd) c c uniform refinement c else if(iadapt==4) then irefn=max(1,ip(21)) ip(21)=irefn if(mpisw==1) then call timer(18_iknd) call refine(maxt,maxv,maxb,maxd,ip,itnode,ibndry,vx,vy, + sf,gf,e,ibmptr,bump,itdof,rp,sxy) call timer(2_iknd) else if(ip(20)>0) then if(mpisw==1.and.irefn>2) then ii=int(log(real(irefn,rknd))/log(2.0e0_rknd)) irefn=2**ii endif call timer(18_iknd) call hunfrm(ntf,nvf,nbf,ndf,ngf,maxt,maxv, + irefn,ip,rp,itnode,ibndry,vx,vy,sf,maxd,gf, 1 e,ibmptr,bump,itdof,1_iknd,sxy) call timer(4_iknd) else call timer(18_iknd) call punfrm(nvf,ntf,ngf,ip,itnode,ibndry, + itdof,maxd,gf) call timer(5_iknd) endif c c load balance c else if(iadapt==6) then if(irgn==1) then call timer(18_iknd) call ldbal(ntf,nbf,nproc,ip,itnode,ibndry,sf,e) call timer(13_iknd) endif call timer(18_iknd) call exflag(ip(25)) call timer(11_iknd) if(ip(25)/=0) go to 50 c c broadcast c call timer(18_iknd) call bcast(vx,vy,sf,ibndry,itnode,itdof, + ip,rp,sp,iu,ru,su,gf,e) call timer(12_iknd) ndf=ip(4) call pstat(ip,rp,ndf,itnode,itdof,e,0_iknd) c c make mesh conforming c else if(iadapt==7) then do iter=1,2 ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) lpq=max(ntf,nbf,ndf,nvf) c c cut c call timer(18_iknd) call cutr(ntf,nbf,lpq,ip,itnode,ibndry,vx,vy,sf, + maxt,e,maxd,gf,1_iknd,itdof) call timer(15_iknd) if(ip(25)/=0) go to 30 c call mkpth(nbf,ip,irgn,ipath,itnode,ibndry,itdof) if(ip(25)/=0) go to 30 c c exchange ipath data c call timer(18_iknd) call expth(ip,ipath) call timer(10_iknd) if(ip(25)/=0) go to 30 c c paste c if(iter==2) then call timer(18_iknd) mm=max(maxv,maxt,maxpth) call paste1(maxt,mm,maxb,nproc,ip,rp,itnode, + ibndry,vx,vy,sf,maxd,gf,ipath,itdof,sxy) call timer(17_iknd) else call timer(18_iknd) call paste(maxt,maxv,maxb,maxpth,ip,rp,itnode, + ibndry,ipath,vx,vy,sf,maxd,gf,1_iknd,itdof,sxy) call timer(16_iknd) endif 30 call timer(18_iknd) call exflag(ip(25)) call timer(11_iknd) if(ip(25)/=0) go to 50 enddo endif c 50 if(isw==1) deallocate(bump,ibmptr) 60 call timer(18_iknd) iflag=ip(25) c c messages c if(iflag==0) then if(itnode(3,1)==0) then write(unit=sp(11),fmt='(a19,i2,2(a6,i8),a6,i8,a1)') + 'trigen: ok (iadapt=',ip(20),', ntf=',ip(1), 1 ', nvf=',ip(2),', nbf=',ip(3),')' else write(unit=sp(11),fmt='(a19,i2,3(a6,i8),a6,i5,a1)') + 'trigen: ok (iadapt=',ip(20),', ntf=',ip(1), 1 ', nvf=',ip(2),', ndf=',ip(4),', nbf=',ip(3),')' endif else if(iflag>=82.and.iflag<=86) then write(unit=sp(11),fmt='(a12,i3,a22)') + 'trigen error',iflag,': insufficient storage' if(nproc>1) ip(24)=irgn else if(iflag==21) then write(unit=sp(11),fmt='(a12,i3,a22)') + 'trigen error',iflag,': insufficient storage' if(nproc>1) ip(24)=irgn else if(iflag==25) then write(unit=sp(11),fmt='(a12,i3,a28)') + 'trigen error',iflag,': wrong input data structure' else if(iflag==24) then write(unit=sp(11),fmt='(a12,i3,a8,i4)') + 'trigen error',iflag,': region',ip(24) else if(iflag==48) then write(unit=sp(11),fmt='(a12,i3,a12)') + 'trigen error',iflag,': mpi is off' else if(iflag==49) then write(unit=sp(11),fmt='(a12,i3,a22)') + 'trigen error',iflag,': nproc > ntf in ldbal' if(nproc>1) ip(24)=irgn else if(iflag==72) then write(unit=sp(11),fmt='(a12,i3,a23)') + 'trigen error',iflag,': interface array error' ip(72)=0 if(nproc>1) ip(24)=irgn else if(iflag>-55.and.iflag<-31) then if(nproc>1) ip(24)=irgn else write(unit=sp(11),fmt='(a12,i3,a15)') + 'trigen error',iflag,': unknown error' if(nproc>1) ip(24)=irgn endif c c********************** c ntf=ip(1) c nvf=ip(2) c nbf=ip(3) c ndf=ip(4) c call chkdof(nvf,ntf,nbf,ndf,itnode,ibndry,itdof) call chksf(vx,vy,ibndry,sf,ip,rp,sxy) c********************** c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clenbp(ntf,nef,itdof,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords cy mxord=10 len=1 do i=1,ntf call locord(i,ndof,iord,iords,itdof) len=len+iord+2 enddo len=len*nef+mxord+1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine errest(ntf,nvf,nbf,ndf,ip,rp,itnode,ibndry,vx,vy,sf, + u,e,ibmptr,bump,udl,itdof,qxy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(nvf) :: idist integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(4,3*ntf) :: itldof integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(3,ntf) :: itedge,iblock real(kind=rknd), dimension(*) :: u,vx,vy,bump,e,udl real(kind=rknd), dimension(ndf) :: u0 real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp cy external qxy,sxy c ndf=ip(4) iadapt=ip(20) if(iadapt==-4) iadapt=4 mpisw=ip(48) irgn=ip(50) nef=ip(76) ngf=ip(77) iprob=ip(6) maxt=ip(83) maxd=ip(85) c c initial error estimates c cc call exer0(maxd,maxt,vx,vy,itnode,itdof,ibndry, cc + ibedge,sf,u,ip,sxy) if(iadapt>=0) then call citdof(ntf,nvf,nbf,ip,itnode,ibndry,itedge, + ibedge,itldof,itdof,nblock,iblock,0_iknd,jtype) ndl=ip(78) call timer(7_iknd) call cbump(ndl,ntf,nbf,maxt,maxd,nef,u,vx,vy,sf, + itnode,itedge,ibedge,itldof,nblock,iblock, 1 ibndry,itdof,ibmptr,bump,e,rp,sxy,0_iknd) call timer(8_iknd) c c set scaling factors c jtype=1 if(jtype==0) then call citdof(ntf,nvf,nbf,ip,itnode,ibndry,itedge, + ibedge,itldof,itdof,nblock,iblock,1_iknd,jtype) ndl=ip(78) call timer(7_iknd) call cbump(ndl,ntf,nbf,maxt,maxd,nef,u,vx,vy,sf, + itnode,itedge,ibedge,itldof,nblock,iblock, 1 ibndry,itdof,ibmptr,bump,e,rp,sxy,1_iknd) call timer(8_iknd) endif call cnorms(ip,rp,itnode,itedge,vx,vy,ibmptr,bump, + maxd,nef,u,ndf,itdof,maxt,e) else call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) call usrfn(ntf,itnode,itdof,iprob,vx,vy,nef, + ngf,maxd,maxt,u,e,rp,ibmptr,bump,u0,qxy) call cnorms(ip,rp,itnode,itedge,vx,vy,ibmptr,bump, + maxd,1_iknd,u0,ndf,itdof,maxt,e) endif c cc call exer1(maxd,maxt,vx,vy,itnode,itdof,ibndry, cc + ibedge,sf,u,e,ip,rp,sxy) if(mpisw==1) call pstat(ip,rp,ndf,itnode,itdof,e,1_iknd) if(mpisw==1.and.abs(iadapt)<=4) then c c compute distance function in graph c call cgdist(nvf,ntf,nbf,idist,irgn,itnode,ibndry) c itheta=1 ifact=2 r0=1.0e-1_rknd do i=1,ntf if(itnode(4,i)==irgn) cycle ii=min(idist(itnode(1,i)),idist(itnode(2,i)), + idist(itnode(3,i)))-itheta if(ii>0) then ss=1.0e-6_rknd call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof ss=max(ss,abs(udl(idof(j)))) enddo ratio=r0*min(ss,1.0e0_rknd)/real(ifact*ii,rknd) else ratio=r0 endif do j=ibmptr(i),ibmptr(i+1)-1 bump(j)=bump(j)*ratio enddo enddo c endif cc call cfact(itnum,expo) cc write(6,*) 'errest',ndf,itnum,expo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine refine(maxt,maxv,maxb,maxd,ip,itnode,ibndry,vx,vy, + sf,gf,e,ibmptr,bump,itdof,rp,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(maxv) :: iseed,vtype integer(kind=iknd), dimension(maxt) :: p,q integer(kind=iknd), dimension(3,maxt) :: itedge integer(kind=iknd), dimension(2,maxb) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(3) :: iords,jords,iv real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(2,*) :: sf cy external sxy c c check to see if we have solved problem on current finest grid c ndf=ip(4) nef=ip(76) ngf=ip(77) ntf=ip(1) nvf=ip(2) nbf=ip(3) iflag=0 mxord=9 rl=rp(21) iadapt=ip(20) mpisw=ip(48) nproc=ip(49) irgn=ip(50) c c controls on refinement c sfave=rp(82)*2.0e0 relerp=rp(86) thresh=2.0e-1_rknd if(abs(iadapt)==4.and.mpisw==1) then kref=-1 ksw=0 irefn=max(1,ip(21)) irtype=1 if(iadapt>0) then irtype=1 qz=real(max(2,irefn)**2-1,rknd) else irtype=-1 qz=sqrt(real(nvf,rknd)/real(ndf,rknd)) qz=(1.0e0_rknd+qz*real(irefn,rknd))**2-qz**2 endif qz=1.0e0_rknd+qz/real(nproc,rknd) ndtrgt=min(ip(22),maxd,int(real(ndf,rknd)*qz)) if(ndf>=ndtrgt) return etrgt=1.0e-1_rknd do i=1,ntf if(itnode(4,i)==irgn) then e(i,1)=10.0e0_rknd else e(i,1)=0.0e0_rknd endif enddo else kref=1 ksw=1 irtype=ip(18) qz=sqrt(real(nvf,rknd)/real(ndf,rknd)) cc qz=(1.0e0_rknd+qz) qz=(4.0e0_rknd)**qz ndtrgt=min(ip(22),maxd,int(real(ndf,rknd)*qz)) if(ndf>=ndtrgt) return etrgt=rp(87)/2.0e0_rknd c c initialize errors c do i=1,ntf call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(i,1)=e1 enddo endif c c initialize itedge c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag) if(jflag/=0) then ip(25)=jflag return endif c c add interfaces to itedge c call cedge5(nbf,itedge,ibedge,1_iknd) c c initialize heap c do i=1,ntf p(i)=i q(i)=i enddo nn=ntf/2 do k=nn,1,-1 call updhp(k,ntf,p,q,e,0_iknd) enddo c ndfi=ndf do ii=1,ndtrgt itri0=p(1) call locord(itri0,ndof,iord,iords,itdof) if(e(itri0,1)<=etrgt) exit c if(irtype==1) then ihref=1 call rotst1(itri0,itnode,itedge,ibndry,vx,vy,isize) if(isize==1) ihref=2 elseif(irtype==-1) then ihref=0 if(iord>=mxord) ihref=2 else c c test for h-p refinement c call rotst1(itri0,itnode,itedge,ibndry,vx,vy,isize) if(iord>=mxord.or.e(itri0,2)>sfave + .or.relerp>thresh) then ihref=1 if(isize==1) then ihref=0 if(iord>=mxord) ihref=2 endif else ihref=0 if(iord>=mxord) then ihref=1 if(isize==1) ihref=2 endif endif endif c if(ihref==1) then if(ndfi+iord**2/2>=ndtrgt) exit 45 call etst1(itri0,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) call newnot(itri,iedge,nvf,ntf,nbf,ndf,itnode, + itedge,ibndry,ibedge,itdof,vx,vy,sf,rl, 1 maxv,maxt,maxb,maxd,gf,ngf,nef, 2 ibmptr,bump,p,q,e,kref,incdf,iflag,sxy) ndfi=ndfi+incdf c if(iflag/=0) exit if(isw==0) go to 45 else if(ihref==0) then c c decide on new order c jord=iord+1 nndof=((jord+1)*(jord+2))/2 if(ndfi+(nndof-ndof)>=ndtrgt) exit do j=1,3 jords(j)=0 enddo call p2qdof(itri0,jord,jords,ndf,ngf,maxd, + itedge,ibedge,itdof,gf,incdf,iv,iflag) if(kref==1) then e(itri0,1)=0.0e0_rknd else e(itri0,1)=e(itri0,1)-1.0e0_rknd endif call updhp(1_iknd,ntf,p,q,e,0_iknd) do j=1,3 if(iv(j)==0) cycle jtri=iv(j) if(kref==1) then e(jtri,1)=0.0e0_rknd else e(jtri,1)=e(jtri,1)-1.0e0_rknd endif jj=q(jtri) call updhp(jj,ntf,p,q,e,0_iknd) enddo ndfi=ndfi+incdf else e(itri0,1)=0.0e0_rknd call updhp(1_iknd,ntf,p,q,e,0_iknd) endif enddo c c degree edge swapping, geometry improvement c call clnup3(ntf,ndf,ngf,maxd,gf,itdof) call eswapa(ntf,nvf,nbf,ngf,nef,itnode,itedge,ibndry,ibedge, + vx,vy,ibmptr,bump,maxt,e,ksw,1_iknd,itdof,maxd,gf) call cedge5(nbf,itedge,ibedge,0_iknd) c c angmin=1.0e-3_rknd arcmax=0.26e0_rknd call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) itmax=2 call mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,itnode, + itedge,ibndry,ibedge,sxy) c c update e c if(kref==1) then do i=1,ntf if(e(i,1)<=0) cycle call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(i,1)=e1 enddo endif c ip(25)=iflag ip(1)=ntf ip(2)=nvf ip(3)=nbf ip(4)=ndf c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mvemsh(ntf,nvf,nbf,ip,rp,itnode,ibndry,vx,vy, + sf,ibmptr,bump,maxt,e,itdof,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(nvf) :: vtype,iseed integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(*) :: rp cy external sxy c c move mesh c c angmin=1.0e-3_rknd arcmax=0.26e0_rknd nef=ip(76) rl=rp(21) c c initailize iseed, vtype c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag) if(jflag/=0) then ip(25)=jflag return endif call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) c c move knots according to error c itmax=4 call mfe1(nvf,nbf,itmax,vx,vy,sf,iseed,vtype, + itnode,itedge,ibndry,ibedge,nef,ibmptr,bump,itdof,sxy) c c move knots according to geometry c itmax=2 call mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,itnode, + itedge,ibndry,ibedge,sxy) c c update e c do i=1,ntf call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(i,1)=e1 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,vx,vy,sf,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(nvf) :: vtype,iseed integer(kind=iknd), dimension(2,nbf) :: ibedge real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(*) :: rp cy external sxy c c move mesh c angmin=1.0e-3_rknd arcmax=0.26e0_rknd rl=rp(21) c c initailize iseed, vtype c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag) if(jflag/=0) then ip(25)=jflag return endif call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) c c move knots according to geometry c itmax=100 call mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,itnode, + itedge,ibndry,ibedge,sxy) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine unrefn(maxt,maxv,maxb,maxd,ip,rp,itnode,ibndry, + vx,vy,sf,gf,e,ibmptr,bump,itdof,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(maxv) :: iseed,vtype integer(kind=iknd), dimension(maxt) :: p,q,mark integer(kind=iknd), dimension(3,maxt) :: itedge,icurv integer(kind=iknd), dimension(2,maxb) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(3) :: iords,iv,jords real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxt) :: qual cy external sxy c c c check to see if we have solved problem on current finest grid c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) irtype=ip(18) nef=ip(76) ngf=ip(77) rl=rp(21) c c control parameters c qz=sqrt(real(nvf,rknd)/real(ndf,rknd)) cc qz=(1.0e0_rknd+qz) qz=(4.0e0_rknd)**qz ndtrgt=max(ip(22),int(real(ndf,rknd)/qz)) if(rp(15)<=0.0e0_rknd.or.rp(15)>1.0e0_rknd) rp(15)=1.0e0_rknd c if(ndf<=ndtrgt) return c sfave=rp(82)*2.0e0_rknd relerp=rp(86) thresh=2.0e-1_rknd etrgt=rp(87)/2.0e0_rknd angmin=1.0e-3_rknd arcmax=0.26e0_rknd c c initialize iseed, vtype, itedge c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag) if(jflag/=0) then ip(25)=jflag return endif call ccurv(ntf,nbf,ibndry,ibedge,icurv) call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) call cedge5(nbf,itedge,ibedge,1_iknd) c c initialize qual, p,q c c emax=0.0e0_rknd do i=1,ntf call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(i,1)=e1 qual(i)=-e1 emax=max(emax,e1) mark(i)=0 p(i)=i q(i)=i enddo c c initialize heap c nn=ntf/2 do k=nn,1,-1 call updhp(k,ntf,p,q,qual,0_iknd) enddo last=ntf ndfi=ndf c c main elimination loop c do nn=ntf,1,-1 if(last<=0) exit itri0=p(1) if(qual(itri0)<=-etrgt) exit call locord(itri0,ndof,iord,iords,itdof) c if(irtype==1) then ihuref=1 elseif(irtype==-1) then ihuref=0 else c c test for h-p unrefinement c if(iord<=1) then ihuref=1 else if(e(itri0,2)>sfave.and.relerp>thresh) then ihuref=1 else ihuref=0 endif endif if(ihuref==1) then p(1)=p(last) p(last)=itri0 q(p(last))=last q(p(1))=1 last=last-1 call updhp(1_iknd,last,p,q,qual,0_iknd) c call rmtst(itri0,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,1_iknd) if(iedge==0) cycle if(ndfi-iord**2/2<=ndtrgt) exit call rmknot(iedge,itri0,iv,itnode,itedge,ibndry, + ibedge,itdof,vx,vy,sf,nef,ngf,maxd,gf,ibmptr, 1 bump,maxt,e,iseed,vtype,incdf,1_iknd,rl,sxy) ndfi=ndfi+incdf call rmupd(nn,last,iv,maxt,itnode,ibndry,itedge, + ibedge,vx,vy,sf,rl,e,iseed,vtype,p,q,mark,qual, 1 angmin,arcmax,sxy) else if(iord==1) then p(1)=p(last) p(last)=itri0 q(p(last))=last q(p(1))=1 last=last-1 call updhp(1_iknd,last,p,q,qual,0_iknd) cycle endif jord=iord-1 nndof=((jord+1)*(jord+2))/2 if(ndfi+(nndof-ndof)<=ndtrgt) exit c c update bump array c do ifn=1,nef ii=ibmptr(itri0)+(ifn-1)*(iord+1) call elel2p(itri0,iord,itnode,ibndry,icurv, + itdof,vx,vy,sf,gf(1,ifn),bump(ii), 1 bump,0_iknd,sxy) enddo c do j=1,3 jords(j)=0 enddo call p2qdof(itri0,jord,jords,ndf,ngf,maxd, + itedge,ibedge,itdof,gf,incdf,iv,iflag) ndfi=ndfi+incdf c call tqual(itri0,itnode,vx,vy,ibmptr,bump,itdof, + nef,e1,e2) e(itri0,1)=e1 e(itri0,2)=1.0e0_rknd c qual(itri0)=-e(itri0,1) qual(itri0)=-emax call updhp(1_iknd,last,p,q,qual,0_iknd) endif enddo c call clnup(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,sf,ibmptr,bump,iseed,gf,maxd,ngf,itdof) c c improve geometry c call eswapa(ntf,nvf,nbf,ngf,nef,itnode,itedge,ibndry,ibedge, + vx,vy,ibmptr,bump,maxt,e,1_iknd,1_iknd,itdof,maxd,gf) call cedge5(nbf,itedge,ibedge,0_iknd) c c call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) itmax=2 call mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,itnode, + itedge,ibndry,ibedge,sxy) c c update e c do i=1,ntf call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(i,1)=e1 enddo c ip(1)=ntf ip(2)=nvf ip(3)=nbf ip(4)=ndf c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rmupd(nn,last,iv,maxt,itnode,ibndry,itedge,ibedge, + vx,vy,sf,rl,e,iseed,vtype,p,q,mark,qual, 1 angmin,arcmax,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: p,q,mark,iseed,vtype integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(500) :: elist,tlist,vlist, + blist,elist0,tlist0,vlist0,blist0 integer(kind=iknd), dimension(3) :: iv real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(*) :: vx,vy,qual cy external sxy c c remove companion element if there was one c jtri=iv(3) if(jtri>0) then kk=q(jtri) if(kk==last) then last=last-1 else p(kk)=p(last) p(last)=jtri q(p(last))=last q(p(kk))=kk last=last-1 call updhp(kk,last,p,q,qual,1_iknd) endif endif c c update vertices in ring around deleted vertex c do m=1,2 if(iv(m)==0) cycle c call cirlst(iv(m),itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) call tstvty(iv(m),itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist,tlist,elist, 1 len,sxy) is=1 if(vtype(iv(m))>=7) is=2 do jj=is,len+1 j=vlist(jj) if(j==0) cycle call cirlst(j,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist0,tlist0,elist0,blist0,len0) call tstvty(j,itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist0,tlist0, 1 elist0,len0,sxy) js=1 if(vtype(j)>=7) js=2 do mm=js,len0 k=tlist0(mm) if(mark(k)/=nn) then qual(k)=-e(k,1) kk=q(k) call updhp(kk,last,p,q,qual,1_iknd) mark(k)=nn endif enddo enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine hunfrm(mtf,mvf,mbf,mdf,ngf,maxt,maxv,irefn,ip,rp, + itnode,ibndry,vx,vy,sf,maxd,gf,e,ibmptr,bump,itdof,isw,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(4*mvf) :: ja,jv integer(kind=iknd), dimension(mtf) :: mark integer(kind=iknd), dimension(2,mbf) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(irefn+1,irefn+1) :: mapv integer(kind=iknd), dimension(9*irefn+1,9*irefn+1) :: mapd integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(3) :: iords,iords0 integer(kind=iknd), dimension(9*irefn+1) :: mape integer(kind=iknd), dimension(3*irefn+1,3*irefn+1) :: mapf integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(*) :: bump,vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3) :: c real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(100) :: gv,rp real(kind=rknd), dimension(mdf,ngf) :: gf0 common /pltmg1/ic(3,363),jc(12) cy external sxy data index/1,2,3,2,3,1,3,1,2/ c c this routine does uniform refinement c len1=irefn+1 c len2=iord*irefn+1 c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) nef=ip(76) cc irefn=ip(21) if(irefn<=1) return maxb=ip(86) nhole=(2*nvf-ntf-nbf-2)/2 ntnew=ntf*irefn**2 rl=rp(21) if(ntnew>maxt) then ip(25)=83 return endif nbnew=nbf*irefn if(nbnew>maxb) then ip(25)=86 return endif nvnew=(ntnew+nbnew+2-2*nhole)/2 if(nvnew>maxv) then ip(25)=84 return endif do ifn=1,ngf do i=1,ndf gf0(i,ifn)=gf(i,ifn) enddo enddo c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,jflag) if(jflag/=0) then ip(25)=jflag return endif c c comput ja c maxlnk=4*nvf call setgr(ntf,nvf,nbf,itnode,ibndry,ja,maxlnk) do i=1,ja(nvf+1)-1 jv(i)=0 enddo c krefn=3*irefn nev=(irefn-2)*(irefn-1)/2 ned=ja(nvf+1)-ja(1) call dcount(ntf,nvf,nbf,ndf,irefn,itdof,itnode, + ibndry,ndnew,1_iknd) if(ndnew>maxd) then ip(25)=85 return endif c pi=3.141592653589793e0_rknd c c mark triangles with curved edges c do i=1,ntf mark(i)=0 enddo do i=1,nbf if(ibndry(3,i)==0) cycle it=ibedge(1,i)/4 mark(it)=i if(ibedge(2,i)==0) cycle it=ibedge(2,i)/4 mark(it)=i enddo c c initalize boundary edges c nv0=nvf 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=real(kk,rknd)/real(irefn,rknd) c1=1.0e0_rknd-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(iv10) then call arc(vx(m1),vy(m1),vx(m2),vy(m2), + sf(1,i),sf(2,i),theta1,theta2,r,alen) k1=ibedge(1,i)/4 k2=ibedge(1,i)-4*k1 m3=itnode(k2,k1) dt=(theta2-theta1)/real(irefn,rknd) 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*real(m,rknd))*pi xx=sf(1,i)+r*cos(tt)-vx(m3) yy=sf(2,i)+r*sin(tt)-vy(m3) c1=(xx*y2-yy*x2)/det c2=(x1*yy-y1*xx)/det c3=1.0e0_rknd-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 else if(ibndry(3,i)<0) then k1=ibedge(1,i)/4 k2=ibedge(1,i)-4*k1 if(iv1==m1) then theta1=sf(1,i) theta2=sf(2,i) else theta1=sf(2,i) theta2=sf(1,i) endif dt=(theta2-theta1)/real(irefn,rknd) do m=1,irefn-1 tt=theta1+dt*real(m,rknd) do mm=1,12 values(mm)=0.0e0_rknd enddo itag=-ibndry(3,i) call sxy(rl,tt,itag,values) vx(m12)=values(1) vy(m12)=values(2) m12=m12+1 enddo if(iv1==m2) dt=-dt endif c c now add boundary edges c do m=1,irefn if(m==1) then ibndry(2,i)=n12 if(ibndry(3,i)<0) sf(2,i)=sf(1,i)+dt else nbf=nbf+1 do j=1,7 ibndry(j,nbf)=ibndry(j,i) enddo if(ibndry(3,i)>=0) then do j=1,2 sf(j,nbf)=sf(j,i) enddo else sf(1,nbf)=sf(1,i)+real(m-1,rknd)*dt sf(2,nbf)=sf(1,i)+real(m,rknd)*dt endif ibndry(1,nbf)=n12 ibndry(2,nbf)=n12+inc n12=n12+inc endif enddo ibndry(2,nbf)=iv2 if(ibndry(4,i)<0) then k=-ibndry(4,i) ibeg=nb0+(irefn-1)*(i-1) kend=nb0+(irefn-1)*k do j=1,irefn if(j==1) then ibndry(4,i)=-kend else if(j==irefn) then ibndry(4,ibeg+j-1)=-k else ibndry(4,ibeg+j-1)=-(kend-j+1) endif enddo endif if(ibndry(5,i)/=0) then is=ibndry(6,i)+1 ii=irefn*is-1 do m=1,irefn if(m==1) then ibndry(6,i)=ii else ibndry(6,nbf-irefn+m)=ii endif ii=ii+1 enddo endif enddo c c add dofs on existing edges c do it=1,ntf call l2gmap(it,idof,ndof,iord,iords,itdof) do iedge=1,3 i1=index(2,iedge) i2=index(3,iedge) iv1=itnode(i1,it) iv2=itnode(i2,it) call jamap0(iv1,iv2,j,jj,ja,0_iknd) if(jv(j)/=0) cycle len=iords(iedge)-1 jrefn=(len+1)*irefn jv(j)=ndf+1 mape(1)=itdof(i1,it) mape(jrefn+1)=itdof(i2,it) c c old data is near smaller vertex, increase towards larger vertex c jj=itdof(3+iedge,it) if(iv10) then do j=1,len mape(j+1)=jj+j-1 enddo else do j=1,len mape(j+1)=-(jj+j-1) enddo endif do j=len+2,jrefn ndf=ndf+1 mape(j)=ndf enddo else if(jj>0) then do j=1,len mape(jrefn-len+j)=jj+j-1 enddo else do j=1,len mape(jrefn-len+j)=-(jj+j-1) enddo endif do j=jrefn-len,2,-1 ndf=ndf+1 mape(j)=ndf enddo endif do j=2,jrefn c(iedge)=0.0e0_rknd c(i2)=real(j-1,rknd)/real(jrefn,rknd) c(i1)=1.0e0_rknd-c(i2) call beval1(c,gv,iord,iords) do ifn=1,ngf sum=0.0e0_rknd do m=1,ndof sum=sum+gf0(idof(m),ifn)*gv(m) enddo gf(mape(j),ifn)=sum enddo enddo enddo enddo c c make new triangles, dofs c do it=1,ntf call l2gmap(it,idof,ndof,iord,iords,itdof) jrefn=iord*irefn c c initialize, transfer known data c iv1=itnode(1,it) iv2=itnode(2,it) iv3=itnode(3,it) do i=1,krefn+1 do j=1,krefn+2-i mapf(i,j)=0 enddo enddo do i=1,jrefn+1 do j=1,jrefn+2-i mapd(i,j)=0 enddo enddo do i=1,irefn+1 do j=1,irefn+2-i mapv(i,j)=0 enddo enddo c mapf(1,1)=itdof(1,it) mapf(krefn+1,1)=itdof(2,it) mapf(1,krefn+1)=itdof(3,it) c mapv(1,1)=iv1 mapv(irefn+1,1)=iv2 mapv(1,irefn+1)=iv3 c c 1-2 edge c call jamap0(iv1,iv2,j,jj,ja,0_iknd) nn=jv(j) len=iords(3)-1 if(iv10) then kk=itdof(6,it) if(kk>0) then mapf(2,1)=kk mapf(3,1)=kk+len-1 else mapf(2,1)=-kk mapf(3,1)=-kk-len+1 endif endif do i=4,krefn,3 mapf(i,1)=nn nn=nn+1 if(len>0) then mapf(i+1,1)=nn nn=nn+len mapf(i+2,1)=nn-1 endif enddo else mm=nv0+(irefn-1)*(j-ja(1))+irefn-1 inc=-1 if(len>0) then kk=itdof(6,it) if(kk>0) then mapf(krefn-1,1)=kk mapf(krefn,1)=kk+len-1 else mapf(krefn-1,1)=-kk mapf(krefn,1)=-kk-len+1 endif endif do i=krefn-2,2,-3 mapf(i,1)=nn nn=nn+1 if(len>0) then mapf(i-1,1)=nn nn=nn+len mapf(i-2,1)=nn-1 endif enddo endif do i=1,irefn+1 if(mapv(i,1)==0) then mapv(i,1)=mm mm=mm+inc endif enddo c c 1-3 edge c call jamap0(iv1,iv3,j,jj,ja,0_iknd) nn=jv(j) len=iords(2)-1 if(iv10) then kk=itdof(5,it) if(kk>0) then mapf(1,3)=kk mapf(1,2)=kk+len-1 else mapf(1,3)=-kk mapf(1,2)=-kk-len+1 endif endif do i=4,krefn,3 mapf(1,i)=nn nn=nn+1 if(len>0) then mapf(1,i+1)=nn nn=nn+len mapf(1,i+2)=nn-1 endif enddo else mm=nv0+(irefn-1)*(j-ja(1))+irefn-1 inc=-1 if(len>0) then kk=itdof(5,it) if(kk>0) then mapf(1,krefn)=kk mapf(1,krefn-1)=kk+len-1 else mapf(1,krefn)=-kk mapf(1,krefn-1)=-kk-len+1 endif endif do i=krefn-2,2,-3 mapf(1,i)=nn nn=nn+1 if(len>0) then mapf(1,i-1)=nn nn=nn+len mapf(1,i-2)=nn-1 endif enddo endif do i=1,irefn+1 if(mapv(1,i)==0) then mapv(1,i)=mm mm=mm+inc endif enddo c c 2-3 edge c call jamap0(iv2,iv3,j,jj,ja,0_iknd) nn=jv(j) len=iords(1)-1 if(iv20) then kk=itdof(4,it) if(kk>0) then mapf(krefn,2)=kk mapf(krefn-1,3)=kk+len-1 else mapf(krefn,2)=-kk mapf(krefn-1,3)=-kk-len+1 endif endif do i=4,krefn,3 mapf(krefn+2-i,i)=nn nn=nn+1 if(len>0) then mapf(krefn+1-i,i+1)=nn nn=nn+len mapf(krefn-i,i+2)=nn-1 endif enddo else mm=nv0+(irefn-1)*(j-ja(1))+irefn-1 inc=-1 if(len>0) then kk=itdof(4,it) if(kk>0) then mapf(3,krefn-1)=kk mapf(2,krefn)=kk+len-1 else mapf(3,krefn-1)=-kk mapf(2,krefn)=-kk-len+1 endif endif do i=krefn-2,2,-3 mapf(krefn+2-i,i)=nn nn=nn+1 if(len>0) then mapf(krefn+3-i,i-1)=nn nn=nn+len mapf(krefn+4-i,i-2)=nn-1 endif enddo endif do i=1,irefn+1 if(mapv(irefn+2-i,i)==0) then mapv(irefn+2-i,i)=mm mm=mm+inc endif enddo c c dofs on interior edges and vertices c do j=4,krefn-2,3 jj=(j-1)*iord/3+1 do i=1,krefn+1-j,3 ii=(i-1)*iord/3+1 if(mapf(i,j)==0) then ndf=ndf+1 mapf(i,j)=ndf mapd(ii,jj)=ndf endif if(iord>1) then mapf(i+1,j)=ndf+1 ndf=ndf+iord-1 mapf(i+2,j)=ndf do k=1,iord-1 mapd(ii+k,jj)=mapf(i+1,j)+k-1 enddo endif if(mapf(j,i)==0) then ndf=ndf+1 mapf(j,i)=ndf mapd(jj,ii)=ndf endif if(iord>1) then mapf(j,i+1)=ndf+1 ndf=ndf+iord-1 mapf(j,i+2)=ndf do k=1,iord-1 mapd(jj,ii+k)=mapf(j,i+1)+k-1 enddo endif if(mapf(krefn+3-j-i,i)==0) then ndf=ndf+1 mapf(krefn+3-j-i,i)=ndf mapd(jrefn+3-jj-ii,ii)=ndf endif if(iord>1) then mapf(krefn+2-j-i,i+1)=ndf+1 ndf=ndf+iord-1 mapf(krefn+1-j-i,i+2)=ndf do k=1,iord-1 mapd(jrefn+3-jj-ii-k,ii+k)= + mapf(krefn+2-j-i,i+1)+k-1 enddo endif enddo enddo if(iord>2) then nn=((iord-1)*(iord-2))/2 mapf(2,2)=itdof(7,it) do i=1,krefn+1 do j=1,krefn+2-i if(mapf(i,j)==0) then mapf(i,j)=ndf+1 ndf=ndf+nn endif enddo enddo endif c c interior vertices c mm=nv0+(irefn-1)*ned+(it-1)*nev+1 do i=1,irefn+1 do j=1,irefn+2-i if(mapv(i,j)/=0) cycle mapv(i,j)=mm c2=real(i-1,rknd)/real(irefn,rknd) c3=real(j-1,rknd)/real(irefn,rknd) c1=1.0e0_rknd-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 enddo enddo c c smooth interior vertices for elements with curved edges c if(mark(it)<=0) go to 20 itmax=100 tol=max(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.0e-2_rknd tol=1.0e-2_rknd do itnum=1,itmax cc=0.0e0_rknd do i=2,irefn-1 do j=2,irefn+1-i xx=(vx(mapv(i,j-1))+vx(mapv(i,j+1))+ + vx(mapv(i+1,j))+vx(mapv(i-1,j))+ 1 vx(mapv(i+1,j-1))+ 2 vx(mapv(i-1,j+1)))/6.0e0_rknd yy=(vy(mapv(i,j-1))+vy(mapv(i,j+1))+ + vy(mapv(i+1,j))+vy(mapv(i-1,j))+ 1 vy(mapv(i+1,j-1))+ 2 vy(mapv(i-1,j+1)))/6.0e0_rknd cc=max(cc,abs(xx-vx(mapv(i,j))), + abs(yy-vy(mapv(i,j)))) vx(mapv(i,j))=xx vy(mapv(i,j))=yy enddo enddo if(cc<=tol) go to 20 enddo c c new triangles c 20 kk=ntf+(irefn**2-1)*(it-1)+1 k1=ntf+(irefn**2-1)*it c c initialize dofs c do i=kk,k1 do j=1,8 itdof(j,i)=itdof(j,it) enddo do j=1,5 itnode(j,i)=itnode(j,it) enddo enddo c c kk=it do i=1,irefn do j=1,i ij=i-j+1 ii=3*(i-j) jj=3*(j-1) c itnode(1,kk)=mapv(ij,j) itnode(2,kk)=mapv(ij+1,j) itnode(3,kk)=mapv(ij,j+1) c itdof(1,kk)=mapf(ii+1,jj+1) itdof(2,kk)=mapf(ii+4,jj+1) itdof(3,kk)=mapf(ii+1,jj+4) c itdof(4,kk)=mapf(ii+3,jj+2) if(mapf(ii+2,jj+3)itdof(3,kk)) then itdof(4,kk)=-itdof(4,kk) endif endif c itdof(5,kk)=mapf(ii+1,jj+3) if(mapf(ii+1,jj+2)itdof(1,kk)) then itdof(5,kk)=-itdof(5,kk) endif endif c itdof(6,kk)=mapf(ii+2,jj+1) if(mapf(ii+3,jj+1)itdof(2,kk)) then itdof(6,kk)=-itdof(6,kk) endif endif c itdof(7,kk)=mapf(ii+2,jj+2) c do k=1,3 iords0(k)=iord enddo if(i==irefn) iords0(1)=iords(1) if(j==i) iords0(2)=iords(2) if(j==1) iords0(3)=iords(3) itdof(8,kk)=iord+16*iords0(1)+256*iords0(2) + +4096*iords0(3) c mm=itdof(7,kk) ii=iord*(i-j)+1 jj=iord*(j-1)+1 do k=jc(iord)+3*iord,jc(iord+1)-1 mapd(ii+ic(2,k),jj+ic(3,k))=mm mm=mm+1 enddo c if(i==1) then kk=ntf+(irefn**2-1)*(it-1)+1 else kk=kk+1 endif c c there is no last backward facing traingle in this row c if(j==i) cycle ij=i-j+1 ii=3*(i-j) jj=3*j c itnode(1,kk)=mapv(ij,j+1) itnode(2,kk)=mapv(ij-1,j+1) itnode(3,kk)=mapv(ij,j) c itdof(1,kk)=mapf(ii+1,jj+1) itdof(2,kk)=mapf(ii-2,jj+1) itdof(3,kk)=mapf(ii+1,jj-2) c itdof(4,kk)=mapf(ii-1,jj) if(mapf(ii,jj-1)itdof(3,kk)) then itdof(4,kk)=-itdof(4,kk) endif endif c itdof(5,kk)=mapf(ii+1,jj-1) if(mapf(ii+1,jj)itdof(1,kk)) then itdof(5,kk)=-itdof(5,kk) endif endif c itdof(6,kk)=mapf(ii,jj+1) if(mapf(ii-1,jj+1)itdof(2,kk)) then itdof(6,kk)=-itdof(6,kk) endif endif c itdof(7,kk)=mapf(ii,jj) mm=itdof(7,kk) ii=iord*(i-j)+1 jj=iord*j+1 do k=jc(iord)+3*iord,jc(iord+1)-1 mapd(ii-ic(2,k),jj-ic(3,k))=mm mm=mm+1 enddo itdof(8,kk)=iord+16*iord+256*iord+4096*iord c kk=kk+1 enddo enddo c c grid function interpolations c do i=2,jrefn do j=2,jrefn+1-i if(mapd(i,j)<=0) stop 9212 c(2)=real(i-1,rknd)/real(jrefn,rknd) c(3)=real(j-1,rknd)/real(jrefn,rknd) c(1)=1.0e0_rknd-c(2)-c(3) call beval1(c,gv,iord,iords) do ifn=1,ngf sum=0.0e0_rknd do m=1,ndof sum=sum+gf0(idof(m),ifn)*gv(m) enddo gf(mapd(i,j),ifn)=sum enddo enddo enddo c c update bump, e c if(isw==1) then n1=ntf+(irefn**2-1)*(it-1)+1 n2=kk-1 call tqual(it,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(it,1)=e1 do i=n1,n2 ibmptr(i+1)=ibmptr(i)+ibmptr(it+1)-ibmptr(it) nbi=ibmptr(it)-ibmptr(i) do j=ibmptr(i),ibmptr(i+1)-1 bump(j)=bump(nbi+j) enddo call tqual(i,itnode,vx,vy,ibmptr,bump, + itdof,nef,e1,e2) e(i,1)=e1 e(i,2)=e(it,2) enddo endif enddo c nvf=nv0+(irefn-1)*ned+ntf*nev ntf=ntf*irefn**2 c ip(1)=ntf ip(2)=nvf ip(3)=nbf ip(4)=ndf c ip(25)=0 c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine punfrm(nvf,ntf,ngf,ip,itnode,ibndry,itdof,maxd,gf) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(4*nvf) :: ja,jv integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(maxd) :: p,q integer(kind=iknd), dimension(ntf) :: jt integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(100,ngf) :: g0 real(kind=rknd), dimension(100) :: gv real(kind=rknd), dimension(3) :: c common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c this routine does uniform p-refinement c mxord=9 irefn=ip(21) if(irefn<=0) return nbf=ip(3) ndf=ip(4) maxd=ip(85) c c comput ja c maxlnk=4*nvf call setgr(ntf,nvf,nbf,itnode,ibndry,ja,maxlnk) do i=1,ja(nvf+1)-1 jv(i)=0 enddo c c layout new order, check storage c call dcount(ntf,nvf,nbf,ndf,irefn,itdof,itnode, + ibndry,ndnew,0_iknd) if(ndnew>maxd) then ip(25)=85 endif do i=1,ndf q(i)=0 p(i)=0 enddo ndf0=ndf ndf=0 m0=ndf0 do it=1,ntf call locord(it,ndof,iord,iords,itdof) if(iord+irefn>mxord) then ip(25)=21 return endif c c vertices c do j=1,3 k=itdof(j,it) if(q(k)==0) then ndf=ndf+1 q(k)=ndf p(ndf)=k endif enddo c c edges c do j=1,3 iv2=itnode(index(2,j),it) iv3=itnode(index(3,j),it) call jamap0(iv2,iv3,k,kk,ja,0_iknd) if(jv(k)/=0) cycle jv(k)=ndf+1 len=iords(j)-1 if(itdof(3+j,it)>0) then istrt=itdof(3+j,it) istop=istrt+len-1 else istop=-itdof(3+j,it) istrt=istop-len+1 endif if(len>0) then do m=istrt,istop ndf=ndf+1 q(m)=ndf p(ndf)=m enddo endif do m=1,irefn m0=m0+1 if(m0>maxd) then ip(25)=85 return endif ndf=ndf+1 q(m0)=ndf p(ndf)=m0 enddo enddo c c interior c jt(it)=ndf+1 if(iord>2) then istrt=itdof(7,it) istop=istrt+(iord-2)*(iord-1)/2-1 do m=istrt,istop ndf=ndf+1 q(m)=ndf p(ndf)=m enddo endif if(iord+irefn>2) then len=((2*iord+irefn-3)*irefn)/2 do m=1,len m0=m0+1 if(m0>maxd) then ip(25)=85 return endif ndf=ndf+1 q(m0)=ndf p(ndf)=m0 enddo endif enddo c c reorder c ip(4)=ndf call dorder(ip,p,q,itdof,maxd,gf) c c interpolate interior nodes c do it=1,ntf call l2gmap(it,idof,ndof,iord,iords,itdof) kord=iord+irefn if(kord>2) then itdof(7,it)=jt(it) do ifn=1,ngf do m=1,ndof g0(m,ifn)=gf(idof(m),ifn) enddo enddo do i=jc(kord)+3*kord,jc(kord+1)-1 do j=1,3 c(j)=real(ic(j,i),rknd)/real(kord,rknd) enddo call beval1(c,gv,iord,iords) do ifn=1,ngf sum=0.0e0_rknd do m=1,ndof sum=sum+g0(m,ifn)*gv(m) enddo gf(jt(it),ifn)=sum enddo jt(it)=jt(it)+1 enddo endif enddo c c interpolate edges c do it=1,ntf call l2gmap(it,idof,ndof,iord,iords,itdof) do j=1,3 iv2=itnode(index(2,j),it) iv3=itnode(index(3,j),it) call jamap0(iv2,iv3,k,kk,ja,0_iknd) len=iords(j)-1 kord=len+irefn if((itdof(3+j,it)>0).or. + ((itdof(3+j,it)==0).and.(iv20) then do ifn=1,ngf do m=1,len g0(m+1,ifn)=gf(jv(k)+m-1,ifn) enddo enddo endif do jj=1,kord c(2)=real(jj,rknd)/real(kord+1,rknd) c(1)=1.0e0_rknd-c(2) call bevale(c,gv,len+1) do ifn=1,ngf sum=0.0e0_rknd do m=1,len+2 sum=sum+g0(m,ifn)*gv(m) enddo gf(jv(k)+jj-1,ifn)=sum enddo enddo jv(k)=-jv(k) enddo enddo c c update iord c itdof8=irefn+16*irefn+256*irefn+4096*irefn do it=1,ntf itdof(8,it)=itdof(8,it)+itdof8 enddo ip(25)=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dcount(ntf,nvf,nbf,ndf,irefn,itdof,itnode,ibndry, + ndnew,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(ndf) :: iv integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(10) :: it,ie integer(kind=iknd), dimension(3) :: iords cy c c determine new ndf for uniform refinement c isw=0 -- p refinement c isw=1 -- h refinement c do i=1,ndf iv(i)=0 enddo do i=1,10 it(i)=0 ie(i)=0 enddo call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) c do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,3 iv(idof(j))=1 enddo it(iord)=it(iord)+1 do j=1,3 if(itedge(j,i)/4>i) cycle ie(iords(j))=ie(iords(j))+1 enddo enddo numv=0 do i=1,ndf if(iv(i)==1) numv=numv+1 enddo nume=0 numi=0 do i=1,10 if(isw==1) then j=irefn*i else j=irefn+i endif nume=nume+(j-1)*ie(i) numi=numi+((j-1)*(j-2)/2)*it(i) enddo ndnew=numv+nume+numi return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rmknot(iedge,itri,iv,itnode,itedge,ibndry, + ibedge,itdof,vx,vy,sf,nef,ngf,maxd,gf,ibmptr,bump, 1 maxt,e,iseed,vtype,incdf,isw,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), save, dimension(10) :: corner integer(kind=iknd), dimension(*) :: iseed,vtype,ibmptr integer(kind=iknd), dimension(500) :: vlist2,tlist2,elist2, + blist2,vlist3,tlist3,elist3,blist3, 1 vlist1,tlist1,elist1,blist1, 2 vlist0,tlist0,elist0,blist0 integer(kind=iknd), dimension(3) :: iords,mords,iv integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(maxd,*) :: gf cy external sxy data corner/0,0,1,0,0,1,0,1,0,1/ data index/1,2,3,2,3,1,3,1,2/ c c eliminate vertex c i1=itnode(iedge,itri) ii2=itnode(index(2,iedge),itri) ii3=itnode(index(3,iedge),itri) i3=min(ii2,ii3) i2=max(ii2,ii3) call cirlst(i1,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist1,tlist1,elist1,blist1,len1) call cirlst(i2,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist2,tlist2,elist2,blist2,len2) call cirlst(i3,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist3,tlist3,elist3,blist3,len3) c c* call dpatch(i2,len2,vlist2,blist2, c* + i3,len3,vlist3,blist3,vtype,vx,vy) c keep=0 if(corner(vtype(i2))==1) keep=2 if(corner(vtype(i3))==1) keep=3 c ibdy=-itedge(iedge,itri) iv(1)=i3 iv(2)=0 c if(ibdy<0) then icase=4 jtri=itedge(iedge,itri)/4 jedge=itedge(iedge,itri)-4*jtri if(min(vtype(i2),vtype(i3))==1) then if(vtype(i2)>1) keep=2 if(vtype(i3)>1) keep=3 endif else if(ibndry(4,ibdy)>0) then icase=1 jtri=0 jedge=0 else if(ibndry(4,ibdy)==0) then icase=2 if(ibedge(1,ibdy)/4/=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 j2=itnode(index(2,jedge),jtri) j3=itnode(index(3,jedge),jtri) iv(2)=j2 endif iv(3)=jtri if(jtri>0) then j1=itnode(jedge,jtri) call cirlst(j1,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist0,tlist0,elist0,blist0,len0) endif c if(keep==0) then call rmgeom(i2,i3,j2,j3,icase,vtype,vx,vy, + len2,len3,vlist2,elist2,vlist3,elist3,g2,g3) if(g2<0.75e0_rknd*g3) keep=2 if(g3<0.75e0_rknd*g2) keep=3 endif c c vx,vy,iseed c itag=0 jtag=0 ii=0 if(ibdy>0) ii=ibndry(3,ibdy) if(keep==2) then vx(i3)=vx(i2) vy(i3)=vy(i2) if(ii<0) then itag=-ii if(ibndry(1,ibdy)==i2) then theta=sf(1,ibdy) else theta=sf(2,ibdy) endif endif if(icase==3) then vx(j2)=vx(j3) vy(j2)=vy(j3) jj=ibndry(3,jbdy) if(jj<0) then jtag=-jj if(ibndry(1,jbdy)==j3) then thetaj=sf(1,jbdy) else thetaj=sf(2,jbdy) endif endif endif else if(keep==3) then if(ii<0) then itag=-ii if(ibndry(1,ibdy)==i3) then theta=sf(1,ibdy) else theta=sf(2,ibdy) endif endif if(icase==3) then jj=ibndry(3,jbdy) if(jj<0) then jtag=-jj if(ibndry(1,jbdy)==j2) then thetaj=sf(1,jbdy) else thetaj=sf(2,jbdy) endif endif endif else if(keep==0) then if(ii==0) then vx(i3)=(vx(i2)+vx(i3))/2.0e0_rknd vy(i3)=(vy(i2)+vy(i3))/2.0e0_rknd if(icase==3) then vx(j2)=(vx(j3)+vx(j2))/2.0e0_rknd vy(j2)=(vy(j3)+vy(j2))/2.0e0_rknd endif else if(ii>0) then call midpt(vx(i2),vy(i2),vx(i3),vy(i3), + sf(1,ibdy),sf(2,ibdy),xx,yy) else itag=-ii theta=(sf(1,ibdy)+sf(2,ibdy))/2.0e0_rknd do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) xx=values(1) yy=values(2) endif vx(i3)=xx vy(i3)=yy if(icase==3) then jj=ibndry(3,jbdy) if(jj>0) then call midpt(vx(j2),vy(j2),vx(j2),vy(j2), + sf(1,jbdy),sf(2,jbdy),xx,yy) else jtag=-jj thetaj=(sf(1,jbdy)+sf(2,jbdy))/2.0e0_rknd do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,thetaj,jtag,values) xx=values(1) yy=values(2) endif vx(j2)=xx vy(j2)=yy endif endif endif c k=iseed(i3)/4 j=iseed(i3)-4*k if(k==itri.or.k==jtri) then ks=1 if(vtype(i3)>=7) ks=2 do i=ks,len3 if(tlist3(i)/=itri.and.tlist3(i)/=jtri) then iseed(i3)=abs(elist3(i))+4*tlist3(i) go to 10 endif enddo ks=1 if(vtype(i2)>=7) ks=2 do i=ks,len2 if(tlist2(i)/=itri.and.tlist2(i)/=jtri) then iseed(i3)=abs(elist2(i))+4*tlist2(i) go to 10 endif enddo stop 7162 endif 10 k=iseed(i1)/4 j=iseed(i1)-4*k if(k==itri) then ks=1 if(vtype(i1)>=7) ks=2 do i=ks,len1 if(tlist1(i)/=itri) then iseed(i1)=abs(elist1(i))+4*tlist1(i) go to 20 endif enddo stop 7163 endif 20 if(jtri>0) then k=iseed(j1)/4 j=iseed(j1)-4*k if(k==jtri) then ks=1 if(vtype(j1)>=7) ks=2 do i=ks,len0 if(tlist0(i)/=jtri) then iseed(j1)=abs(elist0(i))+4*tlist0(i) go to 30 endif enddo stop 7164 endif endif 30 if(icase==3) then k=iseed(j2)/4 j=iseed(j2)-4*k if(k==jtri) then do i=len3+3,elist3(len3+2) if(tlist3(i)/=jtri) then iseed(j2)=abs(elist3(i))+4*tlist3(i) go to 40 endif enddo do i=len2+3,elist2(len2+2) if(tlist2(i)/=jtri) then iseed(j2)=abs(elist2(i))+4*tlist2(i) go to 40 endif enddo stop 7165 endif endif c c itnode, ibndry c 40 ii=2 if(vtype(i2)>=7) ii=1 do i=ii,len2+1 k=blist2(i) if(k/=0) then if(ibndry(1,k)==i2) then ibndry(1,k)=i3 if(ibndry(3,k)<0) then if(ibndry(3,k)==-itag) sf(1,k)=theta endif else if(ibndry(2,k)==i2) then ibndry(2,k)=i3 if(ibndry(3,k)<0) then if(ibndry(3,k)==-itag) sf(2,k)=theta endif else stop 4417 endif endif enddo c c ii=2 if(vtype(i3)>=7) ii=1 do i=ii,len3+1 k=blist3(i) if(k/=0) then if(ibndry(1,k)==i3.and.ibndry(3,k)<0) then if(ibndry(3,k)==-itag) sf(1,k)=theta else if(ibndry(2,k)==i3.and.ibndry(3,k)<0) then if(ibndry(3,k)==-itag) sf(2,k)=theta endif endif enddo c c ii=1 if(vtype(i2)>=7) ii=2 do i=ii,len2 k=tlist2(i) if(k/=itri.and.k/=jtri) then j=abs(elist2(i)) if(itnode(j,k)/=i2) stop 4517 itnode(j,k)=i3 if(isw==1) call tqual(k,itnode,vx,vy, + ibmptr,bump,itdof,nef,e(k,1),e2) else itnode(1,k)=0 endif enddo if(ibdy>0) ibndry(1,ibdy)=0 if(ibdy>0) ibndry(3,ibdy)=0 c if(icase==3) then ll=elist2(len2+2)+1 do i=len2+2,ll k=blist2(i) if(k/=0) then if(ibndry(1,k)==j3) then ibndry(1,k)=j2 if(ibndry(3,k)<0) then if(ibndry(3,k)==-jtag) sf(1,k)=thetaj endif else if(ibndry(2,k)==j3) then ibndry(2,k)=j2 if(ibndry(3,k)<0) then if(ibndry(3,k)==-jtag) sf(2,k)=thetaj endif else stop 4427 endif endif if(i==ll) cycle if(i==len2+2) cycle k=tlist2(i) if(k/=jtri) then j=abs(elist2(i)) if(itnode(j,k)/=j3) stop 4527 itnode(j,k)=j2 if(isw==1) call tqual(k,itnode,vx,vy, + ibmptr,bump,itdof,nef,e(k,1),e2) else itnode(1,k)=0 endif enddo ibndry(1,jbdy)=0 ibndry(3,jbdy)=0 c ll=elist2(len3+2)+1 do i=len3+2,ll k=blist3(i) if(k/=0) then if(ibndry(1,k)==j2.and.ibndry(3,k)<0) then if(ibndry(3,k)==-jtag) sf(1,k)=thetaj else if(ibndry(2,k)==j2.and.ibndry(3,k)<0) then if(ibndry(3,k)==-jtag) sf(2,k)=thetaj endif endif enddo endif c c mpi interface edge c if(icase/=4) then if(ibndry(5,ibdy)/=0.and.isw/=0) then jbdy=0 if(vtype(i2)==5) then do i=1,len2+1 k=blist2(i) if((k/=0).and.(k/=ibdy)) then if(ibndry(5,k)/=0) then jbdy=k exit endif endif enddo else if(vtype(i3)/=5) stop 5099 do i=1,len3+1 k=blist3(i) if((k/=0).and.(k/=ibdy)) then if(ibndry(5,k)/=0) then jbdy=k exit endif endif enddo endif if(jbdy==0) stop 6099 im2=ibndry(6,jbdy)+1 im3=ibndry(6,ibdy)+1 imm=max(im2,im3)/2 ibndry(6,jbdy)=imm-1 endif endif c c itdof c num=2 if(jtri==0) num=1 c if(isw==0) go to 50 iitri=itri iiedge=iedge incdf=0 do nn=1,num call locord(iitri,ndof,iord,iords,itdof) k2=itdof(3+index(2,iiedge),iitri) k3=itdof(3+index(3,iiedge),iitri) m2=itedge(index(2,iiedge),iitri) m3=itedge(index(3,iiedge),iitri) if(m2<0.and.m3>0) then keep=index(2,iiedge) kill=index(3,iiedge) else if(m2>0.and.m3<0) then keep=index(3,iiedge) kill=index(2,iiedge) else if(abs(k2)0) then call locord(mtri,mdof,mord,mords,itdof) mm=iords(keep) mords(medge)=mm if(mm=7) ii=2 do i=ii,len2 k=tlist2(i) j=abs(elist2(i)) if(itdof(j,k)/=kill) stop 8723 itdof(j,k)=keep enddo if(vtype(i2)>=9) then if(i3==ii2) then keep=itdof(index(3,jedge),jtri) kill=itdof(index(2,jedge),jtri) else keep=itdof(index(2,jedge),jtri) kill=itdof(index(3,jedge),jtri) endif do i=len2+3,elist2(len2+2) k=tlist2(i) j=abs(elist2(i)) if(itdof(j,k)/=kill) stop 8724 itdof(j,k)=keep enddo endif c c itedge,ibedge c 50 iitri=itri m2=itedge(index(2,iedge),itri) m3=itedge(index(3,iedge),itri) do nn=1,num if(m2>0.and.m3>0) then mtri=m2/4 medge=m2-4*mtri itedge(medge,mtri)=m3 mtri=m3/4 medge=m3-4*mtri itedge(medge,mtri)=m2 else if(m2>0) then mtri=m2/4 medge=m2-4*mtri itedge(medge,mtri)=m3 ib=-m3 if(ibndry(4,ib)/=0) then ibedge(1,ib)=m2 else ii=1 mm=ibedge(ii,ib)/4 if(mm/=iitri) ii=2 ibedge(ii,ib)=m2 endif else if(m3>0) then mtri=m3/4 medge=m3-4*mtri itedge(medge,mtri)=m2 ib=-m2 if(ibndry(4,ib)/=0) then ibedge(1,ib)=m3 else ii=1 mm=ibedge(ii,ib)/4 if(mm/=iitri) ii=2 ibedge(ii,ib)=m3 endif else c c merge two edges c ib2=max(-m2,-m3) ib3=min(-m2,-m3) if(ibndry(4,ib2)/=0) then if(ibndry(4,ib3)/=0) stop 4547 mm=ibedge(1,ib3)/4 if(mm==iitri) ibedge(1,ib3)=ibedge(2,ib3) ibedge(2,ib3)=0 do k=3,6 ibndry(k,ib3)=ibndry(k,ib2) enddo else if(ibndry(4,ib3)/=0) then ii=1 mm=ibedge(ii,ib2)/4 if(mm==iitri) ii=2 ibedge(1,ib3)=ibedge(ii,ib2) mtri=ibedge(ii,ib2)/4 medge=ibedge(ii,ib2)-4*mtri itedge(medge,mtri)=-ib3 else ii=1 mm=ibedge(ii,ib2)/4 if(mm==iitri) ii=2 jj=1 mm=ibedge(jj,ib3)/4 if(mm/=iitri) jj=2 ibedge(jj,ib3)=ibedge(ii,ib2) mtri=ibedge(ii,ib2)/4 medge=ibedge(ii,ib2)-4*mtri itedge(medge,mtri)=-ib3 endif ibndry(1,ib2)=0 endif iitri=jtri m2=itedge(index(2,jedge),jtri) m3=itedge(index(3,jedge),jtri) enddo c vtype(i3)=max(vtype(i2),vtype(i3)) if(icase==3) vtype(j2)=max(vtype(j2),vtype(j3)) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rmtst(itri,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), save, dimension(10) :: corner integer(kind=iknd), dimension(*) :: iseed,vtype integer(kind=iknd), dimension(500) :: vlist2,tlist2,elist2, + blist2,vlist3,tlist3,elist3,blist3 integer(kind=iknd), dimension(2,*) :: ibedge real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: h cy data corner/0,0,1,0,0,1,0,1,0,1/ data index/1,2,3,2,3,1,3,1,2/ c c isw = 1 find any edge for element itri c isw =-1 test edge iedge of element itri c if(isw/=1) then thresh=0.001e0_rknd bias=0.01e0_rknd iithr=32 ibthr=17 else thresh=0.4e0_rknd bias=0.7e0_rknd iithr=8 ibthr=5 endif if(isw==-1) then ibig=iedge isml=index(2,ibig) imid=index(3,ibig) else do j=1,3 i2=itnode(index(2,j),itri) i3=itnode(index(3,j),itri) h(j)=(vx(i2)-vx(i3))**2+(vy(i2)-vy(i3))**2 enddo ibig=1 if(h(2)>h(ibig)) ibig=2 isml=3-ibig if(h(3)>h(ibig)) ibig=3 if(h(3)iithr) go to 20 if(min(vtype(i2),vtype(i3))>=3) go to 20 if(min(vtype(i2),vtype(i3))>1) then iq=0 if(itnode(4,itri)/=itnode(4,jtri)) iq=1 if(itnode(5,itri)/=itnode(5,jtri)) iq=1 if(iq==0) go to 20 endif if(min(vtype(i2),vtype(i3))==1) then if(vtype(i2)>1) keep=2 if(vtype(i3)>1) keep=3 endif else if(ibndry(4,ibdy)>0) then jtri=0 jedge=0 icase=1 if(len2+len3-3>ibthr) go to 20 else if(ibndry(4,ibdy)==0) then icase=2 if(ibedge(1,ibdy)/4/=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 if(len2+len3-4>iithr) go to 20 else icase=3 if(len2+len3-3>ibthr) go to 20 len2a=elist2(len2+2)-len2-1 len3a=elist3(len3+2)-len3-1 if(len2a+len3a-3>ibthr) go to 20 jbdy=-ibndry(4,ibdy) jtri=ibedge(1,jbdy)/4 jedge=ibedge(1,jbdy)-4*jtri j2=itnode(index(2,jedge),jtri) j3=itnode(index(3,jedge),jtri) endif c c check geometry c call rmgeom(i2,i3,j2,j3,icase,vtype,vx,vy, + len2,len3,vlist2,elist2,vlist3,elist3,g2,g3) if(keep==2) then if(g3=7) then do i=3,len2+1 if(vlist2(i-1)==i3) cycle if(vlist2(i)==i3) cycle gg=geom(i3,vlist2(i-1),vlist2(i),vx,vy) g2=amin1(gg,g2) enddo if(icase==3) then do i=len2+4,elist2(len2+2)+1 if(vlist2(i-1)==j2) cycle if(vlist2(i)==j2) cycle gg=geom(j2,vlist2(i-1),vlist2(i),vx,vy) g2=amin1(gg,g2) enddo endif else do i=2,len2+1 if(vlist2(i-1)==i3) cycle if(vlist2(i)==i3) cycle gg=geom(i3,vlist2(i-1),vlist2(i),vx,vy) g2=amin1(gg,g2) enddo endif c g3=2.0e0_rknd if(vtype(i3)>=7) then do i=3,len3+1 if(vlist3(i-1)==i2) cycle if(vlist3(i)==i2) cycle gg=geom(i2,vlist3(i-1),vlist3(i),vx,vy) g3=amin1(gg,g3) enddo if(icase==3) then do i=len3+4,elist3(len3+2)+1 if(vlist3(i-1)==j3) cycle if(vlist3(i)==j3) cycle gg=geom(j3,vlist3(i-1),vlist3(i),vx,vy) g3=amin1(gg,g3) enddo endif else do i=2,len3+1 if(vlist3(i-1)==i2) cycle if(vlist3(i)==i2) cycle gg=geom(i2,vlist3(i-1),vlist3(i),vx,vy) g3=amin1(gg,g3) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rotst1(it,itnode,itedge,ibndry,vx,vy,itest) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy cy data index/1,2,3,2,3,1,3,1,2/ c c test for roundoff problems c itest=0 do j=1,3 x2=vx(itnode(index(2,j),it)) y2=vy(itnode(index(2,j),it)) x3=vx(itnode(index(3,j),it)) y3=vy(itnode(index(3,j),it)) d=x2**2+y2**2+x3**3+y3**3 s=((x2-x3)**2+(y2-y3)**2)/d if(sqrt(s)0) cycle k=-itedge(j,it) if(ibndry(6,k)>huge(1_iknd)/2) then itest=1 c** write(6,*) 'rotst1: tree depth',it,k,ibndry(6,k) return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rotst2(iv1,ks,len,vlist,vx,vy,itest) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: vlist real(kind=rknd), dimension(*) :: vx,vy cy c c test for roundoff problems c itest=0 x2=vx(iv1) y2=vy(iv1) d2=x2**2+y2**2 do k=ks,len+1 x3=vx(vlist(k)) y3=vy(vlist(k)) d=d2+x3**3+y3**3 s=((x2-x3)**2+(y2-y3)**2)/d if(sqrt(s)6) then 5 j3=index(3,j) if(itedge(j3,k)>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)==0) then ii=1 if(ibedge(1,ib)/4==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)>0) then kk=itedge(j3,k)/4 ks=itedge(j3,k)-4*kk tlist(len-1)=kk if(itnode(5,k)==itnode(5,kk).and. + itnode(4,k)==itnode(4,kk)) then elist(len)=j else elist(len)=-j endif c blist(len)=0 else ib=-itedge(j3,k) if(ibndry(4,ib)==0) then ii=1 if(ibedge(1,ib)/4==k) ii=2 kk=ibedge(ii,ib)/4 ks=ibedge(ii,ib)-4*kk tlist(len-1)=kk 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>500) stop 1309 if(itedge(j2,k)>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)/=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)==0) then ii=1 if(ibedge(1,ib)/4==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)/=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)<9) return ib=-tlist(len+1) if(ibndry(4,ib)<0) then ib=-ibndry(4,ib) else ib=-tlist(1) ib=-ibndry(4,ib) im=ibndry(2,ib) k=iseed(im)/4 j=iseed(im)-4*k 30 j3=index(3,j) if(itedge(j3,k)>0) then kk=itedge(j3,k)/4 ks=itedge(j3,k)-4*kk k=kk j=index(3,ks) go to 30 else ib=-itedge(j3,k) if(ibndry(4,ib)==0) then ii=1 if(ibedge(1,ib)/4==k) ii=2 kk=ibedge(ii,ib)/4 ks=ibedge(ii,ib)-4*kk k=kk j=index(3,ks) go to 30 endif endif iseed(im)=j+4*k endif 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>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)>0) then kk=itedge(j3,k)/4 ks=itedge(j3,k)-4*kk tlist(ll-1)=kk if(itnode(5,k)==itnode(5,tlist(ll-1)).and. + itnode(4,k)==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)==0) then ii=1 if(ibedge(1,ib)/4==k) ii=2 kk=ibedge(ii,ib)/4 ks=ibedge(ii,ib)-4*kk tlist(ll-1)=kk 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>100) stop 1311 if(itedge(j2,k)>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)==0) then ii=1 if(ibedge(1,ib)/4==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tqual(it,itnode,vx,vy,ibmptr,bump,itdof, + nef,erh1,erl2) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(200) :: coeff real(kind=rknd), dimension(100) :: gv,gx,gy,e0,e1 common /pltmg3/c(3,746),wt(746),np2(22) cy c local error estimates in h1 and l2 norms c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) call locord(it,ndof,iord,iords,itdof) irule=2*(iord+1) c det=abs(det)/2.0e0_rknd cfmax=0.0e0 do j=1,nef e0(j)=0.0e0_rknd e1(j)=0.0e0_rknd mm=ibmptr(it)+(j-1)*(iord+2) m=1+(j-1)*(iord+2) call cfeval(tx,ty,bump(mm),coeff(m),iord) do i=m,m+iord+1 cfmax=max(cfmax,abs(coeff(i))) enddo enddo if(cfmax==0.0e0) cfmax=1.0e0_rknd do i=np2(irule),np2(irule+1)-1 call eeval(c(1,i),x,y,gv,gx,gy,iord) do k=1,nef m=(k-1)*(iord+2) sum0=0.0e0_rknd sumx=0.0e0_rknd sumy=0.0e0_rknd do j=1,iord+2 ss=coeff(m+j)/cfmax sum0=sum0+gv(j)*ss sumx=sumx+gx(j)*ss sumy=sumy+gy(j)*ss enddo e0(k)=e0(k)+sum0**2*det*wt(i) e1(k)=e1(k)+(sumx**2+sumy**2)*det*wt(i) enddo enddo erh1=0.0e0_rknd erl2=0.0e0_rknd do k=1,nef erh1=erh1+e1(k) erl2=erl2+e0(k) enddo ss=(bump(iord)*cfmax)**2 erh1=erh1*ss erl2=erl2*ss return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tqualr(it,iord,itnode,ibndry,icurv,vx,vy,sf, + u,ndl,du,itdof,itldof,bump,scale,ave,ratio,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: icurv integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(4,*) :: itldof integer(kind=iknd), dimension(100) :: idof,jdof integer(kind=iknd), dimension(3) :: kords,iords real(kind=rknd), dimension(3) :: x,y,tx,ty,cd real(kind=rknd), dimension(*) :: vx,vy,u,bump,scale real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(ndl,*) :: du real(kind=rknd), dimension(100) :: up,gv,xp,yp,d,en,ed,coeff real(kind=rknd), dimension(3,100) :: c real(kind=rknd), dimension(12,100) :: g real(kind=rknd), dimension(12,20) :: gg real(kind=rknd), dimension(100) :: ur cy external sxy 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 ratio=1.0e0_rknd itri=itldof(4,it) call l2gmpl(it,jdof,ldof,itldof) call l2gmap(itri,idof,ndof,kord,kords,itdof) do j=1,3 iords(j)=iord enddo call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) c call cfeval(tx,ty,bump,coeff,iord) cfmax=0.0e0_rknd do i=1,iord+2 cfmax=max(cfmax,abs(coeff(i))) enddo if(cfmax==0.0e0_rknd) cfmax=1.0e0_rknd call cnode2(itri,itnode,ibndry,itdof,icurv,vx,vy,sf, + xp,yp,isw,sxy) do i=1,ndof up(i)=u(idof(i)) enddo if(isw==1) then call cnode0(c,kord,kords) do i=1,ndof call barinl(c(1,i),xp,yp,gv,kord,kords) up(i)=0.0e0_rknd do j=1,ndof up(i)=up(i)+u(idof(j))*gv(j) enddo enddo endif call p2q2d(up,ur,kord,iord,kords,iords) c ndof=((iord+1)*(iord+2))/2 call deval(itri,itnode,vx,vy,g,scale1,iord) scale1=scale1/scale(iord) ddmax=0.0e0_rknd do i=1,iord+1 d(i)=0.0e0_rknd do j=1,ndof d(i)=d(i)+ur(j)*g(i,j) enddo d(i)=d(i)*scale1 ddmax=max(ddmax,abs(d(i))) enddo if(ddmax==0.0e0_rknd) ddmax=1.0e0_rknd c do k=1,iord+1 ed(k)=0.0e0_rknd en(k)=0.0e0_rknd enddo do j=1,3 j2=jdof(index(2,j)) j3=jdof(index(3,j)) c cd(index(2,j))=0.5e0_rknd cd(index(3,j))=0.5e0_rknd cd(j)=0.0e0_rknd call eeval1(cd,x,y,gg,iord) c do k=1,iord+1 dd=0.0e0_rknd do i=1,iord+2 dd=dd+(coeff(i)/cfmax)*gg(k,i) enddo ed(k)=ed(k)+dd**2 qq=((du(j2,k)+du(j3,k))/2.0e0_rknd-d(k))/ddmax en(k)=en(k)+qq**2 enddo enddo c sd=0.0e0_rknd sn=0.0e0_rknd do k=1,iord+1 sd=sd+ed(k)*real(ibic(iord,k-1),rknd) sn=sn+en(k)*real(ibic(iord,k-1),rknd) enddo sd=sqrt(sd)*cfmax sn=sqrt(sn)*ddmax qq=max(sd,sn,ave) if(qq>0.0e0_rknd) then ss=ave/qq sd=sd/qq sn=sn/qq ratio=sqrt((sn**2+ss*2)/(sd**2+ss**2)) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tquali(it,itnode,vx,vy,nef,maxd,u, + itdof,eh1nrm,el2nrm) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords,jords real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(maxd,*) :: u real(kind=rknd), dimension(100) :: gx,gy,gv,sx,sy,sv real(kind=rknd), dimension(100,nef) :: up,zp real(kind=rknd), dimension(20) :: e1,e0 common /pltmg3/c(3,746),wt(746),np2(22) cy eh1nrm=0.0e0_rknd el2nrm=0.0e0_rknd call l2gmap(it,idof,ndof,iord,iords,itdof) if(iord<2) return jord=iord-1 do j=1,3 jords(j)=iords(j)-1 enddo mdof=ndof-(iord+1) c do ifn=1,nef e0(ifn)=0.0e0_rknd e1(ifn)=0.0e0_rknd do j=1,ndof up(j,ifn)=u(idof(j),ifn) enddo call p2q2d(up(1,ifn),zp(1,ifn),iord,jord,iords,jords) enddo c c compute tangent and normal vectors c call afmap(it,itnode,vx,vy,tx,ty,x,y,det) det=abs(det)/2.0e0_rknd c irule=2*(iord+1) do i=np2(irule),np2(irule+1)-1 c c evaluate basis functions (isoparametric possibility ignored) c call beval(c(1,i),x,y,gv,gx,gy,iord,iords) call beval(c(1,i),x,y,sv,sx,sy,jord,jords) do ifn=1,nef uu=0.0e0_rknd ux=0.0e0_rknd uy=0.0e0_rknd do j=1,ndof uu=uu+up(j,ifn)*gv(j) ux=ux+up(j,ifn)*gx(j) uy=uy+up(j,ifn)*gy(j) enddo zz=0.0e0_rknd zx=0.0e0_rknd zy=0.0e0_rknd do j=1,mdof zz=zz+zp(j,ifn)*sv(j) zx=zx+zp(j,ifn)*sx(j) zy=zy+zp(j,ifn)*sy(j) enddo e0(ifn)=e0(ifn)+wt(i)*(uu-zz)**2*det e1(ifn)=e1(ifn)+wt(i)*((ux-zx)**2+(uy-zy)**2)*det enddo enddo do ifn=1,nef eh1nrm=eh1nrm+e1(ifn) el2nrm=el2nrm+e0(ifn) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cfeval(tx,ty,bump,coeff,iord) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(3) :: tx,ty real(kind=rknd), dimension(*) :: bump,coeff cy do j=0,iord+1 temp=0.0e0_rknd do k1=0,iord+1-j k2=iord+1-j-k1 do k3=0,j k4=j-k3 temp=temp+real(ibic(iord+1-j,k1)*ibic(j,k3),rknd)* + (tx(2)**k1)*(ty(2)**k2)* 1 (tx(3)**k3)*(ty(3)**k4)*bump(k2+k4+1) enddo enddo qq=real(ibic(iord+1,j),rknd)/real(ifac(iord+1),rknd) temp=temp*(-1.0e0_rknd)**(iord+1-j)*qq if (j==0) then coeff(2)=temp else if (j==iord+1) then coeff(1)=temp else coeff(iord+3-j)=temp endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dorder(ip,p,q,itdof,maxd,gf) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(100) :: ip,idof real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(100) :: gg cy c reorder gridfunction arrays with respect to permutation p c ntf=ip(1) ndf=ip(4) ngf=ip(77) c do i=1,ndf q(p(i))=i enddo c c move real arrays c do i=1,ndf if(p(i)==i) cycle if(p(i)<0) cycle do m=1,ngf gg(m)=gf(i,m) enddo j=i 10 k=p(j) p(j)=-k if(k/=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 enddo 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 call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof idof(j)=q(idof(j)) enddo call g2lmap(i,idof,itdof) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine vorder(ip,p,q,itnode,ibndry,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(*) :: vx,vy cy c physically reorder the vertex arrays with respect to c permutation p c ntf=ip(1) nvf=ip(2) nbf=ip(3) c do i=1,nvf q(p(i))=i enddo c c move real arrays c do i=1,nvf if(p(i)==i) cycle if(p(i)<0) cycle r1=vx(i) r2=vy(i) j=i 10 k=p(j) p(j)=-k if(k/=i) then vx(j)=vx(k) vy(j)=vy(k) j=k go to 10 endif vx(j)=r1 vy(j)=r2 enddo 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine border(ip,p,q,ibndry,sf) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(7) :: ib real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(2) :: sb cy c physically reorder the vertex arrays with respect to c permutation p c nbf=ip(3) c do i=1,nbf q(p(i))=i enddo c c do i=1,nbf if(p(i)==i) cycle if(p(i)<0) cycle do m=1,7 ib(m)=ibndry(m,i) enddo do m=1,2 sb(m)=sf(m,i) enddo j=i 10 k=p(j) p(j)=-k if(k/=i) then do m=1,6 ibndry(m,j)=ibndry(m,k) enddo do m=1,2 sf(m,j)=sf(m,k) enddo j=k go to 10 endif do m=1,7 ibndry(m,j)=ib(m) enddo do m=1,2 sf(m,j)=sb(m) enddo enddo c do i=1,nbf p(q(i))=i enddo c do i=1,nbf if(ibndry(4,i)>=0) cycle k=-ibndry(4,i) ibndry(4,i)=-q(k) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clnup(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,sf,ibmptr,bump,mark,gf,maxd,ngf,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: mark,ibmptr integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(100) :: idof real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(2,*) :: sf cy 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)/=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 ibmptr(ntnew+1)=ibmptr(ntnew)+ibmptr(i+1)-ibmptr(i) ii=ibmptr(i)-ibmptr(ntnew) do j=ibmptr(ntnew),ibmptr(ntnew+1)-1 bump(j)=bump(ii+j) enddo do j=1,8 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)>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)>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)/=0) then nbnew=nbnew+1 mark(i)=nbnew do j=1,7 ibndry(j,nbnew)=ibndry(j,i) enddo do j=1,2 ibedge(j,nbnew)=ibedge(j,i) sf(j,nbnew)=sf(j,i) enddo k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew)>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)>=0) cycle k=-ibndry(4,i) ibndry(4,i)=-mark(k) 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)/=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 call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof mark(idof(j))=1 enddo enddo ndnew=0 do i=1,ndf if(mark(i)==0) cycle ndnew=ndnew+1 mark(i)=ndnew do k=1,ngf gf(ndnew,k)=gf(i,k) enddo enddo ndf=ndnew do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof idof(j)=mark(idof(j)) enddo call g2lmap(i,idof,itdof) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clnup2(nvf,ntf,nbf,ndf,newnvf,newntf,newnbf,newndf, + nvi,nbi,ndi,irgn,itnode,itedge,ibndry,ibedge,vx,vy,sf, 1 mark,gf,maxd,ngf,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: mark integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(100) :: idof real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(2,*) :: sf cy 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)/=0) then ntnew=ntnew+1 mark(i)=ntnew do j=1,5 itnode(j,ntnew)=itnode(j,i) enddo do j=1,8 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)>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)>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)/=0) then nbnew=nbnew+1 if(i<=nbi) nbinew=nbinew+1 mark(i)=nbnew do j=1,7 ibndry(j,nbnew)=ibndry(j,i) enddo do j=1,2 ibedge(j,nbnew)=ibedge(j,i) sf(j,nbnew)=sf(j,i) enddo k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew)>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)>=0) cycle k=-ibndry(4,i) ibndry(4,i)=-mark(k) enddo c c orient boundary edges c do i=newntf+1,ntf do j=1,3 if(itedge(j,i)>=0) cycle k=-itedge(j,i) ibsv=ibndry(1,k) ibndry(1,k)=itnode(index(2,j),i) ibndry(2,k)=itnode(index(3,j),i) if(ibndry(4,k)==0.and.itnode(4,i)/=irgn) then if(ibedge(1,k)/4/=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)==irgn) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) else if(itnode(4,ii)=7) then ks=2 ie1=-tlist(1) ie2=-tlist(len+1) if(ibndry(3,ie2)<0) cycle vf(1)=vlist(2) vf(2)=vlist(len+1) if(ibndry(3,ie2)>0) then icen=ie2 rr=(sf(1,icen)-vx(i))**2+(sf(2,icen)-vy(i))**2 endif if(vtype(i)==9) 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)>0) then icen1=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)/=1) then ic=0 do k=ks,len if(elist(k)>=0) cycle ic=ic+1 vf(ic)=vlist(k) ie1=blist(k) enddo if(vtype(i)==4) then if(ibndry(3,ie1)>0) then icen=ie1 rr=(sf(1,icen)-vx(i))**2 + +(sf(2,icen)-vy(i))**2 endif endif endif endif c c initial function evaluation c call rotst2(i,ks,len,vlist,vx,vy,itest) if(itest==1) cycle call geval(i,vx,vy,vlist,tlist,ks,len, + nef,ibmptr,bump,g,itdof) if(vtype(i)==9) then call rotst2(ii,ks1,len1,vlist,vx,vy,itest) if(itest==1) cycle call geval(ii,vx,vy,vlist,tlist,ks1,len1, + nef,ibmptr,bump,g1,itdof) 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_rknd*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_rknd*cs2*g1(5)+cc2*g1(6) endif gs=max(abs(g(4)),abs(g(5)),abs(g(6))) if(gs==0.0e0_rknd) cycle 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==0.0e0_rknd) cycle px=-(g(2)*g(6)-g(3)*g(5))/det py=-(g(4)*g(3)-g(5)*g(2))/det if(vtype(i)/=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==0.0e0_rknd) cycle d0=(px*g(2)+py*g(3))/(g0*pp) if(d0+tol>=0.0e0_rknd) cycle smin=0.0e0_rknd smax=stpmx(i,vx,vy,vlist,ks,len,px,py) if(vtype(i)==9) then px1=dx1*dd py1=dy1*dd smax1=stpmx(ii,vx,vy,vlist,ks1,len1,px1,py1) smax=min(smax,smax1) endif if(smax<=tol) cycle 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)==9) then vx(ii)=xx1+step*px1 vy(ii)=yy1+step*py1 endif if(icen>0) then rn=(sf(1,icen)-vx(i))**2+(sf(2,icen)-vy(i))**2 rn=sqrt(rr/rn) vx(i)=sf(1,icen)+rn*(vx(i)-sf(1,icen)) vy(i)=sf(2,icen)+rn*(vy(i)-sf(2,icen)) if(vtype(i)==9) then vx(ii)=sf(1,icen1)+rn*(vx(ii)-sf(1,icen1)) vy(ii)=sf(2,icen1)+rn*(vy(ii)-sf(2,icen1)) endif endif ic=ic+1 call geval(i,vx,vy,vlist,tlist,ks,len, + nef,ibmptr,bump,g,itdof) if(vtype(i)==9) then call geval(ii,vx,vy,vlist,tlist,ks1,len1, + nef,ibmptr,bump,g1,itdof) 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_rknd*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_rknd*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(fksmin.and.ss=g0) then vx(i)=xx vy(i)=yy if(vtype(i)==9) then vx(ii)=xx1 vy(ii)=yy1 endif ichng=ichng-1 endif ifail=ifail+1 enddo enddo call cedge5(nbf,itedge,ibedge,0_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine geval(iv1,vx,vy,vlist,tlist,ks,len, + nef,ibmptr,bump,g,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: tlist,vlist,ibmptr integer(kind=iknd), dimension(3) :: iv,iords integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(3) :: tx,ty,x,y real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(6) :: g,g1,s,v cy c compute direction vector using newton direction c do j=1,6 g(j)=0.0e0_rknd enddo do k=ks,len iv(1)=iv1 iv(2)=vlist(k) iv(3)=vlist(k+1) it=tlist(k) call locord(it,ndof,iord,iords,itdof) c c compute tangent and normal vectors c call afmap(1_iknd,iv,vx,vy,tx,ty,x,y,det) c c this takes into account det c det=tx(2)*ty(3)-tx(3)*ty(2) detx=ty(3)+ty(2) dety=-tx(2)-tx(3) s(1)=1.0e0_rknd/det s(2)=-detx/det**2 s(3)=-dety/det**2 s(4)=2.0e0_rknd*detx**2/det**3 s(5)=2.0e0_rknd*detx*dety/det**3 s(6)=2.0e0_rknd*dety**2/det**3 if(det<0.0e0_rknd) then do j=1,6 s(j)=-s(j) enddo endif c c edge length terms c xx=tx(1)**2+tx(2)**2+tx(3)**2 dxx=2.0e0_rknd*(tx(2)-tx(3)) ddxx=4.0e0_rknd yy=ty(1)**2+ty(2)**2+ty(3)**2 dyy=2.0e0_rknd*(ty(2)-ty(3)) ddyy=4.0e0_rknd c v(1)=(xx+yy)**(iord+2) z1=real(iord+2,rknd)*(xx+yy)**(iord+1) v(2)=z1*dxx v(3)=z1*dyy z2=real((iord+2)*(iord+1),rknd)*(xx+yy)**iord v(4)=z2*dxx*dxx+z1*ddxx v(5)=z2*dxx*dyy v(6)=z2*dyy*dyy+z1*ddyy c c derivative terms c cf=0.0e0_rknd do mm=1,nef m=ibmptr(it)+(mm-1)*(iord+2) do j=0,iord+1 cccc qq=real(ibic(iord+1,j),rknd)/real(ifac(iord+1),rknd) qq=real(ibic(iord+1,j),rknd) do k1=0,iord+1-j k2=iord+1-j-k1 do k3=0,j k4=j-k3 tt=real(ibic(iord+1-j,k1)*ibic(j,k3),rknd) cf=cf+(bump(k2+k4+m)*qq*tt)**2 enddo enddo enddo enddo c c cf=0.0e0_rknd c qq=1.0e0_rknd/real(ifac(iord+1),rknd) c do j=ibmptr(it),ibmptr(it+1)-1 c cf=cf+(bump(j)*qq)**2 c enddo c call cdp(s,v,g1) do j=1,6 g(j)=g(j)+g1(j)*cf enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdp(v1,v2,g) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(6) :: v1,v2,g cy 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_rknd*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_rknd*v1(3)*v2(3)+v1(1)*v2(6) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,itnode, + itedge,ibndry,ibedge,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(*) :: iseed,vtype integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2) :: vf,vf1 integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(10) :: corner integer(kind=iknd), dimension(500) :: blist,vlist,elist integer(kind=iknd), dimension(500) :: tlist real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy external sxy data corner/0,0,1,0,1,1,0,1,0,1/ c c this routine tries to optimize knot placement c tol=1.0e-3_rknd s3=sqrt(3.0e0_rknd)/2.0e0_rknd c c thr main loop in which the knots positions are c optimized c call cedge5(nbf,itedge,ibedge,1_iknd) do itnum=1,itmax do i=1,nvf if(corner(vtype(i))==1) cycle 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)>=7) then ks=2 ie1=-tlist(1) ie2=-tlist(len+1) if(ibndry(3,ie2)<0) cycle vf(1)=vlist(2) vf(2)=vlist(len+1) if(ibndry(3,ie2)>0) then icen=ie2 rr=(sf(1,icen)-vx(i))**2 + +(sf(2,icen)-vy(i))**2 endif if(vtype(i)==9) 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)>0) then icen1=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)/=1) then ic=0 do k=ks,len if(elist(k)>=0) cycle ic=ic+1 vf(ic)=vlist(k) ie1=blist(k) enddo if(vtype(i)==4) then if(ibndry(3,ie1)>0) then icen=ie1 rr=(sf(1,icen)-vx(i))**2 + +(sf(2,icen)-vy(i))**2 endif endif endif endif qmin=1.0e0_rknd qmin2=1.0e0_rknd 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(q0.0e0_rknd) then r1=-cc/(bb+disc) r2=-(bb+disc) else r1=disc-bb r2=-cc/(bb-disc) endif if(bn>0.0e0_rknd) then beta=max(r1,r2) else beta=min(r1,r2) endif else beta=-(bd*det-bn*cd)/(2.0e0_rknd*ad*det) endif xmax=vx(i)+px*beta ymax=vy(i)+py*beta if(vtype(i)==9) 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_rknd ymk=(vy(kb)+vy(ka))/2.0e0_rknd 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_rknd yml=(vy(lb)+vy(la))/2.0e0_rknd 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_rknd if(a>0.0e0_rknd) 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*max(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(max(zx,zy)0.0e0_rknd) 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<0.0e0_rknd) then r1=(-b+discr)/a r2=c/(-b+discr) else r1=-(b+discr)/a r2=-c/(b+discr) endif ss=max(r1,r2) endif if(ss>0.0e0_rknd) stpmx=min(stpmx,ss) enddo c c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ldbal(ntf,nbf,nproc,ip,itnode,ibndry,sf,e) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd) :: newtag,oldtag integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(ntf) :: q,p,kequv,kequvc,map integer(kind=iknd), dimension(nproc+1) :: jl integer(kind=iknd), dimension(1000) :: list integer(kind=iknd), save :: mxlst=1000 real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(*) :: e real(kind=rknd), dimension(ntf) :: z,ev cy c load balancing c nvf=ip(2) ip(25)=0 call ldinit(ip,itnode,ibndry,sf,p,q) c c boundary cases c ifact=10 ibias=10 if(ifact*nproc>ntf) then ip(25)=49 return endif log2p=int(log(real(nproc,rknd)+0.1e0_rknd)/log(2.0e0_rknd))+1 if(nproc>=ntf) then do i=1,ntf itnode(4,i)=i enddo if(nproc/=ntf) ip(25)=49 go to 50 else if(nproc<=1) then do i=1,ntf itnode(4,i)=1 enddo go to 50 endif call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag) if(jflag/=0) then ip(25)=jflag return endif msize=max(ntf/(nproc*ibias),ifact) c call cequvt(ntf,nproc,itnode,itedge,e,p,q,kequvc,kequv) 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=min(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>1) then call timer(13_iknd) call lbev(ntf,jbeg,jend,p,q,itedge,ev, + kequv,kequvc,map,iflag) call timer(14_iknd) endif do j=jbeg,jend z(j)=ev(map(p(j)))+2.0e0_rknd*real(i-1,rknd) enddo enddo c c split, do crude collapse of tiny regions c call spord(ibeg,iend,z,p,q,itnode,e,nproc,msize, + newtag,oldtag,kequv,kequvc) call rtst(p,q,itnode,itedge,nr,list,e,nproc,msize) enddo enddo c c smoothing c call smth0(ntf,itedge,e,nproc,msize,itnode) 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,sf) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lbev(ntf,ibeg,iend,p,q,itedge,ev,kequv,kequvc, + map,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q,kequv,kequvc,map integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), save :: ihist=27 integer(kind=iknd), dimension(3*ntf) :: ja real(kind=rknd), dimension(*) :: ev real(kind=rknd), dimension(3*ntf) :: a real(kind=rknd), dimension(ntf) :: ev0,dev,r cy c split region into two approximately equal pieces c c pointers (lenz > 7 n) c c parameters c iflag=0 itmax=200 tol=1.0e-2_rknd ispd=1 c c make ja, a c call mtxasm(ibeg,iend,itedge,ja,a,p,q,kequv,kequvc,n,map) if(n==1) then ev(1)=1.0e0_rknd return else if(n==2) then ev(1)=1.0e0_rknd/sqrt(2.0e0_rknd) ev(2)=-ev(1) return endif c c initialize c nn=(n/2)*2 ss=1.0e0_rknd/sqrt(real(nn,rknd)) ev(n)=0.0e0_rknd do i=1,nn,2 ev(i)=ss ev(i+1)=-ss enddo do i=1,n ev0(i)=0.0e0_rknd enddo c c main iteration loop c ihist=ihist+1 if(ihist>30) ihist=27 call hist1(ihist,0_iknd,1.0e0_rknd) do itnum=1,itmax call tresid(n,ja,a,ev,r,dev,evalue,bnorm) call hist1(ihist,itnum,bnorm) if(bnorm<=tol) return call sgs(n,ja,a,dev,r,ispd) call tev(n,ja,a,ev,dev,ev0) enddo iflag=1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ldinit(ip,itnode,ibndry,sf,p,q) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: p,q integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(2,*) :: sf cy c initialize for load balance c ntf=ip(1) nbf=ip(3) c c delete interface edges as necessary c do i=1,nbf if(ibndry(4,i)/=0) then q(i)=1 else if(ibndry(5,i)>0) then q(i)=0 else q(i)=1 endif enddo newnbf=0 nn=nbf+1 do i=1,nbf if(q(i)==1) then newnbf=newnbf+1 p(newnbf)=i else nn=nn-1 p(nn)=i endif enddo if(nn/=newnbf+1) stop 2789 c call border(ip,p,q,ibndry,sf) ip(3)=newnbf c c initialize label fields c do i=1,newnbf ibndry(5,i)=0 ibndry(6,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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ldbdy(ip,itnode,ibndry,itedge,ibedge,sf) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge real(kind=rknd), dimension(2,*) :: sf integer(kind=iknd), save, dimension(3,3) :: index cy data index/1,2,3,2,3,1,3,1,2/ c c ntf=ip(1) nvf=ip(2) nbf=ip(3) maxb=ip(86) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) call cedge5(nbf,itedge,ibedge,1_iknd) c c add internal boundary edges c do i=1,nbf ibndry(5,i)=0 ibndry(6,i)=0 enddo newbdy=0 do i=1,ntf irgn=itnode(4,i) do j=1,3 if(itedge(j,i)>0) then k=itedge(j,i)/4 if(itnode(4,k)/=irgn.and.imaxb) then ip(25)=86 return endif do i=1,ntf irgn=itnode(4,i) do j=1,3 if(itedge(j,i)<0) then k=-itedge(j,i) if(ibndry(4,k)==0) then m=ibedge(1,k)/4 if(m==i) m=ibedge(2,k)/4 krgn=itnode(4,m) if(krgn/=irgn) ibndry(5,k)=-k else if(ibndry(4,k)<0) then km=-ibndry(4,k) m=ibedge(1,km)/4 krgn=itnode(4,m) if(krgn/=irgn) ibndry(5,k)=-min(km,k) endif c else k=itedge(j,i)/4 if(itnode(4,k)/=irgn.and.i=next) exit i=order(ii) do j=1,3 if(itedge(j,i)>0) then k=itedge(j,i)/4 ir=itnode(4,i) kr=itnode(4,k) if(ir/=kr) idist(kr)=min(idist(kr),idist(ir)+1) if(mark(k)==0) then mark(k)=1 order(next)=k next=next+1 endif else k=0 iedge=-itedge(j,i) if(ibndry(4,iedge)==0) then k=ibedge(1,iedge)/4 if(k==i) k=ibedge(2,iedge)/4 else if(ibndry(4,iedge)<0) then kedge=-ibndry(4,iedge) k=ibedge(1,kedge)/4 endif if(k>0) then ir=itnode(4,i) kr=itnode(4,k) if(ir/=kr) + idist(kr)=min(idist(kr),idist(ir)+1) if(mark(k)==0) then mark(k)=1 order(next)=k next=next+1 endif endif endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pdepth(nproc,ipath,idepth) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(*) :: idepth cy 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<=0) then idepth(iseg)=0 else idepth(iseg)=max(idepth(ison),idepth(ison+1))+1 endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mklst(ibeg,iend,itedge,itnode,p,q,nr,mxlst,list) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: p,q,list cy 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)<0) then nr=nr+1 if(nr+1>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<=0) cycle if(itnode(4,m)>0) cycle 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 enddo if(next<=iend) go to 10 list(nr+1)=iend+1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkjl(ntf,mnrgn,mxrgn,jl,itnode,p,q) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: jl,p,q integer(kind=iknd), dimension(5,*) :: itnode cy 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 if(jl(mxrgn-mnrgn+2)/=ntf+1) stop 5463 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mtxasm(ibeg,iend,itedge,ja,a,p,q,kequv,kequvc,n,map) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(*) :: p,q,ja,kequv,map,kequvc real(kind=rknd), dimension(*) :: a cy c determine n c call blkord(ibeg,iend,p,q,kequv,kequvc) n=0 do i=ibeg,iend if(kequv(p(i))==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>0) then j=q(jt) if(j>=i.and.j<=iend) then kmin=min(map(it),map(jt)) kmax=max(map(it),map(jt)) if(kmax>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<=0) cycle j=q(jt) if(jiend) cycle kmin=min(map(it),map(jt)) kmax=max(map(it),map(jt)) if(kmax<=kmin) cycle do kk=ja(kmin),ja(kmin+1)-1 if(ja(kk)==0) then ja(kk)=kmax exit else if(ja(kk)==kmax) then exit endif enddo 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)/=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)0) then j=q(jt) if(j>=i.and.j<=iend) then kmin=min(map(it),map(jt)) kmax=max(map(it),map(jt)) if(kmax>kmin) then a(kmin)=a(kmin)+1.0e0_rknd a(kmax)=a(kmax)+1.0e0_rknd call jamap0(kmin,kmax,ij,ji,ja,0_iknd) a(ij)=a(ij)-1.0e0_rknd endif endif endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cequvt(ntf,nproc,itnode,itedge,e,p,q,mark,kequv) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(*) :: p,q,mark,kequv integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(*) :: e cy ef=1.0e-2_rknd tf=1.0e-2_rknd imx=100 c ee=0.0e0_rknd do i=1,ntf p(i)=i q(i)=i mark(i)=0 kequv(i)=i ee=ee+e(i) enddo ee=ef*ee/real(nproc,rknd) tt=tf*real(ntf,rknd)/real(nproc,rknd) ii=min(int(tt+0.5e0_rknd),imx) c if(ii<=1.or.ee<=0.0e0_rknd) 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_iknd) 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_iknd,len,p,q,e,0_iknd) imark=it mark(it)=imark et=e(it) nt=1 20 if(et>=ee) go to 40 if(nt>=ii) go to 40 if(klen<=len) go to 40 kt=p(klen) do j=1,3 jt=itedge(j,kt)/4 if(jt<=0) cycle if(mark(jt)/=0) cycle if(et+e(jt)>ee) cycle if(nt+1>ii) cycle 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_iknd) enddo klen=klen-1 go to 20 40 if(len>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)<=0) cycle num=1 imin=i next=i 70 next=kequv(next) if(next/=i) then imin=min(imin,next) num=num+1 go to 70 endif last=imin do k=1,num next=kequv(last) kequv(last)=-imin last=next enddo 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_iknd,ntf,p,q,kequv,mark) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine blkord(ibeg,iend,p,q,kequv,kequvc) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q,kequv,kequvc cy c order blocks c i=ibeg 10 ii=p(i) if(kequv(ii)/=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/=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(iecur1) then if(nr0<=1) cycle n0=list0(k0+1)-list0(k0) if(ncur0-n0ecur0-ecur1) cycle jj=list0(k0) mm=imid do k=1,n0 if(mm>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<=1) cycle n1=list1(k1+1)-list1(k1) if(ncur1-n1ecur1-ecur0) cycle jj=list1(k1+1)-1 mm=imid+1 do k=1,n1 if(mm=nbeg.and.kend>nend) then do i=kbeg,iptr itnode(4,p(i))=oldtag enddo c c a split is forced c else if(kbegnend) then mm=p(iptr) 40 m1=mm mm=kequvc(m1) kequvc(m1)=m1 kequv(m1)=m1 if(mm/=p(iptr)) go to 40 else c c shift the samllest number of elements c if(iptr-kbeg=2*n) then nchild=0 return else if(k>=n) then nchild=msize return endif a=log(2.0e0_rknd) q=log(real(n,rknd)+0.1e0_rknd)/a nl=int(q) q=log(real(k,rknd)+0.1e0_rknd)/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>=n1) then if (k1>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<=n2) then if(k2=3) cycle if(inum>=2) go to 20 if(inum==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)==3) go to 10 if(tag(k2)==tag(k2)) go to 10 n2=0 n3=0 do j=1,3 if(ntag(j,ii)==tag(k2)) n2=n2+1 if(ntag(j,ii)==tag(k3)) n3=n3+1 enddo if(n2==1.and.n3==1) then if(tag(k2)==0) then ktag=tag(k3) else if(tag(k3)==0) then ktag=tag(k2) else if(wt(tag(k2))0) go to 40 endif 10 jtag=0 do j=1,3 if(tag(j)/=itag.and.tag(j)/=0) then c c see if relative load balance is improved c gold=max(abs(wt(itag)-wtrgt(itag)), + abs(wt(tag(j))-wtrgt(tag(j)))) gnew=max(abs(wt(itag)-e(i)-wtrgt(itag)), + abs(wt(tag(j))+e(i)-wtrgt(tag(j)))) if(jtag==0) then gg=gold-gnew jtag=tag(j) else if(gold-gnew>gg) then gg=gold-gnew jtag=tag(j) endif endif enddo if(jtag==0) cycle c c accept all cases that reduce interface verts c accept other cases that improve load balance c if(inum==1) then if(tag(k2)/=tag(k3)) then if(gg<=0.0e0_rknd) cycle 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 cycle 20 if(ibdy>0) cycle 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)==ktag) jnum(k2)=jnum(k2)+1 if(ntag(j,k3)==ktag) jnum(k3)=jnum(k3)+1 enddo c c test for three element cap or two element quad c isw=0 if(jnum(k2)==1.and.nnum(k2)==2) isw=isw+1 if(jnum(k3)==1.and.nnum(k3)==2) isw=isw+1 if(isw==2) then go to 30 else if(nnum(k2)==3) then mm=i3 if(isw==1) go to 40 else if(nnum(k3)==3) then mm=i2 if(isw==1) go to 40 else if(nnum(k2)==1) then mm=i2 if(nnum(k3)==1) cycle if(jnum(k2)==2) then if(isw==1) go to 30 go to 40 endif else if(nnum(k3)==1) then mm=i3 if(jnum(k3)==2) then if(isw==1) go to 30 go to 40 endif else if(isw==1) then mm=i2 if(jnum(k2)==1) go to 40 mm=i3 if(jnum(k3)==1) go to 40 endif cycle 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 cycle c c switch quads that improve load balance c 40 ee=e(i)+e(mm) gold=max(abs(wt(itag)-wtrgt(itag)), + abs(wt(ktag)-wtrgt(ktag))) gnew=max(abs(wt(itag)-ee-wtrgt(itag)), + abs(wt(ktag)+ee-wtrgt(ktag))) if(gnew>=gold) cycle 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 enddo c* write(6,*) 'iter:',itnum,ichng,kchng,jchng if(ichng+kchng+jchng==0) return enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cutr(ntf,nbf,lpq,ip,itnode,ibndry,vx,vy,sf,maxt,e, + maxd,gf,icutsw,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(lpq) :: p,q,befor,after integer(kind=iknd), dimension(3,ntf) :: itedge integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(maxd,*) :: gf cy data index/1,2,3,2,3,1,3,1,2/ c nvf=ip(2) ndf=ip(4) irgn=ip(50) if (icutsw==2) go to 10 c c order triangles in region irgn first c newntf=0 do i=1,ntf if(itnode(4,i)==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,8 ii=itdof(j,newntf) itdof(j,newntf)=itdof(j,i) itdof(j,i)=ii enddo do j=1,2 ee=e(newntf,j) e(newntf,j)=e(i,j) e(i,j)=ee enddo endif enddo c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) c c insure proper orientation of edges c call cedge5(nbf,itedge,ibedge,1_iknd) do i=1,ntf do j=1,3 if(itedge(j,i)>=0) cycle k=-itedge(j,i) ibsv=ibndry(1,k) ibndry(1,k)=itnode(index(2,j),i) ibndry(2,k)=itnode(index(3,j),i) if(ibndry(4,k)==0.and.itnode(4,i)/=irgn) then if(ibedge(1,k)/4/=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)==irgn) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) else if(itnode(4,ii)0) then k1=ibedge(1,i)/4 krgn=itnode(4,k1) if(krgn==irgn) then q(i)=1 else q(i)=0 endif else if(ibndry(4,i)==0) then k1=ibedge(1,i)/4 k2=ibedge(2,i)/4 k1rgn=itnode(4,k1) k2rgn=itnode(4,k2) if(k1rgn/=k2rgn) then if(k1rgn==irgn.or.k2rgn==irgn) then q(i)=2 else q(i)=3 endif else if(k1rgn==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/=k2rgn) then if(k1rgn==irgn) then q(i)=2 else if(k2rgn==irgn) then q(i)=0 else if(k1rgn0) then q(1)=1 nedge=1 do i=2,nbb ii=abs(ibndry(5,i)) im=abs(ibndry(5,i-1)) if(ii/=im) then nedge=nedge+1 q(nedge)=i endif enddo else nedge=0 endif q(nedge+1)=nbb+1 if(nbi>newnbf) then q(nedge+2)=newnbf+1 medge=nedge+2 do i=newnbf+2,nbi ii=abs(ibndry(5,i)) im=abs(ibndry(5,i-1)) if(ii/=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==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))==0) ii=i enddo if(ii==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,sf) 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))==0) q(ibndry(1,i))=1 if(q(ibndry(2,i))==0) q(ibndry(2,i))=1 enddo nvi=0 do k=3,1,-1 do ii=1,nvf i=p(ii) if(q(i)/=k) cycle nvi=nvi+1 p(ii)=p(nvi) p(nvi)=i enddo if(k==3) nvv=nvi if(k==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<=nn) cycle nn=nn+1 p(ii)=p(nn) p(nn)=ibndry(j,i) q(p(nn))=nn q(p(ii))=ii enddo enddo nn=newnvf do i=newnbf+1,nbi do j=1,2 ii=q(ibndry(j,i)) if(ii<=nn) cycle nn=nn+1 p(ii)=p(nn) p(nn)=ibndry(j,i) q(p(nn))=nn q(p(ii))=ii enddo enddo c call vorder(ip,p,q,itnode,ibndry,vx,vy) c c mark degress of freedom c 10 if (icutsw==2) then nbb=ip(32) newntf=ip(27) newnbf=ip(29) nbi=ip(35) endif call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,iflag) do i=1,ndf p(i)=0 q(i)=0 enddo mm=0 do i=1,nbb call l2gmpe(i,ibedge,iord,idof,itdof) do j=1,iord+1 if(q(idof(j))/=0) cycle mm=mm+1 p(mm)=idof(j) q(idof(j))=1 enddo enddo ndd=mm do i=1,newntf call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof if(q(idof(j))/=0) cycle mm=mm+1 p(mm)=idof(j) q(idof(j))=1 enddo enddo newndf=mm do i=newnbf+1,nbi call l2gmpe(i,ibedge,iord,idof,itdof) do j=1,iord+1 if(q(idof(j))==0) then mm=mm+1 p(mm)=idof(j) q(idof(j))=1 endif enddo enddo ndi=mm do i=1,ndf if(q(i)/=0) cycle mm=mm+1 p(mm)=i enddo if(mm/=ndf) stop 8871 c do i=1,ndf q(p(i))=i enddo c call dorder(ip,p,q,itdof,maxd,gf) c if (icutsw<=1) then ip(27)=newntf ip(28)=newnvf ip(29)=newnbf ip(31)=nvv ip(32)=nbb ip(33)=ndd ip(34)=nvi ip(35)=nbi endif ip(30)=newndf ip(36)=ndi c c if we just want to organize the data return c if(icutsw==1) return c c set artificial boundary conditions c do i=1,nbb if(ibndry(4,i)==0) then if(ibndry(5,i)>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(3)=newnbf ip(4)=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cutr2(ll,ip,itnode,ibndry,vx,vy,sf, + itedge,ibedge,maxd,gf,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(ll) :: p,q,befor,after integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxd,*) :: gf cy data index/1,2,3,2,3,1,3,1,2/ c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) newntf=ip(27) newnvf=ip(28) newnbf=ip(29) c** newndf=ip(30) nbb=ip(32) nvi=ip(34) nbi=ip(35) ndi=ip(36) irgn=ip(50) c c insure proper orientation c do i=newntf+1,ntf do j=1,3 if(itedge(j,i)>=0) cycle k=-itedge(j,i) ibsv=ibndry(1,k) ibndry(1,k)=itnode(index(2,j),i) ibndry(2,k)=itnode(index(3,j),i) if(ibndry(4,k)==0.and.itnode(4,i)/=irgn) then if(ibedge(1,k)/4/=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)==irgn) then ibndry(1,k)=itnode(index(2,jj),ii) ibndry(2,k)=itnode(index(3,jj),ii) else if(itnode(4,ii)=k2rgn) ksw=1 if(ksw==0) then nbi=nbi+1 p(ii)=p(nbi) p(nbi)=i endif endif enddo call border(ip,p,q,ibndry,sf) c c the rest of the interface edges c do i=1,nbf p(i)=0 enddo do i=newnbf+1,nbi jj=abs(ibndry(5,i)) p(jj)=p(jj)+1 enddo ii=newnbf+1 do i=1,nbf jj=p(i) p(i)=ii ii=jj+ii enddo do i=newnbf+1,nbi jj=abs(ibndry(5,i)) 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,sf) c c collect interface edges in consecutive entries c do i=1,nvf after(i)=0 befor(i)=0 enddo nedge=0 do i=newnbf+1,nbi ii=abs(ibndry(5,i)) im=abs(ibndry(5,i-1)) if(ii/=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))==0) ii=i enddo if(ii==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,sf) 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))==0) q(ibndry(1,i))=1 if(q(ibndry(2,i))==0) q(ibndry(2,i))=1 enddo nvi=newnvf do ii=newnvf+1,nvf i=p(ii) if(q(i)/=1) cycle nvi=nvi+1 p(ii)=p(nvi) p(nvi)=i 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<=nn) cycle nn=nn+1 p(ii)=p(nn) p(nn)=ibndry(j,i) q(p(nn))=nn q(p(ii))=ii enddo enddo if(nn/=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,iflag) do i=1,ndf p(i)=0 q(i)=0 enddo mm=0 do i=1,nbb call l2gmpe(i,ibedge,iord,idof,itdof) do j=1,iord+1 if(q(idof(j))/=0) cycle mm=mm+1 p(mm)=idof(j) q(idof(j))=1 enddo enddo ndd=mm do i=1,newntf call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof if(q(idof(j))/=0) cycle mm=mm+1 p(mm)=idof(j) q(idof(j))=1 enddo enddo newndf=mm do i=newnbf+1,nbi call l2gmpe(i,ibedge,iord,idof,itdof) do j=1,iord+1 if(q(idof(j))==0) then mm=mm+1 p(mm)=idof(j) q(idof(j))=1 endif enddo enddo ndi=mm do i=1,ndf if(q(i)/=0) cycle mm=mm+1 p(mm)=i enddo if(mm/=ndf) stop 8872 c do i=1,ndf q(p(i))=i enddo call dorder(ip,p,q,itdof,maxd,gf) c ip(30)=newndf ip(33)=ndd ip(34)=nvi ip(35)=nbi ip(36)=ndi c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkpth(nbf,ip,irgn,ipath,itnode,ibndry,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(100) :: ip,idof,idof1 integer(kind=iknd), dimension(4,2*nbf) :: itree integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(5,*) :: itnode cy 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,*) +-m +-m +-m +-m c ipath(6,*) iord iord iord iord 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) maxpth=ip(82) c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,iflag) do i=1,nbf if(ibndry(4,i)/=0) cycle it=ibedge(1,i)/4 jt=ibedge(2,i)/4 ir=itnode(4,it) jr=itnode(4,jt) if(ir==irgn) cycle if(jr/=irgn.and.jr>ir) cycle ii=ibedge(1,i) ibedge(1,i)=ibedge(2,i) ibedge(2,i)=ii enddo c if(irgn>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>len) go to 20 itest=1 if(irgn==0.and.ibndry(4,k)<3) itest=0 if(itest==1) then nseg=nseg+1 if(nseg>maxpth) then ip(25)=82 return endif istrt=ibndry(1,k) last=ibndry(2,k) lab=abs(ibndry(5,k)) ipath(1,nseg)=-lab ipath(2,nseg)=0 ipath(3,nseg)=k do i=k+1,len+1 isw=0 ilab=abs(ibndry(5,i)) if(i>len) then isw=1 else if(ibndry(1,i)/=last) then isw=1 else if(ilab/=lab) then isw=1 else if(ibndry(2,i)==istrt) then last=0 else last=ibndry(2,i) endif if(isw==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=max(mxlab,-ipath(1,iseg)) enddo istop=nseg do jseg=istart,istop c c make tree c call etree(nbf,jseg,ipath,ibndry,itree,len) c c set up tree in ipath c iseg=jseg-1 ipath(2,jseg)=2*len-1 do iseg=iseg+1 if(iseg>nseg) exit if(ipath(3,iseg)/=ipath(4,iseg)) then if(nseg+2>maxpth) then ip(25)=82 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==jseg) iseg=nseg nseg=nseg+2 else ib=ipath(3,iseg) ipath(2,iseg)=-ib call l2gmpe(ib,ibedge,iord,idof,itdof) call g2lpth(iseg,idof,iord+1,ipath) if(iseg==jseg) exit endif enddo enddo c c dofs for internal edges c do iseg=nseg,istart,-1 ison=ipath(2,iseg) if(ison<=0) cycle call l2gpth(ison,idof,ndof,ipath) call l2gpth(ison+1,idof1,ndof1,ipath) if(idof(ndof)/=idof1(1)) stop 4443 ndof=min(ndof,ndof1) idof(ndof)=idof1(ndof1) call g2lpth(iseg,idof,ndof,ipath) enddo c if(irgn>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 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine updhpi(i,len,p,q,list,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: p,q,list cy 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==0.or.k==1) go to 10 kfath=k/2 if(list(p(k))>list(p(kfath))) go to 60 c c push c 10 kson=2*k if(kson>len) return if(ksonlist(p(kson))) kson=kson+1 endif if(list(p(k))>=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==0) return if(list(p(kfath))>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine etree(nbf,jseg,ipath,ibndry,itree,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(4,*) :: itree integer(kind=iknd), dimension(2*nbf) :: list,p,q cy 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=ibndry(6,i)+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_iknd) 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_iknd,last,p,q,list,0_iknd) j=p(1) p(1)=p(last) p(last)=j q(p(last))=last q(p(1))=1 last=last-1 call updhpi(1_iknd,last,p,q,list,0_iknd) c c create the father node c if(itree(1,i)0) ipath(2,j)=ipath(2,j)+jb0 enddo 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)>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)<=0) cycle k=ipath0(3,ipath(1,j)) ipath(1,j)=ipath(1,j)+ipath(1,k)-ipath0(1,k) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine matchp(mxlab,nproc,ipath) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(mxlab) :: list cy c sort and match the tree roots c if(mxlab<=0) return do i=1,mxlab list(i)=0 enddo do iseg=ipath(1,nproc+2),ipath(2,nproc+2) if(ipath(1,iseg)>=0) cycle lab=abs(ipath(1,iseg)) if(list(lab)==0) then list(lab)=iseg else jseg=list(lab) ipath(1,iseg)=jseg ipath(1,jseg)=iseg endif enddo c c now match children c do iseg=ipath(1,nproc+2),ipath(2,nproc+2) ison=ipath(2,iseg) if(ison<=0) cycle if(ipath(1,ison)>0) cycle jseg=ipath(1,iseg) if(jseg<=0) cycle if(ipath(1,jseg)/=iseg) stop 2370 json=ipath(2,jseg) if(json<=0) cycle ipath(1,ison)=json+1 ipath(1,ison+1)=json ipath(1,json)=ison+1 ipath(1,json+1)=ison enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkpthi(nbf,mxlab,ip,ipath,itnode,ibndry,itdof,iptsw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(4,2*nbf) :: itree integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(2,mxlab) :: list integer(kind=iknd), save, dimension(3,3) :: index cy 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) ndd=ip(33) nvi=ip(34) nbi=ip(35) maxpth=ip(82) nvv=ipath(4,nproc+2) nbf=ip(3) c call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,iflag) do i=1,nbf if(ibndry(4,i)/=0) cycle it=ibedge(1,i)/4 jt=ibedge(2,i)/4 ir=itnode(4,it) jr=itnode(4,jt) if(ir==irgn) cycle if(jr/=irgn.and.jr>ir) cycle ii=ibedge(1,i) ibedge(1,i)=ibedge(2,i) ibedge(2,i)=ii enddo 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>nbi) go to 40 nseg=nseg+1 if(nseg>maxpth) then ip(25)=82 return endif istrt=ibndry(1,k) last=ibndry(2,k) lab=abs(ibndry(5,k)) ipath(1,nseg)=-lab ipath(2,nseg)=0 ipath(3,nseg)=k do i=k+1,nbi+1 isw=0 ilab=abs(ibndry(5,i)) if(i>nbi) then isw=1 else if(ibndry(1,i)/=last) then isw=1 else if(ilab/=lab) then isw=1 else if(ibndry(2,i)==istrt) then last=0 else last=ibndry(2,i) endif if(isw==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(nbf,jseg,ipath,ibndry,itree,len) c c set up tree in ipath c iseg=jseg-1 ipath(2,jseg)=2*len-1 do iseg=iseg+1 if(iseg>nseg) exit if(ipath(3,iseg)/=ipath(4,iseg)) then if(nseg+2>maxpth) then ip(25)=82 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==jseg) iseg=nseg nseg=nseg+2 else ib=ipath(3,iseg) ipath(2,iseg)=-ib if(iptsw==1) then call l2gmpe(ib,ibedge,iord,idof,itdof) do j=1,iord+1 if(idof(j)<=ndd) cycle idof(j)=idof(j)-newndf+ndd enddo call g2lpth(iseg,idof,iord+1,ipath) else ipath(3,iseg)=ibndry(1,ib)-newnvf+nvv ipath(4,iseg)=ibndry(2,ib)-newnvf+nvv endif if(iseg==jseg) exit endif enddo enddo c ipath(1,nproc+1)=istart ipath(2,nproc+1)=nseg ipath(3,nproc+1)=nvv+1 if(iptsw==0) then ipath(4,nproc+1)=nvv+(nvi-newnvf) do i=istart,nseg if(ipath(2,i)>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)<=nvv) ipath(3,i)=0 if(ipath(4,i)<=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(1,i)=0 list(2,i)=0 enddo do jrgn=1,nproc do iseg=ipath(1,jrgn),ipath(2,jrgn) if(ipath(1,iseg)>=0) cycle lab=-ipath(1,iseg) if(list(1,lab)==0) then list(1,lab)=iseg else list(2,lab)=iseg endif enddo enddo do iseg=ipath(1,nproc+1),ipath(2,nproc+1) if(ipath(1,iseg)>=0) cycle lab=-ipath(1,iseg) ipath(1,iseg)=list(2,lab) enddo do iseg=ipath(1,nproc+1),ipath(2,nproc+1) ison=ipath(2,iseg) if(ison<=0) cycle if(ipath(1,ison)>0) cycle jseg=ipath(1,iseg) if(jseg<=0) cycle json=ipath(2,jseg) if(json>0) then ipath(1,ison)=json+1 ipath(1,ison+1)=json endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine intrpi(maxpth,ipath,ir0,map,nn,num,gf,gf0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(100) :: idof,idof0,idof1 integer(kind=iknd), dimension(maxpth) :: mark integer(kind=iknd), dimension(*) :: ir0,map real(kind=rknd), dimension(nn,*) :: gf,gf0 real(kind=rknd), dimension(100) :: g,g0,g1 common /atest6/nproc,myid,mpisw,mpiint,mpiflt cy c c interpolate to interface on this processor c irgn=myid+1 c c mark all edges on this processor (fine and coarse) c do i=1,maxpth mark(i)=0 enddo do iseg=ipath(1,nproc+1),ipath(2,nproc+1) jseg=ipath(1,iseg) mark(jseg)=1 mark(ipath(1,jseg))=1 enddo do iseg=ipath(1,irgn),ipath(2,irgn) mark(iseg)=1 mark(ipath(1,iseg))=1 enddo c c interpolate coarse leaf edges on this processor c do jrgn=1,nproc if(irgn==jrgn) cycle do iseg=ipath(2,jrgn),ipath(1,jrgn),-1 ison=ipath(2,iseg) if(ison<=0) cycle if(mark(ison)==1) cycle call l2gpth(iseg,idof,ndof,ipath) call l2gpth(ison,idof0,ndof0,ipath) call l2gpth(ison+1,idof1,ndof1,ipath) do ifun=1,num do i=1,ndof0 g0(i)=gf(idof0(i),ifun) enddo do i=1,ndof1 g1(i)=gf(idof1(i),ifun) enddo call p2q1d(g0,g0,ndof0-1,ndof-1) g1(1)=g0(ndof) call p2q1d(g1,g1,ndof1-1,ndof-1) g0(ndof)=g1(1) call p2p1d(g,g0,g1,ndof-1) do i=1,ndof gf(idof(i),ifun)=g(i) enddo enddo enddo enddo c do iseg=ipath(1,nproc+1),ipath(2,nproc+1) if(ipath(2,iseg)>=0) cycle jseg=ipath(1,iseg) if(ipath(2,jseg)>=0) cycle kseg=ipath(1,jseg) call l2gpth(iseg,idof,ndof,ipath) call l2gpth(jseg,idof0,ndof0,ipath) if(ndof==ndof0) cycle call l2gpth(kseg,idof1,ndof1,ipath) if(ndof>ndof0) stop 5122 if(ndof0/=ndof1) stop 5123 do ifun=1,num do i=1,ndof0 g0(i)=gf(idof0(i),ifun) g1(i)=gf(idof1(i),ifun) enddo call p2q1d(g0,g0,ndof0-1,ndof-1) call p2q1d(g1,g1,ndof0-1,ndof-1) do i=1,ndof-1 gf(idof0(i),ifun)=g0(i) gf(idof1(i),ifun)=g1(i) enddo gf(idof0(ndof0),ifun)=g0(ndof) gf(idof1(ndof1),ifun)=g1(ndof) enddo enddo c c reorder c n1=ir0(1)-1 n=ir0(n1)-ir0(1) do i=1,n do ifun=1,num gf0(i,ifun)=gf(map(i),ifun) enddo enddo do i=1,n do ifun=1,num gf(i,ifun)=gf0(i,ifun) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cequvd(ndf,nbf,ibndry,ibedge,iequv,itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: iequv integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(100) :: idof,jdof cy 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 i=1,nbf if(ibndry(4,i)>=0) cycle if(ibndry(5,i)==0) cycle if(abs(ibndry(5,i))==5) cycle j=-ibndry(4,i) if(jmaxja0) return val(next)=jrgn link(next)=link(jrow) link(jrow)=next val(jrow)=val(jrow)+1 next=next+1 else if(val(ilink)/=jrgn) then ilink=link(ilink) go to 10 endif enddo enddo c c now make ir0 c ir0(1)=n+2 do i=1,n ir0(i+1)=ir0(i)+val(i) enddo c do i=1,n next=link(i) do m=ir0(i),ir0(i+1)-1 ir0(m)=i+(n+1)*val(next) next=link(next) enddo enddo c c make irgn first on every list that contains it c do i=1,ndd idx=0 num=i+(n+1)*irgn do j=ir0(i),ir0(i+1)-1 if(ir0(j)==num) idx=j enddo if(idx==0) stop 1177 ir0(idx)=ir0(ir0(i)) ir0(ir0(i))=num enddo c c make linked list for ja0 c n=ir0(n+1)-ir0(1) do i=1,n val(i)=0 link(i)=0 enddo c next=n+2 do it=1,ntf call l2gmap(it,idof,ndof,iord,iords,itdof) jrgn=itnode(4,it) c do j=1,ndof do k=j+1,ndof irow=min(idof(j),idof(k)) icol=max(idof(j),idof(k)) if(irow<=ndd) then jrow=i2j(irow,jrgn,ndd,newndf,ir0) if(icol<=ndd) then jcol=i2j(icol,jrgn,ndd,newndf,ir0) else jcol=-icol endif ilink=link(jrow) 20 if(ilink==0) then if(next>maxja0) return val(next)=jcol link(next)=link(jrow) link(jrow)=next val(jrow)=val(jrow)+1 next=next+1 else if(val(ilink)/=jcol) then ilink=link(ilink) go to 20 endif endif enddo enddo enddo c c now make new ja0 c ja0(1)=n+2 do i=1,n ja0(i+1)=ja0(i)+val(i) enddo c do i=1,n next=link(i) do m=ja0(i),ja0(i+1)-1 ja0(m)=val(next) next=link(next) enddo 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pthmap(ip,maxpth,map,ipath,ir0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ir0,map integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(maxpth) :: rlist integer(kind=iknd), dimension(100) :: idof,jdof,kdof cy c c map ipath array ordering onto ir0 c newndf=ip(30) ndd=ip(33) ndi=ip(36) nproc=ip(49) irgn=ip(50) n=ndd+ndi-newndf n1=ir0(1)-1 c c make list of region indices c do i=1,maxpth rlist(i)=0 enddo do jrgn=1,nproc do iseg=ipath(1,jrgn),ipath(2,jrgn) rlist(iseg)=jrgn enddo enddo c do i=ir0(1),ir0(n+1)-1 map(i-n1)=0 enddo c c coarse interface c i think this orients the edges correctly for this match c do iseg=ipath(1,nproc+1),ipath(2,nproc+1) if(ipath(2,iseg)>=0) cycle jseg=ipath(1,iseg) jrgn=rlist(jseg) kseg=ipath(1,jseg) krgn=rlist(kseg) if(jrgn=0) cycle jseg=ipath(1,iseg) jrgn=rlist(jseg) call l2gpth(iseg,idof,ndof,ipath) call l2gpth(jseg,jdof,ndof,ipath) do mm=1,ndof ii=idof(mm)-ipath(3,irgn)+1 do k=ir0(ii),ir0(ii+1)-1 if(ir0(k)/n1==irgn) map(k-n1)=idof(mm) if(ir0(k)/n1==jrgn) map(k-n1)=jdof(ndof+1-mm) enddo enddo enddo do i=ir0(1),ir0(n+1)-1 if(map(i-n1)<=0) stop 5124 enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ja0map(ii,jj,i,j,ij,ji,ja0,amtx0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ja0 integer(kind=iknd) :: amtx0 cy c compute location of a(i,j) and a(j,i) c if(ii 0 c input i, interface dof in grid numbering c output i2j --corresponding vertex in jrgn interface numbering c jrgn =0 c input i, vertex in interface numbering c output i2j --corresponding vertex in grid numbering c n1=ir0(1)-1 if(jrgn>0) then ii=i if(i>ndd) ii=i-newndf+ndd it=ii+n1*jrgn do j=ir0(ii),ir0(ii+1)-1 if(ir0(j)==it) then i2j=ir0(i)-n1 return endif enddo stop 7171 else ii=i+n1 krgn=ir0(ii)/n1 i2j=ir0(ii)-n1*krgn if(i2j>ndd) i2j=i2j+newndf-ndd endif end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine paste(maxt,maxv,maxb,maxpth,ip,rp,itnode,ibndry, + ipath,vx,vy,sf,maxd,gf,ipstsw,itdof,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,maxt) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(100) :: ip,idof,jdof integer(kind=iknd), dimension(2,maxb) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(maxpth) :: order integer(kind=iknd), dimension(3) :: p,q,ibmptr,iords,iv integer(kind=iknd), dimension(maxv) :: iseed,vtype real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(3) :: e,bump real(kind=rknd), dimension(100) :: rp cy external sxy c c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) nef=ip(76) ngf=ip(77) maxpth=ip(82) cc maxt=ip(83) nproc=ip(49) irgn=ip(50) mxlab=ipath(3,nproc+2) rl=rp(21) c c make ipath array c if(ipstsw==1) then mxpth=ipath(2,nproc+2) call spth(nproc,irgn,mxpth,ipath) else nproc=0 irgn=1 call mkpth(nbf,ip,nproc,ipath,itnode,ibndry,itdof) endif call matchp(mxlab,nproc,ipath) c c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) if(iflag/=0) stop 8255 call cedge5(nbf,itedge,ibedge,1_iknd) c c refine interface edges to make conforming c ismth=0 iseg=ipath(1,irgn)-1 nseg=ipath(2,irgn) 10 iseg=iseg+1 if(iseg>nseg) go to 30 if(ipath(2,iseg)>0) go to 10 jseg=ipath(1,iseg) if(jseg<=0) go to 10 if(ipath(2,jseg)<=0) go to 10 ibdy=-ipath(2,iseg) 20 if(ibndry(4,ibdy)/=0) then itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri else if(ibndry(4,ibdy)==0) then k=ibedge(1,ibdy)/4 if(itnode(4,k)/=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,itnode, + itedge,ibndry,ibedge,itdof,vx,vy,sf,rl, 1 maxv,maxt,maxb,maxd,gf,ngf,nef, 2 ibmptr,bump,p,q,e,0_iknd,incdf,iflag,sxy) c if(iflag/=0) then ip(25)=iflag return endif ismth=1 if(isw==0) go to 20 if(nseg+2>maxpth) then ip(25)=82 return endif json=ipath(2,jseg) ipath(2,iseg)=nseg+1 ipath(1,nseg+1)=json+1 ipath(1,json+1)=nseg+1 ipath(2,nseg+1)=-nbf call l2gmpe(nbf,ibedge,iord,idof,itdof) call g2lpth(nseg+1,idof,iord+1,ipath) ipath(1,nseg+2)=json ipath(1,json)=nseg+2 ipath(2,nseg+2)=-ibdy call l2gmpe(ibdy,ibedge,iord,idof,itdof) call g2lpth(nseg+2,idof,iord+1,ipath) nseg=nseg+2 go to 10 c c 30 ipath(2,irgn)=nseg if(ismth==0) go to 40 angmin=1.0e-3_rknd arcmax=0.26e0_rknd itmax=2 c c swap edges c call cedge5(nbf,itedge,ibedge,1_iknd) call eswapa(ntf,nvf,nbf,ngf,nef,itnode,itedge,ibndry, + ibedge,vx,vy,ibmptr,bump,1_iknd,e, 1 0_iknd,1_iknd,itdof,maxd,gf) c c smoothing c call cedge5(nbf,itedge,ibedge,0_iknd) call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) call mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype, + itnode,itedge,ibndry,ibedge,sxy) c 40 ip(1)=ntf ip(2)=nvf ip(3)=nbf ip(4)=ndf call cedge5(nbf,itedge,ibedge,1_iknd) c c compute order of (potential) elements on fine interface c do iseg=ipath(1,irgn),ipath(2,irgn) jseg=ipath(1,iseg) if(jseg>0) then call l2gpth(jseg,jdof,mdof,ipath) order(iseg)=mdof-1 endif ison=ipath(2,iseg) if(ison>0) then order(ison)=order(iseg) order(ison+1)=order(iseg) endif enddo c c now adjust orders on fine interface c do iseg=ipath(1,irgn),ipath(2,irgn) if(ipath(2,iseg)>0) cycle call l2gpth(iseg,idof,ndof,ipath) c c decide what element/edge to refine c ibdy=-ipath(2,iseg) it=ibedge(1,ibdy)/4 is=1 if(itnode(4,it)/=irgn) is=2 it=ibedge(is,ibdy)/4 ied=ibedge(is,ibdy)-4*it if(itnode(4,it)/=irgn) stop 6716 c c now refine order c call locord(it,nndof,iord,iords,itdof) if(iords(ied)/=ndof-1) stop 6717 iref=0 if(order(iseg)>iords(ied)) then iords(ied)=order(iseg) iref=1 endif jord=iords(ied) do j=1,3 if(j==ied) cycle if(itedge(j,it)>=0) then iords(j)=0 else jb=-itedge(j,it) if(ibndry(5,jb)/=0) then jord=min(jord,iords(j)) else iords(j)=0 endif endif enddo if(jord/=iord) iref=1 if(iref==0) cycle call p2qdof(it,jord,iords,ndf,ngf,maxd,itedge,ibedge, + itdof,gf,incdf,iv,iflag) if(iflag/=0) then ip(25)=iflag return endif enddo c call clnup3(ntf,ndf,ngf,maxd,gf,itdof) ip(4)=ndf c if(ipstsw==1) return c c adjust interface boundary edges that have been resolved c do iseg=ipath(1,irgn),ipath(2,irgn) if(ipath(2,iseg)>0) cycle jseg=ipath(1,iseg) if(jseg<=iseg) cycle if(ipath(2,jseg)>0) cycle i=-ipath(2,iseg) j=-ipath(2,jseg) if(ibndry(4,i)/=ibndry(4,j)) stop 8123 ccc if(ibndry(5,i)/=ibndry(5,j)) stop 8124 if(ibndry(4,i)<3) stop 8125 if(ibndry(5,i)<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,itdof) call l2gmpe(j,ibedge,iord,jdof,itdof) do m=1,ngf do k=1,iord+1 gg=(gf(idof(k),m)+gf(jdof(iord+2-k),m))/2.0e0_rknd gf(idof(k),m)=gg gf(jdof(iord+2-k),m)=gg enddo enddo enddo c c delete extra edges, vertices and degress of freedom c call trmbdy(ndf,ip,itnode,ibndry,ibedge,vx,vy,sf,maxd,gf,itdof) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine paste1(maxt,maxp,maxb,nproc,ip,rp,itnode,ibndry, + vx,vy,sf,maxd,gf,ipath,itdof,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(maxp) :: iseed,vtype integer(kind=iknd), dimension(nproc+1) :: idist integer(kind=iknd), dimension(3,maxt) :: itedge integer(kind=iknd), dimension(100) :: idof,idof1,idof2,jdof integer(kind=iknd), dimension(500) :: elist,tlist,vlist, + blist integer(kind=iknd), save, dimension(10) :: corner integer(kind=iknd), dimension(2,maxb) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: p,q,ibmptr,iords,iv integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: bump,e real(kind=rknd), dimension(100) :: rp cy external sxy data corner/0,0,1,0,0,1,0,1,0,1/ 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(3) ndf=ip(4) newntf=ip(27) newnvf=ip(28) newnbf=ip(29) newndf=ip(30) nvi=ip(34) nbi=ip(35) ndi=ip(36) cc maxt=ip(83) maxv=ip(84) cc maxb=ip(86) nef=ip(76) ngf=ip(77) cc nproc=ip(49) irgn=ip(50) maxpth=ip(82) nvv=ipath(4,nproc+2) mxlab=ipath(3,nproc+2) rl=rp(21) c c initailize c call mkpthi(nbf,mxlab,ip,ipath,itnode,ibndry,itdof,0_iknd) c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) if(iflag/=0) stop 1331 call cedge5(nbf,itedge,ibedge,1_iknd) c call crdist(ntf,irgn,nproc,itnode,itedge,ibndry,ibedge,idist) call pdepth(nproc,ipath,iseed) mxdist=1 mfact=2 ntfsv=ntf iseg=ipath(1,nproc+1)-1 nseg=ipath(2,nproc+1) 10 iseg=iseg+1 if(iseg>nseg) go to 30 c c test for edges with a crosspoint endpoint c c*** if(min(ipath(3,iseg),ipath(4,iseg))>0) go to 10 if(ipath(2,iseg)>0) go to 10 jseg=ipath(1,iseg) if(jseg<=0) go to 10 if(ipath(2,jseg)<=0) go to 10 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)max(mxdist,iseed(jseg)/mfact)) go to 10 c*** if(i1>mxdist) go to 10 c 20 if(ibndry(4,ibdy)/=0) then itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri else if(ibndry(4,ibdy)==0) then k=ibedge(1,ibdy)/4 if(itnode(4,k)==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,itnode, + itedge,ibndry,ibedge,itdof,vx,vy,sf,rl, 1 maxv,maxt,maxb,maxd,gf,ngf,nef, 2 ibmptr,bump,p,q,e,0_iknd,incdf,iflag,sxy) c if(iflag/=0) then ip(25)=iflag return endif if(isw==0) go to 20 if(nseg+2>maxpth) then ip(25)=82 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 10 c 30 if(ntfsv==ntf) go to 40 ip(1)=ntf ip(2)=nvf ip(3)=nbf ip(4)=ndf ll=max(ip(3),ip(2),ip(4),ip(1),ip(70)) call cutr2(ll,ip,itnode,ibndry,vx,vy,sf,itedge, + ibedge,maxd,gf,itdof) nvi=ip(34) nbi=ip(35) ndi=ip(36) call mkpthi(nbf,mxlab,ip,ipath,itnode,ibndry,itdof,0_iknd) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) if(iflag/=0) stop 1322 call cedge5(nbf,itedge,ibedge,1_iknd) c c 40 ic=0 do iseg=ipath(1,nproc+1),ipath(2,nproc+1) ison=ipath(2,iseg) if(ison<=0) cycle if(ipath(1,ison)<=0) ic=ic+1 enddo if(ic==0) go to 60 c angmin=1.0e-3_rknd arcmax=0.26e0_rknd call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) call cedge5(nbf,itedge,ibedge,1_iknd) c c main elimination loop c do iseg=ipath(2,nproc+1),ipath(1,nproc+1),-1 ison=ipath(2,iseg) if(ison<=0) cycle if(ipath(1,ison)>0) cycle iedge=-ipath(2,ison) iv1=ibndry(1,iedge) iv2=ibndry(2,iedge) jedge=-ipath(2,ison+1) jv1=ibndry(1,jedge) jv2=ibndry(2,jedge) if(iv1==jv2) then i=iv1 else if(iv2==jv1) then i=iv2 else stop 7676 endif c c make sure the edges have the same order c call eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy, + iseed,vtype,itdof,ndf,ngf,maxd,gf,iflag) c call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) call tstvty(i,itnode,ibndry,vx,vy,sf,rl,itedge,vtype, + angmin,arcmax,vlist,tlist,elist,len,sxy) if(corner(vtype(i))==1) cycle kedge=iedge 50 it1=ibedge(1,kedge)/4 ie1=ibedge(1,kedge)-4*it1 call rmtst(it1,ie1,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,-1_iknd) if(ie1==0) then if(kedge==jedge) stop 6651 kedge=jedge go to 50 endif call rmknot(ie1,it1,iv,itnode,itedge,ibndry, + ibedge,itdof,vx,vy,sf,nef,ngf,maxd,gf,ibmptr, 1 bump,maxt,e,iseed,vtype,incdf,-1_iknd,rl,sxy) c c adjust edge point in ipath c if(ibndry(1,iedge)==0) then ipath(2,iseg)=-jedge else ipath(2,iseg)=-iedge endif enddo c c 60 ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) newntf=ip(27) newnvf=ip(28) newnbf=ip(29) newndf=ip(30) nvi=ip(34) nbi=ip(35) ndi=ip(36) call clnup2(nvf,ntf,nbf,ndf,newnvf,newntf,newnbf,newndf, + nvi,nbi,ndi,irgn,itnode,itedge,ibndry,ibedge,vx,vy, 1 sf,iseed,gf,maxd,ngf,itdof) c ip(1)=ntf ip(2)=nvf ip(3)=nbf ip(4)=ndf ip(34)=nvi ip(35)=nbi ip(36)=ndi c c reduce degrees as needed on coarse interface c ll=max(ip(3),ip(2),ip(4),ip(1),ip(70)) call cutr2(ll,ip,itnode,ibndry,vx,vy,sf,itedge, + ibedge,maxd,gf,itdof) nbf=ip(3) ndf=ip(4) call mkpthi(nbf,mxlab,ip,ipath,itnode,ibndry,itdof,0_iknd) c c c do iseg=ipath(2,nproc+1),ipath(1,nproc+1),-1 if(ipath(2,iseg)>0) cycle if(ipath(1,iseg)<=0) stop 4198 jseg=ipath(1,iseg) call l2gpth(jseg,jdof,mdof,ipath) c c check coarse interface c ibdy=-ipath(2,iseg) it1=ibedge(1,ibdy)/4 it2=ibedge(2,ibdy)/4 i1=1+min(idist(itnode(4,it1)),idist(itnode(4,it2)))/mfact c*** i1=1 do mm=1,2 it1=ibedge(mm,ibdy)/4 ie1=ibedge(mm,ibdy)-4*it1 c call locord(it1,ndof,iord,iords,itdof) c c unrefine high order coarse element c if(iords(ie1)>mdof-1) then iords(ie1)=mdof-1 iord=min(iord,iords(ie1)) else c c minimize appearance of transition edges on interface c if(iord>=mdof-i1) cycle iords(ie1)=mdof-i1 iord=mdof-i1 do j=1,3 if(j==ie1) cycle if(itedge(j,it1)>=0) then iords(j)=0 else jb=-itedge(j,it1) if(ibndry(5,jb)/=0) then iord=min(iord,iords(j)) else iords(j)=0 endif endif enddo endif call p2qdof(it1,iord,iords,ndf,ngf,maxd, + itedge,ibedge,itdof,gf,incdf,iv,iflag) enddo enddo call clnup3(ntf,ndf,ngf,maxd,gf,itdof) ip(4)=ndf c c final form of ipath c ll=max(ip(3),ip(2),ip(4),ip(1),ip(70)) call cutr2(ll,ip,itnode,ibndry,vx,vy,sf,itedge, + ibedge,maxd,gf,itdof) call mkpthi(nbf,mxlab,ip,ipath,itnode,ibndry,itdof,1_iknd) call matchp(mxlab,nproc,ipath) c******************* cc call cipath(ip,ipath) c******************* c c make sure final order matches coarse edge c do iseg=ipath(1,nproc+1),ipath(2,nproc+1) if(ipath(2,iseg)>=0) cycle call l2gpth(iseg,idof,ndof,ipath) jseg=ipath(1,iseg) call l2gpth(jseg,idof1,ndof1,ipath) if(ndof==ndof1) cycle if(ndof>ndof1) stop 5613 if(ipath(2,jseg)<=0) cycle kseg=ipath(1,jseg) call l2gpth(kseg,idof2,ndof2,ipath) c idof1(ndof)=idof1(ndof1) idof2(ndof)=idof2(ndof2) call g2lpth(jseg,idof1,ndof,ipath) call g2lpth(kseg,idof2,ndof,ipath) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine p2qdof(itri,iordc,iordsc,ndf,ngf,maxd,itedge,ibedge, + itdof,gf,incdf,iv,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(3) :: iords,iordsc,jadj, + jedge,jord,nords,kords,iv integer(kind=iknd), save, dimension(3,3) :: jords integer(kind=iknd), dimension(5) :: iptr,kptr integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof,kdof real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(100,ngf) :: g,g0,r,r0 cy c c compute neighbor information c iflag=0 incdf=0 c call l2gmap(itri,idof,ndof,iord,iords,itdof) do j=1,3 if(itedge(j,itri)>0) then jadj(j)=itedge(j,itri)/4 jedge(j)=itedge(j,itri)-4*jadj(j) else ib=-itedge(j,itri) if(ibedge(2,ib)==0) then jadj(j)=0 jedge(j)=0 else if(ibedge(2,ib)/4==itri) then jadj(j)=ibedge(1,ib)/4 jedge(j)=ibedge(1,ib)-4*jadj(j) else jadj(j)=ibedge(2,ib)/4 jedge(j)=ibedge(2,ib)-4*jadj(j) endif endif endif if(jadj(j)>0) then call locord(jadj(j),mdof,jord(j),jords(1,j),itdof) endif enddo c c sort out consistency constraints c if(iordc==0) then do j=1,3 if(iordsc(j)/=0) then nords(j)=iordsc(j) else nords(j)=iords(j) endif enddo nord=min(nords(1),nords(2),nords(3)) else do j=1,3 if(iordsc(j)/=0) then nords(j)=iordsc(j) else if(jadj(j)==0) then nords(j)=iordc else nords(j)=max(iordc,jord(j)) endif endif enddo nord=iordc endif if(abs(nord-iord)+abs(iords(1)-nords(1))+ + abs(iords(2)-nords(2))+abs(iords(3)-nords(3))==0) return c incdf=nords(1)+nords(2)+nords(3)-iords(1)-iords(2)-iords(3)+ + (nord-iord)*(nord+iord-3)/2 c c check storage c if(nord>iord) then isum=((nord-1)*(nord-2))/2 else isum=0 endif do j=1,3 if(nords(j)>iords(j)) then isum=isum+nords(j)-1 endif enddo if(ndf+isum>maxd) then iflag=1 return endif c c do interpolation c do ifun=1,ngf do j=1,ndof g0(j,ifun)=gf(idof(j),ifun) enddo call p2q2d(g0(1,ifun),g(1,ifun),iord,nord,iords,nords) enddo c c edges c call mkgptr(nord,nords,iptr) itdof(8,itri)=nord+16*nords(1)+256*nords(2)+4096*nords(3) do j=1,3 iv(j)=0 if(iords(j)==nords(j)) cycle if(jadj(j)>0) then jords(jedge(j),j)=nords(j) neword=min(jords(1,j),jords(2,j),jords(3,j)) if(neword/=jord(j)) then call l2gmap(jadj(j),kdof,mdof,kord,kords,itdof) do ifun=1,ngf do k=1,mdof r0(k,ifun)=gf(kdof(k),ifun) enddo call p2q2d(r0(1,ifun),r(1,ifun), + kord,neword,kords,jords(1,j)) enddo call mkgptr(neword,jords(1,j),kptr) ii=kptr(4) nn=kptr(5)-kptr(4) if(neword>jord(j)) then itdof(7,jadj(j))=ndf+1 ndf=ndf+nn endif jj=itdof(7,jadj(j)) do k=1,nn do ifun=1,ngf gf(jj+k-1,ifun)=r(ii+k-1,ifun) enddo enddo iv(j)=jadj(j) incdf=incdf+(neword-jord(j))*(neword+jord(j)-3)/2 jord(j)=neword endif itdof(8,jadj(j))=jord(j) + +16*jords(1,j)+256*jords(2,j)+4096*jords(3,j) endif if(nords(j)==1) then itdof(3+j,itri)=0 if(jadj(j)>0) then itdof(3+jedge(j),jadj(j))=0 endif cycle endif if(iords(j)>nords(j)) then if(itdof(3+j,itri)>0) then if(jadj(j)>0) then itdof(3+jedge(j),jadj(j))= + -(itdof(3+j,itri)+nords(j)-2) endif else if(jadj(j)>0) then itdof(3+j,itri)= + -(itdof(3+jedge(j),jadj(j))+nords(j)-2) endif endif else if(itdof(3+j,itri)>0) then itdof(3+j,itri)=ndf+1 if(jadj(j)>0) then itdof(3+jedge(j),jadj(j))=-(ndf+nords(j)-1) endif else if(jadj(j)>0) then itdof(3+jedge(j),jadj(j))=ndf+1 endif itdof(3+j,itri)=-(ndf+nords(j)-1) endif ndf=ndf+nords(j)-1 endif ii=iptr(j) jj=itdof(3+j,itri) if(jj>0) then do k=1,nords(j)-1 do ifun=1,ngf gf(jj+k-1,ifun)=g(ii+k-1,ifun) enddo enddo else do k=1,nords(j)-1 do ifun=1,ngf gf(-(jj+k-1),ifun)=g(ii+k-1,ifun) enddo enddo endif enddo c c interior c if(nord>2) then nn=((nord-1)*(nord-2))/2 if(nord>iord) then itdof(7,itri)=ndf+1 ndf=ndf+nn endif ii=iptr(4) jj=itdof(7,itri) do k=1,nn do ifun=1,ngf gf(jj+k-1,ifun)=g(ii+k-1,ifun) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine newnot(itri,iedge,nvf,ntf,nbf,ndf,itnode, + itedge,ibndry,ibedge,itdof,vx,vy,sf,rl,maxv,maxt,maxb, 1 maxd,gf,ngf,nef,ibmptr,bump,p,q,e,isw,incdf,iflag,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(3) :: iords,jords,iord0,iord1 integer(kind=iknd), dimension(5) :: iptr,jptr integer(kind=iknd), save, dimension(4) :: it,ib,iv integer(kind=iknd), dimension(*) :: p,q,ibmptr integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof,jdof integer(kind=iknd), dimension(50,20) :: map,map0,mark integer(kind=iknd), dimension(50) :: emap,emap0,emark real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(maxd,*) :: gf real(kind=rknd), dimension(3) :: c real(kind=rknd), dimension(12) :: values real(kind=rknd), dimension(100) :: gv common /pltmg1/ic(3,363),jc(12) cy external sxy data index/1,2,3,2,3,1,3,1,2/ data it/1,2,2,2/ data ib/1,1,2,0/ data iv/1,1,2,1/ c c check storage c call locord(itri,ndof,iord,iords,itdof) ibdy=-itedge(iedge,itri) if(ibdy<0) then icase=4 jtri=itedge(iedge,itri)/4 jedge=itedge(iedge,itri)-4*jtri else if(ibndry(4,ibdy)>0) then icase=1 else if(ibndry(4,ibdy)==0) then icase=2 if(ibedge(1,ibdy)/4/=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)>maxv) then iflag=84 return endif if(nbf+ib(icase)>maxb) then iflag=86 return endif if(ntf+it(icase)>maxt) then iflag=83 return endif incdf=((iord-2)*(iord-1))/2+1+iord-1+iords(iedge)-1 if(icase/=1) then call l2gmap(jtri,jdof,ndof,jord,jords,itdof) incdf=incdf+((jord-2)*(jord-1))/2+jord-1 if(icase==3) incdf=incdf+1+iords(iedge)-1 endif if(ndf+incdf>maxd) then iflag=85 return endif iflag=0 nvf=nvf+iv(icase) nbf=nbf+ib(icase) ntf=ntf+it(icase) ndf0=ndf ndf=ndf+incdf c c if(icase/=4) go to 5 iv2=itnode(index(2,iedge),itri) iv3=itnode(index(3,iedge),itri) vx(nvf)=(vx(iv2)+vx(iv3))/2.0e0_rknd vy(nvf)=(vy(iv2)+vy(iv3))/2.0e0_rknd go to 10 c c refine ibdy c 5 if(ibndry(3,ibdy)>0) then call midpt(vx(ibndry(1,ibdy)),vy(ibndry(1,ibdy)), + vx(ibndry(2,ibdy)),vy(ibndry(2,ibdy)), 1 sf(1,ibdy),sf(2,ibdy),vx(nvf),vy(nvf)) else if(ibndry(3,ibdy)<0) then do k=1,12 values(k)=0.0e0_rknd enddo itag=-ibndry(3,ibdy) theta=(sf(1,ibdy)+sf(2,ibdy))/2.0e0_rknd call sxy(rl,theta,itag,values) vx(nvf)=values(1) vy(nvf)=values(2) else vx(nvf)=(vx(ibndry(1,ibdy))+vx(ibndry(2,ibdy)))/2.0e0_rknd vy(nvf)=(vy(ibndry(1,ibdy))+vy(ibndry(2,ibdy)))/2.0e0_rknd endif c do k=1,7 ibndry(k,nbf)=ibndry(k,ibdy) enddo if(ibndry(3,ibdy)>=0) then do k=1,2 sf(k,nbf)=sf(k,ibdy) enddo else if(ibndry(1,ibdy)==itnode(index(2,iedge),itri)) then theta2=sf(1,ibdy) theta3=sf(2,ibdy) else theta2=sf(2,ibdy) theta3=sf(1,ibdy) endif sf(1,nbf)=theta2 sf(2,nbf)=theta sf(1,ibdy)=theta sf(2,ibdy)=theta3 endif 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)/=0) then is=ibndry(6,ibdy)+1 ibndry(6,ibdy)=2*is-1 ibndry(6,nbf)=2*is if(ibndry(6,nbf)/=ibndry(6,ibdy)+1) stop 8888 endif c if(icase==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/=3) go to 10 if(ibndry(3,jbdy)>0) then call midpt(vx(ibndry(1,jbdy)),vy(ibndry(1,jbdy)), + vx(ibndry(2,jbdy)),vy(ibndry(2,jbdy)), 1 sf(1,ibdy),sf(2,ibdy),vx(nvf-1),vy(nvf-1)) else if(ibndry(3,jbdy)<0) then do k=1,12 values(k)=0.0e0_rknd enddo itag=-ibndry(3,jbdy) theta=(sf(1,jbdy)+sf(2,jbdy))/2.0e0_rknd call sxy(rl,theta,itag,values) vx(nvf-1)=values(1) vy(nvf-1)=values(2) else vx(nvf-1)=(vx(ibndry(1,jbdy))+vx(ibndry(2,jbdy)))/2.0e0_rknd vy(nvf-1)=(vy(ibndry(1,jbdy))+vy(ibndry(2,jbdy)))/2.0e0_rknd endif c do k=1,7 ibndry(k,nbf-1)=ibndry(k,jbdy) enddo if(ibndry(3,jbdy)>=0) then do k=1,2 sf(k,nbf-1)=sf(k,jbdy) enddo else if(ibndry(2,jbdy)==itnode(index(3,jedge),jtri)) then theta2=sf(1,jbdy) theta3=sf(2,jbdy) else theta2=sf(2,jbdy) theta3=sf(1,jbdy) endif sf(1,nbf-1)=theta sf(2,nbf-1)=theta3 sf(1,ibdy)=theta2 sf(2,ibdy)=theta endif 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)/=0) then is=ibndry(6,jbdy)+1 ibndry(6,jbdy)=2*is-1 ibndry(6,nbf-1)=2*is if(ibndry(6,nbf-1)/=ibndry(6,jbdy)+1) stop 8889 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==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>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==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,iord,iords,itdof) call mkgptr(iord,iords,iptr) do j=1,8 itdof(j,ntf)=itdof(j,itri) enddo i2=index(2,iedge) i3=index(3,iedge) c do j=1,3 iord0(j)=iords(j) iord1(j)=iords(j) enddo iord0(i2)=iord iord1(i3)=iord itdof(8,itri)=iord+16*iord0(1)+256*iord0(2)+4096*iord0(3) itdof(8,ntf) =iord+16*iord1(1)+256*iord1(2)+4096*iord1(3) c c fixup vertices, old edges c ndf0=ndf0+1 itdof(i3,itri)=ndf0 itdof(i2,ntf)=ndf0 c itdof(3+iedge,ntf)=ndf0+1 len=iords(iedge)-1 ndf0=ndf0+len c emap(1)=idof(i2) emap(len+2)=itdof(i3,itri) emap(2*len+3)=idof(i3) emap0(1)=idof(i2) do j=2,2*len+2 emark(j)=0 emap0(j)=0 enddo emap(2*len+3)=idof(i3) ii=iptr(iedge)-1 do j=1,len emap(j+1)=idof(ii+j) emark(2*j+1)=ii+j emap0(2*j+1)=idof(ii+j) emap(len+2+j)=itdof(3+iedge,ntf)+j-1 enddo c c interpolation along refined edge c do i=2*len+2,2,-1 if(emap0(i)/=0) then if(emap0(i)/=emap(i)) then do ifn=1,ngf gf(emap(i),ifn)=gf(emap0(i),ifn) enddo idof(emark(i))=emap(i) endif else c(iedge)=0.0e0_rknd c(i3)=real(i-1,rknd)/real(2*len+2,rknd) c(i2)=1.0e0_rknd-c(i3) call beval1(c,gv,iord,iords) do ifn=1,ngf sum=0.0e0_rknd do m=1,ndof sum=sum+gf(idof(m),ifn)*gv(m) enddo gf(emap(i),ifn)=sum enddo endif enddo itdof(3+i2,itri)=ndf0+1 itdof(3+i3,ntf)=-(ndf0+iord-1) ndf0=ndf0+iord-1 if(ndof<=4) go to 30 c c interior vertices and new edge c map0 is the old layout c do j=1,iord+1 do i=1,2*(iord+1-j)+1 map0(i,j)=0 mark(i,j)=0 enddo enddo c itdof(7,ntf)=ndf0+1 m2=index(2,i2) m3=index(3,i2) istrt=jc(iord)+3*iord ishift=iptr(4)-istrt do i=istrt,jc(iord+1)-1 mark(2*ic(m2,i)+1,ic(m3,i)+1)=i+ishift map0(2*ic(m2,i)+1,ic(m3,i)+1)=idof(i+ishift) map(ic(m2,i)+1,ic(m3,i)+1)=idof(i+ishift) ndf0=ndf0+1 map(ic(m2,i)+1+iord-ic(m3,i),ic(m3,i)+1)=ndf0 enddo c c new edge c do i=2,iord map(iord+2-i,i)=itdof(3+i2,itri)+i-2 enddo c c fixup old function values c do j=2,iord do i=2*(iord+1-j),2,-1 if(map0(i,j)/=0) then if(map(i,j)/=map0(i,j)) then do ifn=1,ngf gf(map(i,j),ifn)=gf(map0(i,j),ifn) enddo idof(mark(i,j))=map(i,j) endif else c(iedge)=real(j-1,rknd)/real(iord,rknd) c(i3)=real(i-1,rknd)/real(2*iord,rknd) c(i2)=1.0e0_rknd-c(iedge)-c(i3) call beval1(c,gv,iord,iords) do ifn=1,ngf sum=0.0e0_rknd do m=1,ndof sum=sum+gf(idof(m),ifn)*gv(m) enddo gf(map(i,j),ifn)=sum enddo endif enddo enddo c c refine jtri c 30 if(icase==1) go to 50 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==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==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>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==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,jord,jords,itdof) call mkgptr(jord,jords,jptr) do j=1,8 itdof(j,ntf1)=itdof(j,jtri) enddo j2=index(2,jedge) j3=index(3,jedge) c do j=1,3 iord0(j)=jords(j) iord1(j)=jords(j) enddo iord0(j2)=jord iord1(j3)=jord itdof(8,ntf1)=jord+16*iord0(1)+256*iord0(2)+4096*iord0(3) itdof(8,jtri)=jord+16*iord1(1)+256*iord1(2)+4096*iord1(3) c c fixup vertices, original edges c itdof(j2,jtri)=itdof(i3,itri) itdof(j3,ntf1)=itdof(i3,itri) itdof(3+jedge,ntf1)=-(itdof(3+iedge,ntf)+len-1) c itdof(3+j3,jtri)=-(ndf0+jord-1) itdof(3+j2,ntf1)=ndf0+1 ndf0=ndf0+jord-1 if(ndof<=4) go to 40 c c interior vertices and new edge c map0 is the old layout c do j=1,jord+1 do i=1,2*(jord+1-j)+1 map0(i,j)=0 mark(i,j)=0 enddo enddo c itdof(7,jtri)=ndf0+1 m2=index(2,j2) m3=index(3,j2) jstrt=jc(jord)+3*jord jshift=jptr(4)-jstrt do i=jstrt,jc(jord+1)-1 mark(2*ic(m2,i)+1,ic(m3,i)+1)=i+jshift map0(2*ic(m2,i)+1,ic(m3,i)+1)=jdof(i+jshift) map(ic(m2,i)+1,ic(m3,i)+1)=jdof(i+jshift) ndf0=ndf0+1 map(ic(m2,i)+1+jord-ic(m3,i),ic(m3,i)+1)=ndf0 enddo c c new edge c do i=2,jord map(jord+2-i,i)=itdof(3+j2,ntf1)+i-2 enddo c c fixup old function values c do j=2,jord do i=2*(jord+1-j),2,-1 if(map0(i,j)/=0) then if(map(i,j)/=map0(i,j)) then do ifn=1,ngf gf(map(i,j),ifn)=gf(map0(i,j),ifn) enddo jdof(mark(i,j))=map(i,j) endif else c(jedge)=real(j-1,rknd)/real(jord,rknd) c(j3)=real(i-1,rknd)/real(2*jord,rknd) c(j2)=1.0e0_rknd-c(jedge)-c(j3) call beval1(c,gv,jord,jords) do ifn=1,ngf sum=0.0e0_rknd do m=1,ndof sum=sum+gf(jdof(m),ifn)*gv(m) enddo gf(map(i,j),ifn)=sum enddo endif enddo enddo c 40 if(isw==1) then ibmptr(ntf1+1)=ibmptr(ntf1)+ibmptr(jtri+1)-ibmptr(jtri) jj=ibmptr(jtri)-ibmptr(ntf1) do k=ibmptr(ntf1),ibmptr(ntf1+1)-1 bump(k)=bump(jj+k) enddo if(e(jtri,1)>0.0e0_rknd) then call tqual(ntf1,itnode,vx,vy,ibmptr,bump,itdof, + nef,ee,e2) else ee=0.0e0_rknd endif e(ntf1,1)=ee e(ntf1,2)=e(jtri,2) p(ntf1)=ntf1 q(ntf1)=ntf1 call updhp(ntf1,ntf1,p,q,e,1_iknd) if(e(jtri,1)>0.0e0_rknd) then call tqual(jtri,itnode,vx,vy,ibmptr,bump,itdof, + nef,ee,e2) e(jtri,1)=ee kk=q(jtri) call updhp(kk,ntf1,p,q,e,1_iknd) endif else if(isw==-1) then e(ntf1,1)=e(jtri,1)-1.0e0_rknd e(ntf1,2)=e(jtri,2) p(ntf1)=ntf1 q(ntf1)=ntf1 call updhp(ntf1,ntf1,p,q,e,1_iknd) e(jtri,1)=e(jtri,1)-1.0e0_rknd kk=q(jtri) call updhp(kk,ntf1,p,q,e,1_iknd) endif 50 if(isw==1) then ibmptr(ntf+1)=ibmptr(ntf)+ibmptr(itri+1)-ibmptr(itri) jj=ibmptr(itri)-ibmptr(ntf) do k=ibmptr(ntf),ibmptr(ntf+1)-1 bump(k)=bump(jj+k) enddo if(e(itri,1)>0.0e0_rknd) then call tqual(ntf,itnode,vx,vy,ibmptr,bump,itdof, + nef,ee,e2) else ee=0.0e0_rknd endif e(ntf,1)=ee e(ntf,2)=e(itri,2) p(ntf)=ntf q(ntf)=ntf call updhp(ntf,ntf,p,q,e,1_iknd) if(e(itri,1)>0.0e0_rknd) then call tqual(itri,itnode,vx,vy,ibmptr,bump,itdof, + nef,ee,e2) e(itri,1)=ee kk=q(itri) call updhp(kk,ntf,p,q,e,1_iknd) endif else if(isw==-1) then e(ntf,1)=e(itri,1)-1.0e0_rknd e(ntf,2)=e(itri,2) p(ntf)=ntf q(ntf)=ntf call updhp(ntf,ntf,p,q,e,1_iknd) e(itri,1)=e(itri,1)-1.0e0_rknd kk=q(itri) call updhp(kk,ntf,p,q,e,1_iknd) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine etst1(itri0,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: h cy 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_rknd 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)0) then icase=1 return else if(ibndry(4,ibdy)==0) then icase=2 if(ibedge(1,ibdy)/4/=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)>=thresh*max(h(2),h(3))) then itri=itsv iedge=iesv return endif isw=0 c c find longest edge c 30 if(h(2)>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<0) then jtri=itedge(kedge,itri)/4 jedge=itedge(kedge,itri)-4*jtri else if(ibndry(4,kbdy)>0) then iedge=kedge return else if(ibndry(4,kbdy)==0) then if(4*itri+kedge==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)>=thresh*max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine etst(ibdy,irgn,itri,iedge,isw,itnode, + itedge,ibndry,ibedge,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: h cy 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_rknd c c find itri, iedge in irgn c if(ibndry(4,ibdy)/=0) then itri=ibedge(1,ibdy)/4 iedge=ibedge(1,ibdy)-4*itri else if(ibndry(4,ibdy)==0) then k=ibedge(1,ibdy)/4 if(itnode(4,k)/=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)>=thresh*max(h(2),h(3))) go to 20 isw=0 c c find longest edge c 10 if(h(2)>h(3)) then kedge=index(2,iedge) else kedge=index(3,iedge) endif c c find opposing triangle c if(itedge(kedge,itri)>0) then jtri=itedge(kedge,itri)/4 jedge=itedge(kedge,itri)-4*jtri else kbdy=-itedge(kedge,itri) if(ibndry(4,kbdy)>0) then iedge=kedge return else if(ibndry(5,kbdy)/=0) then if(itri==itsv) then isw=1 go to 20 else return endif else if(ibndry(4,kbdy)==0) then if(4*itri+kedge==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)>=thresh*max(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)==0) then if(4*itri+iedge==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)>=thresh*max(h(2),h(3))) then itri=itsv iedge=iesv return endif isw=0 c c find longest edge c 30 if(h(2)>h(3)) then kedge=index(2,iedge) else kedge=index(3,iedge) endif c c find opposing triangle c if(itedge(kedge,itri)>0) then jtri=itedge(kedge,itri)/4 jedge=itedge(kedge,itri)-4*jtri else kbdy=-itedge(kedge,itri) if(ibndry(4,kbdy)>0) then iedge=kedge return else if(ibndry(5,kbdy)/=0) then if(itri==jtsv) then isw=1 itri=itsv iedge=iesv endif return else if(ibndry(4,kbdy)==0) then if(4*itri+kedge==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)>=thresh*max(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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine trmbdy(ndf,ip,itnode,ibndry,ibedge,vx,vy,sf,maxd,gf, + itdof) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(ndf) :: p,q,iequv integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxd,*) :: gf cy ntf=ip(1) nvf=ip(2) nbf=ip(3) c c mark vertices c call cequvd(ndf,nbf,ibndry,ibedge,iequv,itdof) do i=1,ndf p(i)=i enddo c c fixup itdof c do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof idof(j)=iequv(idof(j)) enddo call g2lmap(i,idof,itdof) enddo c c now reorder vertices c newndf=0 do i=1,ndf if(iequv(i)/=i) cycle newndf=newndf+1 p(i)=p(newndf) p(newndf)=i enddo c call dorder(ip,p,q,itdof,maxd,gf) c c mark vertices c call cequv1(nvf,nbf,ibndry,iequv,2_iknd) 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)/=i) cycle newnvf=newnvf+1 p(i)=p(newnvf) p(newnvf)=i enddo c call vorder(ip,p,q,itnode,ibndry,vx,vy) c c reorder ibndry c do i=1,nbf p(i)=i enddo newnbf=0 do i=1,nbf isw=1 mk=abs(ibndry(5,i)) if(mk==3.or.mk==4) then if(ibndry(4,i)<0) then m=-ibndry(4,i) if(i>m) isw=0 ibndry(4,i)=0 endif endif if(isw==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,sf) c c reset ibndry(5,*) c do i=1,newnbf if(ibndry(5,i)<0) then if(ibndry(4,i)<=0) ibndry(5,i)=-i else if(ibndry(5,i)>0) then if(ibndry(4,i)<=0) ibndry(5,i)=i endif enddo ip(2)=newnvf ip(3)=newnbf ip(70)=newnbf ip(4)=newndf return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine citdof(ntf,nvf,nbf,ip,itnode,ibndry,itedge,ibedge, + itldof,itdof,nblock,iblock,itype,jtype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge,iblock integer(kind=iknd), dimension(20) :: itc integer(kind=iknd), dimension(3) :: iords,jords integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(4,*) :: itldof integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(ntf+nvf) :: mark cy c ierrsw=ip(19) mxord=10 jtype=itype c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) c do i=1,mxord+1 itc(i)=0 enddo c c survey triangles c if(itype==0) then do it=1,ntf call locord(it,ndof,iord,iords,itdof) itc(iord+1)=itc(iord+1)+1 do j=1,3 mark(j)=0 if(itedge(j,it)<=0) cycle jt=itedge(j,it)/4 call locord(jt,ndof,jord,jords,itdof) if(iord==jord) cycle mark(j)=jord if(j>1.and.mark(1)==jord) cycle if(j>2.and.mark(2)==jord) cycle if(ierrsw==1.and.itnode(5,it)/=itnode(5,jt)) cycle itc(jord+1)=itc(jord+1)+1 enddo enddo itc(1)=1 do i=1,mxord itc(i+1)=itc(i+1)+itc(i) enddo minord=10 maxord=1 do i=1,mxord if(itc(i)==itc(1).and.itc(i+1)>itc(1)) minord=i if(itc(i)1.and.mark(1)==jord) cycle if(j>2.and.mark(2)==jord) cycle if(ierrsw==1.and.itnode(5,it)/=itnode(5,jt)) cycle itldof(4,itc(jord))=it itc(jord)=itc(jord)+1 enddo enddo do i=mxord,2,-1 itc(i)=itc(i-1) enddo itc(1)=1 else minord=10 do it=1,ntf call locord(it,ndof,iord,iords,itdof) minord=min(minord,iord) itldof(4,it)=it enddo c*** minord=1 do i=1,minord itc(i)=1 enddo do i=minord+1,mxord+1 itc(i)=ntf+1 enddo endif c do i=1,ntf mark(i)=0 enddo nblock=0 iblock(1,1)=1 do iord=1,mxord it1=itc(iord) it2=itc(iord+1)-1 if(it1>it2) cycle do it=it1,it2 itri=itldof(4,it) mark(itri)=it enddo next=it1 last=next mark(itldof(4,next))=0 10 itri=itldof(4,next) next=next+1 if(itri==0) stop 9192 do j=1,3 if(itedge(j,itri)<=0) cycle jtri=itedge(j,itri)/4 if(mark(jtri)==0) cycle if(ierrsw==1.and.itnode(5,itri)/=itnode(5,jtri)) cycle last=last+1 ktri=itldof(4,last) jloc=mark(jtri) itldof(4,jloc)=ktri itldof(4,last)=jtri mark(ktri)=jloc mark(jtri)=0 enddo if(next<=last) go to 10 nblock=nblock+1 iblock(2,nblock)=iord iblock(1,nblock+1)=next if(last>=it2) cycle last=next mark(itldof(4,next))=0 go to 10 enddo c c vertices c do i=1,nvf mark(i)=0 enddo ndl=0 iblock(3,1)=1 do ii=1,nblock it1=iblock(1,ii) it2=iblock(1,ii+1)-1 jv=iblock(3,ii)-1 do it=it1,it2 itri=itldof(4,it) do j=1,3 iv=itnode(j,itri) if(mark(iv)<=jv) then ndl=ndl+1 mark(iv)=ndl endif itldof(j,it)=mark(iv) enddo enddo iblock(3,ii+1)=ndl+1 enddo c ip(78)=ndl c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cbump(ndl,ntf,nbf,maxt,maxd,nef,u,vx,vy,sf,itnode, + itedge,ibedge,itldof,nblock,iblock,ibndry,itdof, 1 ibmptr,bump,e,rp,sxy,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(4*ndl) :: ja integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(4,*) :: itldof integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3,*) :: itedge,iblock integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(3,ntf) :: icurv integer(kind=iknd), dimension(ndl) :: ibc integer(kind=iknd), dimension(*) :: ibmptr integer(kind=iknd), dimension(3) :: iords,jords,kords integer(kind=iknd), dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy,bump real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxd,*) :: u real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(ndl,10) :: r real(kind=rknd), dimension(4*ndl) :: a1,a2 real(kind=rknd), dimension(ndl) :: z,rsv real(kind=rknd), dimension(3) :: x,y,tx,ty real(kind=rknd), dimension(12) :: scale real(kind=rknd), dimension(100) :: rx,ry,er,rp,bump0 cy data index/1,2,3,2,3,1,3,1,2/ external sxy c c compute recovered gradient c if(itype==1) then mxcg=50 mxsmth=1 ave=rp(37) cc mxcg=2 cc ave=0.0e0_rknd else mxcg=1 mxsmth=1 ave=rp(37)/sqrt(real(ntf,rknd)) endif mxord=10 ntl=iblock(1,nblock+1)-1 eps=1.0e2_rknd*epsilon(1.0e0_rknd) c call ccurv(ntf,nbf,ibndry,ibedge,icurv) c c set up ibmptr c call cscale(ntf,itnode,itdof,vx,vy,scale,itype) if(itype==0) then ibmptr(1)=mxord+2 do i=1,ntf call locord(i,ndof,iord,iords,itdof) ibmptr(i+1)=ibmptr(i)+(iord+2)*nef enddo do iord=1,mxord bump(iord)=scale(iord) enddo endif c c mark boundary points c do i=1,ndl ibc(i)=0 enddo do i=1,ntl itri=itldof(4,i) c call locord(itri,ndof,iord,iords,itdof) do j=1,3 if(itedge(j,itri)<=0) then ibc(itldof(index(2,j),i))=1 ibc(itldof(index(3,j),i))=1 c else c jtri=itedge(j,itri)/4 c call locord(jtri,ndof,jord,jords,itdof) c if(jord/=iord) then c ibc(itldof(index(2,j),i))=1 c ibc(itldof(index(3,j),i))=1 c endif endif enddo enddo c c compute mass and stiffness matrices for linear elements c maxlnk=ndl*4 call setgr1(ntl,ndl,itldof,ja,maxlnk,0_iknd,jflag) call l2mtx(ndl,vx,vy,itnode,ja,a2,itldof,ntl) call h1mtx(ndl,vx,vy,itnode,ja,a1,itldof,ntl) c nnef=nef if(itype==1) nnef=1 do ifn=1,nnef do jblock=1,nblock iord=iblock(2,jblock) n1=iblock(3,jblock) n2=iblock(3,jblock+1)-1 it1=iblock(1,jblock) it2=iblock(1,jblock+1)-1 c do j=1,iord+1 do i=n1,n2 r(i,j)=0.0e0_rknd enddo enddo c c compute right hand sides c do it=it1,it2 itri=itldof(4,it) call locord(itri,ndof,jord,jords,itdof) call l2gmpl(it,idof,ldof,itldof) c c this branch is for lower order overlap elements c if(iord>jord.and.it2-it1>n2-n1-1) then jtri=0 do m=1,3 if(itedge(m,itri)>0) then ktri=itedge(m,itri)/4 call locord(ktri,ndof,kord,kords,itdof) if(kord==iord) jtri=ktri endif enddo if(jtri==0) stop 8181 call elel2p(jtri,iord,itnode,ibndry,icurv, + itdof,vx,vy,sf,u(1,ifn),er,scale,1_iknd,sxy) call afmap(itri,itnode,vx,vy,tx,ty,x,y,deti) call afmap(jtri,itnode,vx,vy,tx,ty,x,y,detj) do j=1,iord+1 er(j)=er(j)*abs(deti/detj) enddo else c c this is the default c call elel2p(itri,iord,itnode,ibndry,icurv, + itdof,vx,vy,sf,u(1,ifn),er,scale,1_iknd,sxy) endif do k=1,ldof do j=1,iord+1 r(idof(k),j)=r(idof(k),j)+er(j) enddo enddo enddo c c l2 projection and smoothing c do j=1,iord+1 rscale=rl2nrm(n2-n1+1,r(n1,j))/a2(ndl+1) if(rscale==0.0e0_rknd) cycle do i=n1,n2 z(i)=r(i,j)/rscale r(i,j)=0.0e0_rknd enddo if(itype==1) then call sgscg1(ndl,n1,n2,ja,a2,r(1,j),z,mxcg,eps) else call jcg1(ndl,n1,n2,ja,a2,r(1,j),z,mxcg,eps) endif if(mxsmth<=0) cycle do i=n1,n2 z(i)=0.0e0_rknd rsv(i)=r(i,j) enddo call jcg1(ndl,n1,n2,ja,a1,r(1,j),z,mxsmth,eps) do i=n1,n2 if(ibc(i)==1) r(i,j)=rsv(i) r(i,j)=r(i,j)*rscale enddo enddo c c compute gradients of recovered functions c do it=it1,it2 itri=itldof(4,it) call locord(itri,ndof,jord,jords,itdof) if(jord/=iord.and.itype==0) cycle call l2gmpl(it,idof,ldof,itldof) call afmap(itri,itnode,vx,vy,tx,ty,x,y,det) iv1=idof(1) iv2=idof(2) iv3=idof(3) do j=1,iord+1 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 bump0(1)=rx(1) do j=2,iord+1 bump0(j)=(rx(j)+ry(j-1))/2.0e0_rknd enddo bump0(iord+2)=ry(iord+1) call tqualr(it,iord,itnode,ibndry,icurv,vx,vy,sf, + u(1,ifn),ndl,r,itdof,itldof,bump0,scale,ave, 1 aa,sxy) e(itri,2)=max(0.0e0_rknd,aa) c c final form of bump c if(itype==0) then ii=ibmptr(itri)-1+(ifn-1)*(iord+2) do j=1,iord+2 bump(ii+j)=bump0(j)*aa enddo endif enddo enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cscale(ntf,itnode,itdof,vx,vy,scale,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,scale real(kind=rknd), dimension(3) :: tx,ty,x,y cy c c set overall scaling factors c mxord=10 do iord=1,mxord+1 scale(iord)=0.0e0_rknd enddo if(itype==1) then do iord=1,mxord scale(iord)=real(ifac(iord+1),rknd) enddo else do i=1,ntf call locord(i,ndof,iord,iords,itdof) call afmap(i,itnode,vx,vy,tx,ty,x,y,det) dd=max(abs(x(1)),abs(x(2)),abs(x(3))) dd=max(abs(y(1)),abs(y(2)),abs(y(3)),dd) scale(iord)=max(scale(iord),dd) enddo do iord=1,mxord scale(iord)=(scale(iord)*real(iord,rknd))**iord enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdlfn(ndf,ip,itnode,itdof,udl,ja,ibs,ibp,ibo, + a,jua,ua,juac,jp,uac) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip,idof integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jua, + ibo,juac,jp integer(kind=iknd) :: amtx integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(ndf) :: mark integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), allocatable, dimension(:) :: jap real(kind=rknd), dimension(*) :: udl,a,ua,uac real(kind=rknd), dimension(ndf) :: z,b cy c ntf=ip(1) irgn=ip(50) method=ip(9) ispd=ip(8) mxcg=ip(10) nb=ip(91) eps=1.0e2_rknd*epsilon(1.0e0_rknd) epsmg=max(1.0e-3_rknd,eps) c c return if matrix data structres not set up c if(nb==0) then do i=1,ndf udl(i)=0.0e0_rknd enddo return endif c c set ups rhs c lenja=ja(nb+1) allocate(jap(lenja)) call cjap(nb,ispd,ja,jap,ibs) c amtx=0 if(ispd/=1) amtx=jap(ja(nb+1))-jap(ja(1)) c c mark dofs in irgn c do i=1,ndf mark(i)=0 z(i)=0.0e0_rknd enddo do i=1,ntf if(itnode(4,i)/=irgn) cycle call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof mark(idof(j))=1 enddo enddo c do i=1,nb if(mark(ibp(i))==0) cycle do j=1,ibs(i) z(ibp(i)+j-1)=a(jap(i)+j-1) enddo do j=jap(i)+ibs(i),jap(i+1)-1 a(j)=0.0e0_rknd enddo enddo c do i=1,nb if(mark(ibp(i))==1) then do j=ja(i),ja(i+1)-1 k=ja(j) if(mark(ibp(k))==0) then iz=ibp(k)-1 do jj=1,ibs(k) ks=jap(j)+(jj-1)*ibs(i)-1 do ii=1,ibs(i) z(iz+jj)=z(iz+jj)-a(ks+ii) enddo enddo endif do m=jap(j),jap(j+1)-1 a(m)=0.0e0_rknd a(m+amtx)=0.0e0_rknd enddo enddo else do j=ja(i),ja(i+1)-1 k=ja(j) if(mark(ibp(k))==0) cycle iz=ibp(i)-1 do jj=1,ibs(k) ks=jap(j)+(jj-1)*ibs(i)-1 do ii=1,ibs(i) z(iz+ii)=z(iz+ii)-a(ks+ii+amtx) enddo enddo do m=jap(j),jap(j+1)-1 a(m)=0.0e0_rknd a(m+amtx)=0.0e0_rknd enddo enddo endif enddo deallocate(jap) c c solve equations c if(ispd==0) then jspd=-1 else jspd=1 endif call mtxmlt(ndf,nb,ja,ibs,ibp,a,udl,b,jspd) do i=1,ndf b(i)=z(i)-b(i) enddo maxju=0 maxu=0 maxac=ja(nb+1)-1 if(ispd/=1) maxac=2*maxac-(nb+1) dtol=0.0e0_rknd hbtol=0.0e0_rknd c if(abs(method)==1) then call sfbilu(ndf,nb,ja,a,ibs,maxju,jua, + maxu,ua,ispd,dtol,0_iknd) endif if(method>=0) then call sfhb(nb,ja,jp,ibs,ibo,a, + maxju,juac,maxu,uac,ispd,hbtol,0_iknd) endif c call mg(ndf,nb,ispd,method,mxcg,0_iknd,epsmg,ja, + a,jua,ua,juac,jp,uac,ibs,ibp,ibo, 1 z,b,relerr,jflag,18_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cgdist(nvf,ntf,nbf,idist,irgn,itnode,ibndry) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7*nvf) :: jc integer(kind=iknd), dimension(nvf) :: order integer(kind=iknd), dimension(*) :: idist integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(4*nvf) :: ja cy c compute distance in graph from irgn c mxdist=0 c maxlnk=4*nvf call setgr(ntf,nvf,nbf,itnode,ibndry,ja,maxlnk) call ja2jc(nvf,ja,jc) c 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)/=irgn) cycle do j=1,3 ii=itnode(j,i) idist(ii)=0 enddo enddo c do kk=1,2 c c breadth first search c next=1 do i=1,nvf if(idist(i)==0) then order(next)=i next=next+1 else idist(i)=nvf+1 endif enddo c do ii=1,nvf if(ii>=next) go to 10 i=order(ii) do jj=jc(i),jc(i+1)-1 j=jc(jj) if(idist(j)<=nvf) cycle idist(j)=idist(i)+1 order(next)=j next=next+1 if(next>nvf) go to 10 enddo enddo c c adjust coarse interface edges near cross points c 10 if(kk==2.or.mxdist<=0) return do i=1,nbf if(ibndry(5,i)==0) cycle do j=1,2 ii=ibndry(j,i) if(idist(ii)<=mxdist) idist(ii)=0 enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine usrfn(ntf,itnode,itdof,iprob,vx,vy, + nef,ngf,maxd,maxt,u,e,rp,ibmptr,bump,uu,qxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(*) :: ibmptr real(kind=rknd), dimension(*) :: vx,vy,bump,uu real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(maxd,*) :: u real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(4,100) :: gv real(kind=rknd), dimension(12,100) :: g real(kind=rknd), dimension(3,100) :: c real(kind=rknd), dimension(2,2) :: h1nrm real(kind=rknd), dimension(12) :: scale cy external qxy c c compute user function for use in error estimates c c note this needs to be one order higher than the higest allowed c in order to work properly c mxord=10 rl=rp(21) if(iprob==7) rl=rp(46) c c set up ibmptr c call cscale(ntf,itnode,itdof,vx,vy,scale,0_iknd) ibmptr(1)=mxord+2 do i=1,ntf call locord(i,ndof,iord,iords,itdof) ibmptr(i+1)=ibmptr(i)+(iord+2)*nef enddo c do iord=1,mxord+1 bump(iord)=scale(iord) enddo c c the main loop c do i=1,ntf call locord(i,ndof,iord,iords,itdof) do j=1,3 iords(j)=iord+1 enddo call cnode0(c,iord+1,iords) call deval(i,itnode,vx,vy,g,scale1,iord+1) npts=(iord+2)*(iord+3)/2 call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + npts,gv,c,itdof,qxy) do j=ibmptr(i),ibmptr(i+1)-1 bump(j)=0.0e0_rknd enddo ii=ibmptr(i)-1 ss=scale1/scale(iord) do j=1,iord+2 sum=0.0e0_rknd do k=1,npts sum=sum+gv(4,k)*g(j,k) enddo bump(ii+j)=sum*ss enddo enddo c do i=1,ntf call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,erh1,erl2) e(i,1)=erh1 e(i,2)=10.0e0_rknd call l2gmap(i,idof,ndof,iord,iords,itdof) call cnode0(c,iord,iords) call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + ndof,gv,c,itdof,qxy) do j=1,ndof uu(idof(j))=gv(4,j) enddo enddo c c set up for h or p refinement (default is h) c thrsh1=1.8e0_rknd thrsh2=1.1e0_rknd do i=1,ntf e(i,2)=10.0e0_rknd call locord(i,ndof,iord,iords,itdof) call osc(i,itnode,itdof,vx,vy,ngf,maxd,u,rl,h1nrm,qxy) if(h1nrm(1,1)==0.0e0_rknd) cycle if(h1nrm(1,2)==0.0e0_rknd) cycle if(h1nrm(2,1)==0.0e0_rknd) cycle if(h1nrm(2,2)==0.0e0_rknd) cycle c c tests for h or p refinement c r1=(h1nrm(1,1)/h1nrm(1,2))**(1.0e0_rknd/real(iord,rknd)) r2=(h1nrm(2,1)/h1nrm(2,2))**(1.0e0_rknd/real(iord+1,rknd)) if(min(r1,r2)0) go to 20 ka=itnode(ke,kt) q=6.0e0_rknd-cang(kb,kv,ka,vx,vy)*3.0e0_rknd iq=max(int(q+0.5e0_rknd)-1,0_iknd) deg(kv)=min(5,iq) enddo c c compute degrees in deg(*) c do i=1,ntf do j=1,3 k=itedge(j,i)/4 if(i<=k) cycle j2=itnode(index(2,j),i) j3=itnode(index(3,j),i) deg(j2)=deg(j2)+1 deg(j3)=deg(j3)+1 enddo enddo c c the main loop in which the edges are swapped c do ithrsh=5,2,-1 qmin=qmin0(ithrsh) fract=fract0(ithrsh) do itnum=1,itmax ichng=0 do i=1,ntf call locord(i,ndof,iord,iords,itdof) do ied=1,3 if(iords(ied)/=iord) cycle k=itedge(ied,i)/4 if(k<=0) cycle if(itnode(4,k)/=itnode(4,i)) cycle if(itnode(5,k)/=itnode(5,i)) cycle call locord(k,mdof,kord,kords,itdof) if(iord/=kord) cycle ked=itedge(ied,i)-4*k c 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(mtst0) then if(ibndry(4,ii)/=0.and.ibndry(4,jj)/=0) + cycle endif ii=-itedge(index(ied,3),i) jj=-itedge(index(ked,2),k) if(min(ii,jj)>0) then if(ibndry(4,ii)/=0.and.ibndry(4,jj)/=0) + cycle 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=min(q2,q3) qik=min(qi,qk) if(q230) then ledge=itedge(iedge,itri)-4*ltri itedge(ledge,ltri)=4*itri+iedge else ledge=-itedge(iedge,itri) if(ibedge(1,ledge)/4==ktri) then ibedge(1,ledge)=4*itri+iedge else ibedge(2,ledge)=4*itri+iedge endif endif ltri=itedge(kedge,ktri)/4 if(ltri>0) then ledge=itedge(kedge,ktri)-4*ltri itedge(ledge,ltri)=4*ktri+kedge else ledge=-itedge(kedge,ktri) if(ibedge(1,ledge)/4==itri) then ibedge(1,ledge)=4*ktri+kedge else ibedge(2,ledge)=4*ktri+kedge endif endif c c fixup bump c if(isw==1) then mk=ibmptr(ktri)-ibmptr(itri) do m=ibmptr(itri),ibmptr(itri+1)-1 bump(m)=(bump(m)+bump(m+mk))/2.0e0_rknd bump(m+mk)=bump(m) enddo call tqual(itri,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(itri,1)=e1 call tqual(ktri,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2) e(ktri,1)=e1 endif c c fixup iseed c if(jsw==1) then iseed(itnode(ie3,itri))=4*itri+ie3 iseed(itnode(ke3,ktri))=4*ktri+ke3 endif c c fixup itdof c do i=1,8 it0(i)=itdof(i,itri) kt0(i)=itdof(i,ktri) enddo call l2gmap(itri,idof0,nidof0,iord,iords0,itdof) call l2gmap(ktri,kdof0,nkdof0,kord,kords0,itdof) call mkgptr(iord,iords0,iptr0) call mkgptr(kord,kords0,kptr0) do i=1,3 iords1(i)=iords0(i) kords1(i)=kords0(i) enddo iords1(iedge)=kords0(ke3) iords1(ie3)=iord kords1(kedge)=iords0(ie3) kords1(ke3)=iord c if(iord/=kord) stop 6017 c itdof(8,itri)=iord+16*iords1(1)+256*iords1(2) + +4096*iords1(3) itdof(8,ktri)=iord+16*kords1(1)+256*kords1(2) + +4096*kords1(3) c itdof(ie2,itri)=kt0(kedge) itdof(ke2,ktri)=it0(iedge) c itdof(iedge+3,itri)=kt0(ke3+3) itdof(ie3+3,itri)=kt0(kedge+3) itdof(kedge+3,ktri)=it0(ie3+3) itdof(ke3+3,ktri)=it0(iedge+3) c if(iord<=2) return if(ksw/=1) return c c new layout c call l2gmap(itri,idof1,nidof1,iord,iords1,itdof) call l2gmap(ktri,kdof1,nkdof1,iord,kords1,itdof) call mkgptr(iord,iords1,iptr1) call mkgptr(kord,kords1,kptr1) c c interior nodes c istrt=jc(iord)+3*iord istop=jc(iord+1)-1 is0=iptr0(4)-istrt is1=iptr1(4)-istrt ks0=kptr0(4)-istrt ks1=kptr1(4)-istrt do i=istrt,istop k1=ic(ie2,i)+1 k2=ic(ie3,i)+1 map0(k1,k2)=idof0(i+is0) c k1=iord+1-ic(ke2,i) k2=iord+1-ic(ke3,i) map0(k1,k2)=kdof0(i+ks0) c k1=ic(ie2,i)+1 k2=ic(ie3,i)+k1 map1(k1,k2)=idof1(i+is1) c k1=iord+1-ic(ke2,i) k2=k1-ic(ke3,i) map1(k1,k2)=kdof1(i+ks1) enddo c c shared edge c do ii=1,iord-1 i=jc(iord)+3+(iedge-1)*(iord-1)+ii-1 k1=ic(ie2,i)+1 k2=ic(ie3,i)+1 map0(k1,k2)=idof0(iptr0(iedge)+ii-1) c i=jc(iord)+3+(kedge-1)*(iord-1)+ii-1 k1=iord+1-ic(ke2,i) k2=iord+1-ic(ke3,i) map0(k1,k2)=kdof0(kptr0(kedge)+ii-1) c i=jc(iord)+3+(ie3-1)*(iord-1)+ii-1 k1=ic(ie2,i)+1 k2=ic(ie3,i)+k1 map1(k1,k2)=idof1(iptr1(ie3)+ii-1) c i=jc(iord)+3+(ke3-1)*(iord-1)+ii-1 k1=iord+1-ic(ke2,i) k2=k1-ic(ke3,i) map1(k1,k2)=kdof1(kptr1(ke3)+ii-1) enddo c do i=1,ngf do j=2,iord do k=2,iord gtmp(k,j)=gf(map0(k,j),i) enddo enddo do j=2,iord do k=2,iord gf(map1(k,j),i)=gtmp(k,j) enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(nvf+nbf+3*ntf) :: list integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: ibedge cy 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=min(ibndry(1,i),ibndry(2,i)) imax=max(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=max(itnode(j2,i),itnode(j3,i)) imin=min(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k<=0) then c c add triangle i, edge j to list c if(iptr<=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)>0) then ii=list(k+1)/4 jj=list(k+1)-4*ii j2=index(2,jj) j3=index(3,jj) iimax=max(itnode(j2,ii),itnode(j3,ii)) if(imax==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=max(ibndry(1,ii),ibndry(2,ii)) if(imax==iimax) then itedge(j,i)=-ii if(ibndry(4,ii)==0) then if(ibedge(1,ii)/=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)>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)/=0) cycle if(ibedge(2,i)==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)==itnode(5,k2)) then c* iflag=-43 c* return c* endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cedge5(nbf,itedge,ibedge,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge cy c switch modes in itedge c if(isw==1) then do i=1,nbf if(ibedge(2,i)<=0) cycle do k=1,2 it=ibedge(k,i)/4 iedge=ibedge(k,i)-4*it itedge(iedge,it)=-i enddo enddo else do i=1,nbf if(ibedge(2,i)<=0) cycle do k=1,2 it=ibedge(k,i)/4 iedge=ibedge(k,i)-4*it itedge(iedge,it)=ibedge(3-k,i) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(nvf+nbf*2) :: list integer(kind=iknd), save, dimension(3,3) :: index cy 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)==0) cycle imin=min(ibndry(1,i),ibndry(2,i)) imax=max(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=max(itnode(j2,i),itnode(j3,i)) imin=min(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k<=0) cycle ii=-list(k+1) iimax=max(ibndry(1,ii),ibndry(2,ii)) if(imax==iimax) then if(ibndry(4,ii)==0) then if(ibedge(1,ii)/=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 enddo enddo c c check for left over edges c do i=1,nvf if(list(i)>0) then iflag=-48 return endif enddo c c check for illegal interface edges c do i=1,nbf if(ibndry(4,i)==0) then if(ibedge(2,i)==0) then iflag=-43 return endif c** k1=ibedge(1,i)/4 c** k2=ibedge(2,i)/4 c** if(itnode(5,k1)==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tgen(ntf,maxt,maxv,ip,rp,vx,vy,sf,itnode,ibndry,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(ntf+1) :: itptr,ivptr integer(kind=iknd), dimension(5,ntf) :: irgn integer(kind=iknd), dimension(3,maxv) :: ipoly integer(kind=iknd), dimension(3,maxt) :: itedge integer(kind=iknd), dimension(maxt) :: irptr real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp cy external sxy c c this routine triangulates the user defines regions c ntr=ip(1) nvr=ip(2) nbr=ip(3) maxt=ip(83) maxv=ip(84) maxb=ip(86) rl=rp(21) c c iflag=0 c set up parameters c rp(15) = hmax c rp(16) = grade c rp(76) = qual c rp(77) = angmn c rp(78) = diam c rp(79) = best c if(rp(15)<=0.0e0_rknd.or.rp(15)>1.0e0_rknd) rp(15)=1.0e0_rknd rp(16)=max(1.5e0_rknd,rp(16)) rp(16)=min(2.5e0_rknd,rp(16)) eps=1.0e2_rknd*epsilon(1.0e0_rknd) rp(76)=sqrt(3.0e0_rknd)/2.0e0_rknd-eps rp(77)=1.0e0_rknd/4.0e0_rknd-eps call xybox(nbr,vx,vy,sf,ibndry,rp(89),rp(91),rp(78), + rp(21),sxy) c c refine boundary edges c call lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,sf, + itnode,ibndry,iflag,rl,sxy) if(iflag/=0) go to 100 c c compute local h refine original edges c llist=2*maxv call sethl(nvr,nbr,ntr,maxv,maxb,vx,vy, + sf,itnode,ibndry,rp,llist,iflag,sxy) if(iflag/=0) go to 100 c c save itnode in irgn c do i=1,ntr do j=1,5 irgn(j,i)=itnode(j,i) enddo enddo c c store crude triangulation in tail of itnode c call mktri0(ntr,nvr,nbr,vx,vy,sf,ibndry,irptr, + itnode,itedge,maxt,irgn,iflag,rl,sxy) if(iflag/=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)==0) then c c triangulate a region c call tseg(ns,nvr,ntr,maxv,vx,vy,itnode, + itedge,ipoly,irptr,rp,iflag) if(iflag/=0) go to 100 nt1=itptr(ir) call cedge2(nvr,nt1,ntr,nbr,itnode,itedge) call eswap(nt1,ntr,nvr,itnode,itedge,ipoly,vx,vy) nv1=ivptr(ir) call mfe0(nv1,nvr,nt1,ntr,itnode,itedge,vx,vy) 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/=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)=nbr ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tseg(ns,nvr,ntr,maxv,vx,vy,itnode, + itedge,ipoly,irptr,rp,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: irptr integer(kind=iknd), dimension(3,*) :: ipoly,itedge integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(100) :: rp cy 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)>0) cycle 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 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_rknd jchop=0 do i=1,num call tchop(j,kv,vx,vy,rp,ipoly) if(j/=0) then jchop=kv if(j==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==1) go to 80 c c link two non-adjacent vertices c jlink=0 kv=itnode(1,it1) rp(79)=0.0e0_rknd do i=1,num call tlink(j,kv,kk,vx,vy,ipoly,rp,itnode,itedge) if(j/=0) then klink=kk jlink=kv if(j==1) go to 90 endif kv=ipoly(1,kv) enddo c c make the best of a bad situation c if(jlink/=0) go to 90 if(jcnvx/=0) go to 80 if(jchop==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>it2) then ns=ns-1 if(ns=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)>0) cycle j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) ipoly(1,j1)=j2 len=len+1 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)>0) cycle j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) if(irgn(3,ns)>0) then ipoly(2,j1)=j2 else ipoly(2,j2)=j1 endif leno=leno+1 enddo enddo if(len/=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)<0) then m1=2 m2=1 sn=-1.0e0_rknd else m1=1 m2=2 sn=1.0e0_rknd 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>tol) go to 100 enddo c c compute new interior vertices c n1=ivptr(nso) n2=ivptr(nso+1)-1 if(n1<=n2) then if(nvr+n2-n1+1>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>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cequv(nvr,nbr,ntr,itnode,jb,ibndry,sf,iequv, + isw,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: jb,iequv integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(2,*) :: sf cy 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/=ibndry(1,ie2).and.iv/=ibndry(2,ie2)) then iv=ibndry(2,ie1) ibndry(2,ie1)=ibndry(1,ie1) ibndry(1,ie1)=iv if(ibndry(3,ie1)<0) then ss=sf(2,ie1) sf(2,ie1)=sf(1,ie1) sf(1,ie1)=ss endif endif ie2=ie1 enddo enddo c c mark periodic vertices c do i=1,nbr if(ibndry(4,i)>=0) cycle j=-ibndry(4,i) if(j=ns) go to 200 i1=jb(ns) i2=jb(ns+1)-1 j1=jb(nso) j2=jb(nso+1)-1 if(i2-i1/=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/=ibndry(1,ie2).and.iv/=ibndry(2,ie2)) + iv=ibndry(2,ie1) jv=ibndry(1,je1) if(jv/=ibndry(1,je2).and.jv/=ibndry(2,je2)) + jv=ibndry(2,je1) if(itnode(3,ns)>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==jv) go to 50 if(it/=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 enddo c c final form of iequv c if(isw==0) return do i=1,nvr if(iequv(i)<=0) cycle next=iequv(i) last=i do iequv(last)=-i if(next==i) exit last=next next=iequv(next) enddo 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sethl(nvr,nbr,ntr,maxv,maxb,vx,vy, + sf,itnode,ibndry,rp,llist,iflag,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3*nbr) :: jb integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(nvr) :: iequv integer(kind=iknd), dimension(2,llist) :: list real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(nvr) :: hloc real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(2) :: p,dp,q,dq,al,ang,theta,cen real(kind=rknd), dimension(20) :: x,y,fi cy external sxy c c compute appropriate values of hloc c itmax=nvr tol=1.0e-3_rknd iflag=0 eps=1.0e1_rknd*epsilon(1.0e0_rknd) grade=rp(16) hmax=rp(78)*rp(15) rl=rp(21) num=16 c c compute jb c call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb, + iflag,rl,sxy) if(iflag/=0) return c c initialize iequv c call cequv(nvr,nbr,ntr,itnode,jb,ibndry,sf,iequv,1_iknd,iflag) if(iflag/=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) call arclen(i,ibndry,1_iknd,sf,vx,vy,d, + theta1,theta2,radius,num,x,y,fi,rl,sxy) hloc(iequv(j1))=min(d,hloc(iequv(j1))) hloc(iequv(j2))=min(d,hloc(iequv(j2))) enddo c c compute list of edge-vertex parirs to be made consistant c ncount=0 do ns=1,ntr if(itnode(3,ns)/=0) cycle i1=jb(ns) i2=jb(ns+1)-1 ie1=jb(i1) ie2=jb(i2) lv=ibndry(1,ie1) if(lv/=ibndry(1,ie2).and.lv/=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 p(1)=(vx(iv)+vx(jv))/2.0e0_rknd p(2)=(vy(iv)+vy(jv))/2.0e0_rknd dp(1)=(vx(jv)-vx(iv))/2.0e0_rknd dp(2)=(vy(jv)-vy(iv))/2.0e0_rknd dq(1)=dp(2) dq(2)=-dp(1) kv=ist do jj=i1,i2 je1=jb(jj) if(kv==iv.or.kv==jv) go to 90 q(1)=vx(kv) q(2)=vy(kv) ii=1 if(iv/=ibndry(1,ie1)) ii=-1 call arclen(ie1,ibndry,ii,sf,vx,vy,d, + theta(1),theta(2),radius,num,x,y,fi,rl,sxy) if(ibndry(3,ie1)>0) then cen(1)=sf(1,ie1) cen(2)=sf(2,ie1) call liarc(q,dq,cen,theta,radius,npts, + al,ang,eps) if(npts/=1) go to 90 if(al(1)<=eps) go to 90 else if(ibndry(3,ie1)<0) then npts=0 do k=1,num p(1)=(x(k)+x(k+1))/2.0e0_rknd p(2)=(y(k)+y(k+1))/2.0e0_rknd dp(1)=(x(k)-x(k+1))/2.0e0_rknd dp(2)=(y(k)-y(k+1))/2.0e0_rknd call lil(p,dp,q,dq,al,jflag) if(jflag/=0) cycle if(abs(al(1))>=1.0e0_rknd+eps) cycle if(al(2)<=eps) cycle npts=npts+1 enddo if(npts==0) go to 90 else call lil(p,dp,q,dq,al,jflag) if(jflag/=0) go to 90 if(abs(al(1))>=1.0e0_rknd+eps) go to 90 if(al(2)<=eps) go to 90 endif ncount=ncount+1 if(ncount>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 enddo c c final loop where hloc values are made consistant c do itnum=1,itmax ratio=0.0e0_rknd c c check all edges c do i=1,nbr iv=ibndry(1,i) jv=ibndry(2,i) ii=1 if(hloc(iequv(iv))>hloc(iequv(jv))) then ii=-1 iv=jv jv=ibndry(1,i) endif call arclen(i,ibndry,ii,sf,vx,vy,d, + theta1,theta2,radius,num,x,y,fi,rl,sxy) r=((grade-1.0e0_rknd)*d+hloc(iequv(iv)))/grade if(rhloc(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_rknd dp(2)=(vy(jv)-vy(iv))/2.0e0_rknd dq(1)=dp(2) dq(2)=-dp(1) d=sqrt(dp(1)*dp(1)+dp(2)*dp(2)) ii=1 if(iv/=ibndry(1,ie1)) ii=-1 call arclen(ie1,ibndry,ii,sf,vx,vy,dd, + theta(1),theta(2),radius,num,x,y,fi,rl,sxy) if(ibndry(3,ie1)>0) then cen(1)=sf(1,ie1) cen(2)=sf(2,ie1) 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/=ibndry(1,ie1)) fr=1.0e0_rknd-fr else if(ibndry(3,ie1)>0) then z=0.0e0_rknd npts=0 do k=1,num p(1)=(x(k)+x(k+1))/2.0e0_rknd p(2)=(y(k)+y(k+1))/2.0e0_rknd dp(1)=(x(k)-x(k+1))/2.0e0_rknd dp(2)=(y(k)-y(k+1))/2.0e0_rknd call lil(p,dp,q,dq,al,jflag) if(jflag/=0) cycle if(abs(al(1))>=1.0e0_rknd+eps) cycle if(al(2)<=eps) cycle if(npts>=1.and.al(2)>=z) cycle npts=npts+1 z=d*al(2) fr=(fi(k)+fi(k+1) + +(fi(k+1)-fi(k))*al(1))/2.0e0_rknd enddo else p(1)=(vx(iv)+vx(jv))/2.0e0_rknd p(2)=(vy(iv)+vy(jv))/2.0e0_rknd dd=2.0e0_rknd*d call lil(p,dp,q,dq,al,jflag) z=d*abs(al(2)) fr=(al(1)+1.0e0_rknd)/2.0e0_rknd endif c c check length of edge ie1 c r=((grade-1.0e0_rknd)*dd+hloc(iequv(iv)))/grade if(r=hb) cycle c c nearer to iv c if(fr<0.25e0_rknd) then rj=((grade-1.0e0_rknd)*fr*dd+r)/grade rj=min(rj,hloc(iequv(jv))) ri=rj+(r-rj)/(1.0e0_rknd-fr) ri=max(r/grade,ri) ri=min(ri,hloc(iequv(iv))) rj=((grade-1.0e0_rknd)*dd+ri)/grade rj=min(rj,hloc(iequv(jv))) c c nearer to jv c else if(fr>0.75e0_rknd) then ri=((grade-1.0e0_rknd)*(1.0e0_rknd-fr)*dd+r)/grade ri=min(ri,hloc(iequv(iv))) rj=ri+(r-ri)/fr rj=max(r/grade,rj) rj=min(rj,hloc(iequv(jv))) ri=((grade-1.0e0_rknd)*dd+rj)/grade ri=min(ri,hloc(iequv(iv))) c c middle of interval c else ri=min(r,hloc(iequv(iv))) rj=ri+(r-ri)/fr rj=min(rj,z,hloc(iequv(jv))) endif c ratio=max(ratio,hloc(iequv(iv))/ri) hloc(iequv(iv))=min(ri,hloc(iequv(iv))) ratio=max(ratio,hloc(iequv(jv))/rj) hloc(iequv(jv))=min(rj,hloc(iequv(jv))) else c c the case where hloc at vertex kv is bigger c r=((grade-1.0e0_rknd)*z+hb)/grade r=min(r,z) if(rmaxv) then iflag=84 return endif if(nbr+np>maxb) then iflag=86 return endif c c the case of a curved edge c if(ibndry(3,i)>0) then nvsave=nvr dt=theta2-theta1 q=0.0e0_rknd do j=1,np q=q+h h=h*al arg=(theta1+q*dt)*pi nvr=nvr+1 vx(nvr)=sf(1,i)+radius*cos(arg) vy(nvr)=sf(2,i)+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) ibndry(7,nbr)=ibndry(7,i) sf(1,nbr)=sf(1,i) sf(2,nbr)=sf(2,i) enddo ibndry(2,nbr)=j2 ibndry(2,i)=nvsave+1 c c the case of a parameterized edge c else if(ibndry(3,i)<0) then c* kold=1 s1=sf(1,i) s2=sf(2,i) dt=(s2-s1)/real(num,rknd) nvsave=nvr last=i q=0.0e0_rknd itag=-ibndry(3,i) do j=1,np q=q+h h=h*al c c space uniformly in the user parameter c sm=s1+(s2-s1)*q c c space uniformly in approximate arclength c might fail to refine eqivalent edges the same. c c* do k=kold,num c* if(fi(k)<=q.and.fi(k+1)>=q) exit c* enddo c* kold=k c* sl=s1+dt*real(k-1,rknd) c* sr=sl+dt c* sm=((q-fi(k))*sl+(fi(k+1)-q)*sr)/(fi(k+1)-fi(k)) c do k=1,12 values(k)=0.0e0_rknd enddo call sxy(rl,sm,itag,values) nvr=nvr+1 vx(nvr)=values(1) vy(nvr)=values(2) 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) ibndry(7,nbr)=ibndry(7,i) sf(1,nbr)=sm sf(2,last)=sm last=nbr enddo ibndry(2,nbr)=j2 ibndry(2,i)=nvsave+1 sf(2,nbr)=s2 c c the case of a straight edge c else nvsave=nvr p1=vx(j1) p2=vy(j1) dp1=vx(j2)-p1 dp2=vy(j2)-p2 q=0.0e0_rknd 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) ibndry(7,nbr)=ibndry(7,i) sf(1,nbr)=0.0e0_rknd sf(2,nbr)=0.0e0_rknd enddo ibndry(2,nbr)=j2 ibndry(2,i)=nvsave+1 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)/=k.and.ibndry(2,j)/=k) then jj=list(j+1)-1 if(ibndry(2,jj)/=k) stop 9327 itnode(2,i)=jj endif enddo c c periodic boundary edges c do i=1,nbr0 if(ibndry(4,i)>=0) cycle k=-ibndry(4,i) ibeg=list(i) iend=list(i+1) c** kbeg=list(k) kend=list(k+1) if(ibeg>=iend) cycle do j=ibeg,iend if(j==iend) then ibndry(4,i)=-(kend-1) else if(j==iend-1) then ibndry(4,iend-1)=-k else ibndry(4,j)=-(kend-2+ibeg-j) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mktri0(ntr,nvr,nbr,vx,vy,sf,ibndry,irptr, + itnode,itedge,maxt,irgn,iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3*nbr) :: jb integer(kind=iknd), dimension(5,*) :: itnode,irgn integer(kind=iknd), dimension(*) :: irptr integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(nbr) :: list integer(kind=iknd), dimension(nvr+nbr) :: vindex integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy external sxy data index/1,2,3,2,3,1,3,1,2/ c c make a crude triangulation of the skeleton c iflag=0 c c make jb c call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb, + iflag,rl,sxy) if(iflag/=0) return c 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/=ibndry(1,ie2).and.ivc/=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) call cedgek(nvr,nt1,nt2,nb1,nb2,itnode,ibndry,itedge,jb) 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)/=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)<0) then m=-list(j) if(irgn(5,m)/=irgn(5,i)) list(j)=1 else if(list(j)==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)<=0) then jb(i)=0 else nbr=nbr+1 jb(i)=nbr do j=1,7 ibndry(j,nbr)=ibndry(j,i) enddo do j=1,2 sf(j,nbr)=sf(j,i) enddo endif enddo c do i=1,nbr if(ibndry(4,i)>=0) cycle k=-ibndry(4,i) ibndry(4,i)=-jb(k) 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<=0) cycle itedge(j,i)=-jb(k) if(jb(k)<=0) cycle m=jb(k) ibsv=ibndry(1,m) ibndry(1,m)=itnode(index(2,j),i) ibndry(2,m)=itnode(index(3,j),i) if(ibndry(3,m)<0.and.ibndry(1,m)/=ibsv) then sfsv=sf(1,m) sf(1,m)=sf(2,m) sf(2,m)=sfsv endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tswap(it1,it2,itnode,itedge) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(3) :: iadj1,iadj2 cy 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==it2) return do j=1,3 iadj1(j)=itedge(j,it1) iadj2(j)=itedge(j,it2) enddo do j=1,3 if(iadj1(j)>0) then kt=iadj1(j)/4 ke=iadj1(j)-4*kt itedge(ke,kt)=4*it2+j endif if(iadj2(j)>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tchop(ichop,kv,vx,vy,rp,ipoly) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: ipoly real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(100) :: rp cy 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/=ipoly(3,kb)/4) return c c check geometry c gg=geom(kb,kv,ka,vx,vy) currnt=min(1.0e0_rknd,gg/qual) if(currnt<=best) return ichop=1 if(currnt<1.0e0_rknd) ichop=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cchop(kv,ntr,ns,irptr,itnode,itedge,ipoly) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(*) :: irptr integer(kind=iknd), dimension(3,*) :: itedge,ipoly integer(kind=iknd), save, dimension(3,3) :: index cy 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(itit2) 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)<=0) cycle 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 enddo if(it>it1) then do j=1,3 if(itedge(j,it)>0) cycle j1=itnode(index(2,j),it) ipoly(3,j1)=4*it+j enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tcnvx(icnvx,ns,irptr,itnode,vx,vy,rp,nvr,maxv,ipoly) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: irptr integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: ipoly real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(100) :: rp cy 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>=7) return if(nvr+1>maxv) return qual=rp(76) best=rp(79) currnt=1.0e0_rknd cc if(num==7) currnt=0.9e0_rknd cc if(num==8) currnt=0.8e0_rknd cc if(currnt<=best) return c c compute centroid c kv=itnode(1,it1) x=0.0e0_rknd y=0.0e0_rknd do i=1,num x=x+vx(kv) y=y+vy(kv) kv=ipoly(1,kv) enddo nvr1=nvr+1 vx(nvr1)=x/real(num,rknd) vy(nvr1)=y/real(num,rknd) c c check geometry c do i=1,num g=geom(kv,ipoly(1,kv),nvr1,vx,vy) currnt=min(currnt,g/qual) if(currnt<=best) return kv=ipoly(1,kv) enddo if(currnt<=0.0e0_rknd) return icnvx=1 if(currnt<1.0e0_rknd) icnvx=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ccnvx(ns,nvr,ntr,maxv,vx,vy,itnode,irptr,ipoly,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: irptr integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: ipoly real(kind=rknd), dimension(*) :: vx,vy cy 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>it2) then iflag=83 return endif if(nvr+1>maxv) then iflag=84 return endif c c compute centroid c kv=itnode(1,it1) x=0.0e0_rknd y=0.0e0_rknd do i=1,num x=x+vx(kv) y=y+vy(kv) kv=ipoly(1,kv) enddo nvr=nvr+1 vx(nvr)=x/real(num,rknd) vy(nvr)=y/real(num,rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tlink(ilink,kv,kk,vx,vy,ipoly,rp,itnode,itedge) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: ipoly,itedge integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(100) :: rp cy 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_rknd/20.0e0_rknd angmax=2.0e0_rknd-angmin ilink=0 c c kk=0 currnt=0.0e0_rknd 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/=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==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=min(a1,a2,a3,a4) aamax=max(a1,a2,a3,a4) if(aaminangmax) go to 10 testkm=min(1.0e0_rknd,aamin/angmn) c if(ka==kf.or.kb==ks) testkm=testkm/2.0e0_rknd if(testkm>currnt) then c c km is the best point found so far c currnt=testkm kk=km if(currnt==1.0e0_rknd) go to 180 endif go to 10 endif if(kk==0) return if(currnt<=best) return 180 ilink=1 if(currnt<1.0e0_rknd) ilink=-1 rp(79)=currnt return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rlink(hl,hr,d,rp,xl,yl,xr,yr,vx,vy,nvr,maxv,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(*) :: vx,vy cy iflag=0 call dvpram(hl,hr,d,rp,alpha,h,np) if(np==0) return if(nvr+np>maxv) then iflag=84 return endif if(np==0) return qq=0.0e0_rknd 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clink(kv,kk,ns,nvr,maxv,ntr, + vx,vy,ipoly,irptr,itnode,itedge,rp,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3,*) :: ipoly,itedge integer(kind=iknd), dimension(*) :: irptr integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(2) :: p,dp,q,dq,al cy 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<=8) go to 60 if(d<=grade*(hv+hk)) go to 60 ds=d*(grade-1.0e0_rknd)/grade theta=(hv-hk)/(2.0e0_rknd*ds) if(abs(theta)>0.4e0_rknd) go to 60 fv=0.5e0_rknd-theta fk=0.5e0_rknd+theta hm=(ds+hv+hk)/2.0e0_rknd hmin=fv*hk+fk*hv hm=min(hm,hmax) if(hm=1.0e0_rknd) cycle al2=abs(al(2))*ds if(al2>hm*(1.0e0_rknd-al1)) cycle hh=chloc(ipoly(2,k),k,ipoly(1,k),vx,vy) z=al2+hh/grade h=hm+(ht-hm)*al1 if(h<=z) cycle hz=(z-al1*ht)/(1.0e0_rknd-al1) if(hz<=0.0e0_rknd) cycle hm=min(hm,hz) if(hm0) 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(i0) then mt=ktf/4 me=ktf-4*mt itedge(me,mt)=4*i+1 endif endif itedge(2,i)=0 if(i>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>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(i0) then mt=ktf/4 me=ktf-4*mt itedge(me,mt)=4*i+1 endif endif itedge(2,i)=0 if(i>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)<=0) cycle mt=itedge(j,icur)/4 if(mt<=last) cycle last=last+1 call tswap(last,mt,itnode,itedge) enddo icur=icur+1 if(icur<=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cedge2(nvr,nt1,nt2,nbf,itnode,itedge) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(nvr+nbf+3*(nt2-nt1+1)) :: list integer(kind=iknd), save, dimension(3,3) :: index cy 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=max(itnode(j2,i),itnode(j3,i)) imin=min(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k<=0) then c c add triangle i, edge j to list c if(iptr<=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=max(itnode(j2,ii),itnode(j3,ii)) if(imax==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eswap(nt1,nt2,nvr,itnode,itedge,ipoly,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge,ipoly integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), save, dimension(4) :: qmin0,fract0 cy data index/1,2,3,2,3,1,3,1,2/ data fract0/1.0e0_rknd, 1.0e0_rknd, 0.8e0_rknd, 0.6e0_rknd/ data qmin0 /1.0e0_rknd, 1.0e0_rknd, 0.6e0_rknd, 0.3e0_rknd/ 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)>0) cycle j1=itnode(index(2,j),i) j2=itnode(index(3,j),i) ipoly(1,j1)=j2 ipoly(2,j2)=j1 len=len+1 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_rknd-cang(kb,kv,ka,vx,vy)*3.0e0_rknd iq=max(int(q+0.5e0_rknd)-1,0_iknd) ipoly(3,kv)=min(5,iq) kv=ipoly(1,kv) enddo c*** if(kv/=j2) call drgrdx(vx,vy,len,nt1,nt2,itnode) if(kv/=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<=k) cycle 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 enddo enddo c c the main loop in which the edges are swapped c do ithrsh=4,2,-1 qmin=qmin0(ithrsh) fract=fract0(ithrsh) do itnum=1,itmax ichng=0 do i=nt1,nt2 do ied=1,3 k=itedge(ied,i)/4 if(k<=0) cycle ked=itedge(ied,i)-4*k if(knt2) 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=max(itedge(index(ied,2),i), + itedge(index(ked,3),k)) m2=max(itedge(index(ked,2),k), + itedge(index(ied,3),i)) if(min(m1,m2)<=0) cycle mtst=ipoly(3,j2)+ipoly(3,j3) + -ipoly(3,mi)-ipoly(3,mk) if(mtst0) then jed=itedge(ied,i)-4*j itedge(jed,j)=ied+4*i endif j=itedge(ked,k)/4 if(j>0) then jed=itedge(ked,k)-4*j itedge(jed,j)=ked+4*k endif enddo enddo if(ichng<=0) exit enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy, + iseed,vtype,itdof,ndf,ngf,maxd,gf,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(*) :: iseed,vtype integer(kind=iknd), dimension(3) :: ibmptr,iords,iv, + istart,istop integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(500) :: vlist,tlist,elist, + blist real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: bump,e real(kind=rknd), dimension(maxd,*) :: gf cy data index/1,2,3,2,3,1,3,1,2/ c iflag=0 call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) c c make all elements and spoke edges for vertex i the c same order c iiord=100 num=1 istart(1)=1 istop(1)=len if(vtype(i)>=7) istart(1)=2 if(vtype(i)>=9) then num=2 istart(2)=len+3 istop(2)=elist(len+2) endif do m=1,num do k=istart(m),istop(m) it=tlist(k) call locord(it,ndof,iord,iords,itdof) iiord=min(iord,iiord) enddo enddo c c make interior elements order iiord c do m=1,num do k=istart(m),istop(m) it=tlist(k) call locord(it,ndof,iord,iords,itdof) j=abs(elist(k)) iords(index(2,j))=0 iords(index(3,j))=0 call p2qdof(it,iiord,iords,ndf,ngf,maxd, + itedge,ibedge,itdof,gf,incdf,iv,iflag) enddo enddo c c reduce degree to 3 or 4 by swapping edges c if(vtype(i)>=7) go to 30 if(len<=4) return c ivf1=0 ivf2=0 do j=2,len+1 if(elist(j)<0) then if(ivf1==0) then ivf1=vlist(j) else ivf2=vlist(j) endif endif enddo c c 10 if(len>4) then jj=2 gs=-1.0e0_rknd do j=2,len+1 if(vlist(j)==ivf1.or.vlist(j)==ivf2) cycle if(vlist(j-1)==ivf1.and.vlist(j+1)==ivf2) cycle if(vlist(j+1)==ivf1.and.vlist(j-1)==ivf2) cycle qq=geom(i,vlist(j-1),vlist(j+1),vx,vy) if(qq<=0.0e0_rknd) cycle gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg<=gs) cycle jj=j gs=gg enddo if(gs<=0.0e0_rknd) then iflag=1 return endif k=index(3,abs(elist(jj))) it=tlist(jj) call eleswp(it,k,itnode,itedge,ibedge,itdof, + ngf,maxd,gf,1_iknd,ibmptr,bump,3_iknd,e,iseed, 1 vx,vy,0_iknd,1_iknd,1_iknd) 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>3) then jj=3 gs=-1.0e0_rknd do j=3,len qq=geom(i,vlist(j-1),vlist(j+1),vx,vy) if(qq<=0.0e0_rknd) cycle gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg<=gs) cycle jj=j gs=gg enddo if(gs<=0.0e0_rknd) then iflag=2 return endif k=index(3,abs(elist(jj))) it=tlist(jj) call eleswp(it,k,itnode,itedge,ibedge,itdof, + ngf,maxd,gf,1_iknd,ibmptr,bump,3_iknd,e,iseed, 1 vx,vy,0_iknd,1_iknd,1_iknd) call cirlst(i,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) go to 30 endif if(vtype(i)/=9) return 50 ks1=len+3 len1=elist(len+2) ii=vlist(len+2) if(len1+2-ks1>3) then jj=ks1+1 gs=-1.0e0_rknd do j=ks1+1,len1 qq=geom(ii,vlist(j-1),vlist(j+1),vx,vy) if(qq<=0.0e0_rknd) cycle gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy) if(gg<=gs) cycle jj=j gs=gg enddo if(gs<=0.0e0_rknd) then iflag=3 return endif k=index(3,abs(elist(jj))) it=tlist(jj) call eleswp(it,k,itnode,itedge,ibedge,itdof, + ngf,maxd,gf,1_iknd,ibmptr,bump,3_iknd,e,iseed, 1 vx,vy,0_iknd,1_iknd,1_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mfe0(nv1,nv2,nt1,nt2,itnode,itedge,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(50) :: vlist integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(nv2) :: list integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy cy data index/1,2,3,2,3,1,3,1,2/ c c this routine tries to optimize knot placement c if(nv1>nv2) return tol=1.0e-3_rknd s3=sqrt(3.0e0_rknd)/2.0e0_rknd 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>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)/=i) stop 6630 kk=itnode(ke,k) if(kk/=kv) go to 10 vlist(ideg+1)=kv c qmin=1.0e0_rknd qmin2=1.0e0_rknd k1=0 k2=0 do k=1,ideg kb=vlist(k) ka=vlist(k+1) q=geom(i,kb,ka,vx,vy) if(q0.0e0_rknd) 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*max(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(max(zx,zy)0.0e0_rknd) then d=sqrt(disc) npts=2 if(b>=0.0e0_rknd) 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==0.0e0_rknd) then npts=1 al(1)=b/a else npts=0 return endif c c compute theta values c tmin=min(t(1),t(2)) tmax=max(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=min(1.0e0_rknd,x) x=max(-1.0e0_rknd,x) th=acos(x)/pi if(y<0.0e0_rknd) th=-th do j=1,5 theta=th+real(j-3,rknd)*2.0e0_rknd if(abs(theta-tmin)<=tol) theta=tmin if(theta>=tmin) exit enddo if(abs(theta-tmax)<=tol) theta=tmax ang(i)=theta enddo if(npts==2.and.ang(2)tmax) npts=0 if(npts==2.and.ang(2)>tmax) npts=1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lil(p,dp,q,dq,al,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(2) :: p,dp,q,dq,al cy 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/=0.0e0_rknd) 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_rknd al(2)=0.0e0_rknd iflag=1 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function chloc(kb,kv,ka,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd) :: chloc cy 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_rknd return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function geom(kv,kb,ka,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd) :: geom cy 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_rknd/dd return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function ch(kv,kb,ka,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd) :: ch cy 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function cangmx(kb,kv,ka,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: h real(kind=rknd) :: cangmx real(kind=rknd), save :: pi=3.141592653589793e0_rknd cy data index/1,2,3,2,3,1,3,1,2/ 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)>h(1)) j=2 if(h(3)>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_rknd)/(2.0e0_rknd*sqrt(h(j2)*h(j3))) q=min(1.0e0_rknd,q) q=max(-1.0e0_rknd,q) cangmx=acos(q)/pi return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function cangmn(kb,kv,ka,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3) :: h real(kind=rknd) :: cangmn real(kind=rknd), save :: pi=3.141592653589793e0_rknd cy data index/1,2,3,2,3,1,3,1,2/ 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)=epsm) return hmin=min(hl,hr)/d if(hmin*grade>=epsm) return c c find np by increasing hmin as quickly as possible c q=hmin 3 np=np+1 hmin=min(hmin*grade,hmax) q=q+hmin if(q1.0e0_rknd+hmax/2.0e0_rknd) 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==0) return r=hr/hl if(abs(r-1.0e0_rknd)<1.0e-3_rknd) then h=1.0e0_rknd/real(np+1,rknd) else al=r**(1.0e0_rknd/real(np+1,rknd)) al=min(grade,al) al=max(1.0e0_rknd/grade,al) h=(al-1.0e0_rknd)/(al**(np+1)-1.0e0_rknd) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,sf, + itnode,ibndry,iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3*nbr) :: jb integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(maxv) :: iequv real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxv) :: hloc real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(17) :: x,y,fi cy external sxy 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_rknd factor=1.1e0_rknd num=16 c c make jb c call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb, + iflag,rl,sxy) if(iflag/=0) return c c initialize iequv c call cequv(nvr,nbr,ntr,itnode,jb,ibndry,sf,iequv,1_iknd,iflag) if(iflag/=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) call arclen(i,ibndry,1_iknd,sf,vx,vy,d, + theta1,theta2,radius,num,x,y,fi,rl,sxy) if(hloc(iequv(j1))<=0.0e0_rknd) then hloc(iequv(j1))=d else hloc(iequv(j1))=min(d,hloc(iequv(j1))) endif if(hloc(iequv(j2))<=0.0e0_rknd) then hloc(iequv(j2))=d else hloc(iequv(j2))=min(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 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 call arclen(i,ibndry,1_iknd,sf,vx,vy,d, + theta1,theta2,radius,num,x,y,fi,rl,sxy) c if(d<=grade*(hloc(j1)+hloc(j2))) cycle ds=d*(grade-1.0e0_rknd)/grade theta=(hloc(j1)-hloc(j2))/(2.0e0_rknd*ds) if(abs(theta)>0.4e0_rknd) cycle f1=0.5e0_rknd-theta f2=0.5e0_rknd+theta hmm=(ds+hloc(j1)+hloc(j2))/2.0e0_rknd hmin=f1*hloc(j2)+f2*hloc(j1) hmm=min(hmm,hmax) if(hmm=maxv) then iflag=84 return endif nvr=nvr+1 if(jc>0) then theta=(f1*theta2+f2*theta1)*pi vx(nvr)=sf(1,i)+radius*cos(theta) vy(nvr)=sf(2,i)+radius*sin(theta) else if(jc<0) then do m=1,num k=m if(fi(m+1)>f1) exit enddo k=max(2,k) if(abs(fi(k)-f1)>abs(fi(k+1)-f1)) k=k+1 k=min(num,k) vx(nvr)=x(k) vy(nvr)=y(k) dt=(theta2-theta1)/real(num,rknd) thetam=theta1+dt*real(k-1,rknd) else vx(nvr)=f1*vx(j2)+f2*vx(j1) vy(nvr)=f1*vy(j2)+f2*vy(j1) endif if(nbr>=maxb) then iflag=86 return endif nbr=nbr+1 iequv(i)=nbr do j=1,7 ibndry(j,nbr)=ibndry(j,i) enddo do j=1,2 sf(j,nbr)=sf(j,i) enddo if(jc<0) then sf(1,nbr)=thetam sf(2,i)=thetam endif ibndry(2,i)=nvr ibndry(1,nbr)=nvr enddo if(nbr0=0) cycle k=-ibndry(4,i) ibndry(4,k)=-i enddo endif c c fix itnode c do i=1,ntr k=itnode(1,i) j=itnode(2,i) if(ibndry(1,j)==k.or.ibndry(2,j)==k) cycle jj=iequv(j) if(ibndry(2,jj)/=k) stop 9328 itnode(2,i)=jj enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine arclen(iedge,ibndry,isw,sf,vx,vy, + alen,theta1,theta2,radius,num,x,y,fi,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(*) :: vx,vy,fi,x,y real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(12) :: values cy external sxy c c compute approximate arclength c if(isw==1) then k1=1 k2=2 else k1=2 k2=1 endif j1=ibndry(k1,iedge) j2=ibndry(k2,iedge) jc=ibndry(3,iedge) if(jc>0) then call arc(vx(j1),vy(j1),vx(j2),vy(j2), + sf(1,iedge),sf(2,iedge), 1 theta1,theta2,radius,alen) else if(jc<0) then itag=-jc theta1=sf(k1,iedge) theta2=sf(k2,iedge) x(1)=vx(j1) y(1)=vy(j1) dt=(theta2-theta1)/real(num,rknd) alen=0.0e0_rknd fi(1)=0.0e0 do k=2,num+1 do m=1,12 values(m)=0.0e0_rknd enddo theta=theta1+dt*real(k-1,rknd) call sxy(rl,theta,itag,values) x(k)=values(1) y(k)=values(2) fi(k)=sqrt((x(k)-x(k-1))**2+(y(k)-y(k-1))**2) alen=alen+fi(k) fi(k)=alen enddo do k=1,num+1 fi(k)=fi(k)/alen enddo else alen=sqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+ + (vy(j1)-vy(j2))*(vy(j1)-vy(j2))) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine makjb(nvf,nbf,ntf,vx,vy,sf,ibndry,itnode,jbsw, + jb,iflag,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(nvf+2*nbf+1) :: list integer(kind=iknd), dimension(nvf) :: ibdy integer(kind=iknd), dimension(nbf) :: orient,num integer(kind=iknd), dimension(*) :: jb integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy external sxy 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)==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)==0) cycle if(ibdy(i)/=-2) then iflag=-48 return endif enddo c c order boundary edges first c do i=1,nbf if(ibndry(4,i)==0) cycle do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo enddo do i=1,nbf if(ibndry(4,i)/=0) cycle do k=1,2 j=ibndry(k,i) list(list(j))=i list(j)=list(j)+1 enddo enddo do i=nvf,2,-1 list(i)=list(i-1) enddo list(1)=nvf+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)>=0) cycle if(left==0) then left=i else if(vx(i)0) then call arc(vx(iv),vy(iv),vx(jv),vy(jv), + sf(1,icur),sf(2,icur),thetab,thetac,rad,hh) arg=(0.95e0_rknd*thetac+0.05e0_rknd*thetab)*pi x(1)=sf(1,icur)+rad*cos(arg) y(1)=sf(2,icur)+rad*sin(arg) else if(ibndry(3,icur)<0) then itag=-ibndry(3,icur) if(iv==ibndry(1,icur)) then thetab=sf(1,icur) thetac=sf(2,icur) else thetac=sf(1,icur) thetab=sf(2,icur) endif theta=0.95e0_rknd*thetac+0.05e0_rknd*thetab do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) x(1)=values(1) y(1)=values(2) else x(1)=vx(iv) y(1)=vy(iv) endif x(2)=vx(jv) y(2)=vy(jv) if(ibndry(3,k)>0) then call arc(vx(kv),vy(kv),vx(jv),vy(jv), + sf(1,k),sf(2,k),thetaa,thetac,rad,hh) arg=(0.95e0_rknd*thetac+0.05e0_rknd*thetaa)*pi x(3)=sf(1,k)+rad*cos(arg) y(3)=sf(2,k)+rad*sin(arg) else if(ibndry(3,k)<0) then itag=-ibndry(3,k) if(kv==ibndry(1,k)) then thetaa=sf(1,k) thetac=sf(2,k) else thetac=sf(1,k) thetaa=sf(2,k) endif theta=0.95e0_rknd*thetac+0.05e0_rknd*thetaa do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) x(3)=values(1) y(3)=values(2) else x(3)=vx(kv) y(3)=vy(kv) endif aa=cang(i1,i2,i3,x,y) c c this section handles roundoff error problems at cracks c if(ibndry(4,k)/=0) then iseg=ibdy(kv) if(orient(iseg)==0) orient(iseg)=-1 if(ibndry(4,icur)/=0) then if(aa=ang) cycle ang=aa next=k enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xybox(nbf,vx,vy,sf,ibndry,vmin,vmax,diam,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry real(kind=rknd), dimension(2) :: vmin,vmax real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(12) :: values cy external sxy c c find a box containing domain c num=16 xmin=vx(ibndry(1,1)) ymin=vy(ibndry(1,1)) xmax=xmin ymax=ymin do i=1,nbf xmin=min(xmin,vx(ibndry(1,i)),vx(ibndry(2,i))) ymin=min(ymin,vy(ibndry(1,i)),vy(ibndry(2,i))) xmax=max(xmax,vx(ibndry(1,i)),vx(ibndry(2,i))) ymax=max(ymax,vy(ibndry(1,i)),vy(ibndry(2,i))) c c check for curved edges c if(ibndry(3,i)==0) cycle if(ibndry(3,i)>0) then xc=sf(1,i) yc=sf(2,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<0.0e0_rknd) then al=x1/(x1-x2) if(y1+al*(y2-y1)>0.0e0_rknd) then ymax=max(ymax,yc+rad) else ymin=min(ymin,yc-rad) endif endif if(y1*y2<0.0e0_rknd) then al=y1/(y1-y2) if(x1+al*(x2-x1)>0.0e0_rknd) then xmax=max(xmax,xc+rad) else xmin=min(xmin,xc-rad) endif endif else itag=-ibndry(3,i) theta1=sf(1,i) theta2=sf(2,i) dt=(theta2-theta1)/real(num,rknd) do k=1,num-1 do m=1,12 values(m)=0.0e0_rknd enddo theta=theta1+dt*real(k,rknd) call sxy(rl,theta,itag,values) x=values(1) y=values(2) xmin=min(x,xmin) xmax=max(x,xmax) ymin=min(y,ymin) ymax=max(y,ymax) enddo endif enddo c c compute diameter c diam=sqrt((xmax-xmin)**2+(ymax-ymin)**2) vmin(1)=xmin vmin(2)=ymin vmax(1)=xmax vmax(2)=ymax return end c***************************** file: mg3.f ***************************** c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine triplt(vx,vy,sf,itnode,ibndry,itdof,e, + ip,rp,sp,gf,qxy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(22) :: kdist integer(kind=iknd), dimension(3) :: ia integer(kind=iknd), allocatable, dimension(:,:) :: + jtnode,jbndry,jtdof,itedge,ibedge,iuvptr integer(kind=iknd), allocatable, dimension(:) :: jord real(kind=rknd), allocatable, dimension(:) :: vx0,vy0,ut,vt real(kind=rknd), allocatable, dimension(:,:) :: sf0 real(kind=rknd), dimension(*) :: vx,vy,e,gf real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t,tl real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(4096) :: red,green,blue character(len=80), dimension(100) :: sp cy external qxy,sxy 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 yt yt from t c 12 mpisw rmag 1.0e0_rknd 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 call setcom c c error flags c ip(25)=0 if(itnode(3,1)==0) then iflag=25 go to 20 endif c if(ip(5)/=0) then call stor(ip,rp) call dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy) if(ip(25)/=0) return c c setup itdof c ntf=ip(1) nvf=ip(2) nbf=ip(3) c call mkdof(ntf,nvf,nbf,ip,itnode,ibndry,itdof) maxt=ip(83) maxd=ip(85) call gfinit(ip,maxd,gf,maxt,e) endif c ntf=ip(1) nvf=ip(2) nbf=ip(3) iprob=abs(ip(6)) mxcolr=max(2,ip(51)) mxcolr=min(4096,mxcolr) icrsn=ip(68) itrgt=ip(69) mpisw=ip(48) nproc=ip(49) irgn=ip(50) if(mpisw==1) then mpirgn=ip(47) if(mpirgn/=0) then if(mpirgn/=irgn) return mpisw=-1 endif endif do i=1,ntf nproc=max(nproc,itnode(4,i)) enddo c ndf=ip(4) ngf=ip(77) maxt=ip(83) maxd=ip(85) c c initialize data structures c if(mpisw==1) then call exflag(ip(24)) if(ip(24)/=0) then iflag=24 go to 20 endif if(icrsn==1) then ia(1)=max(4*itrgt,ntf) ia(2)=max(2*itrgt,nbf) ia(3)=max(2*itrgt,nvf) else ia(1)=ntf*nproc ia(2)=nbf*nproc ia(3)=nvf*nproc endif call exsze(ia,0_iknd) lent=ia(1) lenb=ia(2) lenv=ia(3) else lent=ntf lenb=nbf lenv=nvf endif c call clenut(ntf,itdof,lenut) lenut=int(real(lenut,rknd)*(real(lent,rknd)/real(ntf,rknd))) c allocate(jtnode(5,lent),jbndry(7,lenb),jtdof(8,lent), + iuvptr(2,lent+1),itedge(3,lent),ibedge(2,lenb), 1 vx0(lenv),vy0(lenv),ut(lenut),vt(lenut),jord(lent), 2 sf0(2,lenb)) c call cpds(ntf,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf, + jtnode,jbndry,jtdof,vx0,vy0,sf0) c c compute function to be displayed c ifun=abs(ip(52)) rl=rp(21) if(iprob==7) rl=rp(46) c call gfptr(ip,iuu,iu0,iudot,iu0dot, + ievr,ievl,ivx0,ivy0,ium,iuc,iudl) ivu=iuu iv1=iuu iv2=iuu ierrsw=0 icont=0 itype=0 iee=1 if(ifun==1) then itype=1 if(ip(57)==1) icont=1 else if(ifun==2) then itype=2 if(ip(57)==1) icont=1 else if(ifun==3) then itype=3 if(ip(57)==1) icont=1 else if(ifun==4) then itype=4 if(ip(57)==1) icont=1 else if(ifun==5) then itype=5 if(ip(57)==1) icont=1 if(icont==0.and.mpisw/=1.and.icrsn/=1) ierrsw=1 else if(ifun==6) then ivu=iudot else if(ifun==7) then ivu=ievr else if(ifun==8) then ivu=ievl else if(ifun==9) then ivu=ium else if(ifun==10) then ivu=iuc else if(ifun==11) then ivu=iudl else if(ifun==12) then iee=iee+maxt itype=5 if(ip(57)==1) icont=1 if(icont==0.and.mpisw/=1.and.icrsn/=1) ierrsw=1 endif c call setfun(ntf,nvf,nbf,ndf,maxd,ngf,itype,icont,icplt, + gf(ivu),gf(iv1),gf(iv2),e(iee),vx,vy,sf,iuvptr,ut, 1 vt,jtnode,jbndry,rl,jtdof,qxy,sxy) call plinit(ip,rp,jtnode,jbndry,jtdof,itedge,ibedge,vx0,vy0, + iuvptr,ut,vt,sf0,icplt,ierrsw,e(iee),kdist,q,t,tl, 1 jp,ndf,sxy) c c if(mpisw==1) then ia(1)=jp(1) ia(2)=jp(2) ia(3)=jp(3) call exsze(ia,1_iknd) ntf=ia(1) nvf=ia(2) nbf=ia(3) iflag=0 if(ntf>lent) iflag=83 if(nvf>lenv) iflag=84 if(nbf>lenb) iflag=86 if(iflag/=0) go to 10 call glbpix(vx0,vy0,sf0,jbndry,jtnode,ia,iuvptr, + ut,vt,jp,1_iknd) if(irgn==1) then call cedge1(nvf,ntf,nbf,jtnode,jbndry,itedge, + ibedge,iflag) else iflag=0 go to 10 endif endif c c ordering c ilen=max(ntf,nbf) call torder(jp,jtnode,itedge,jord,ilen,vx0,vy0,q) 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_iknd) call title0(sp(1),0_iknd) call pframe(-4_iknd) call pframe(5_iknd) if(icplt==1) then call cplot(jp,jtnode,jbndry,itedge,jord, + vx0,vy0,iuvptr,ut,sf0,q,t,rl,sxy) else call vplot(jp,jtnode,jbndry,itedge,jord, + vx0,vy0,iuvptr,ut,vt,sf0,q,t,rl,sxy) endif c c numbers c if(jp(21)==1) call tlabel(jp,jtnode,vx0,vy0,q,t) if(jp(21)==2.or.jp(21)==8) then llen=jp(2) call vlabel(llen,jp,jtnode,itedge,jbndry, + ibedge,vx0,vy0,sf0,q,t,rl,sxy) endif if(jp(21)==9) then ndf=ip(4) call dlabel(ndf,jp,jtnode,itdof,vx0, + vy0,q,t) endif if(jp(21)>=3.and.jp(21)<=6) then call blabel(jp,jtnode,jbndry, + ibedge,vx0,vy0,sf0,q,t,rl,sxy) endif if(jp(21)==7) then call plabel(nproc,jp,jtnode,vx0,vy0,q,t) endif call pframe(-5_iknd) c c legend c call pframe(2_iknd) if(icplt==1) then call legnd4(jp,tl,kdist) else call legnd3(jp,tl) endif call pframe(-2_iknd) c c small plot c call pframe(3_iknd) jp(20)=1 if(t(12)<=1.0e0_rknd) jp(22)=0 if(icplt==1) then jp(16)=0 call cplot(jp,jtnode,jbndry,itedge,jord, + vx0,vy0,iuvptr,ut,sf0,q,tl,rl,sxy) else call vplot(jp,jtnode,jbndry,itedge,jord, + vx0,vy0,iuvptr,ut,vt,sf0,q,tl,rl,sxy) endif call legnd0(t) call pframe(-3_iknd) c call pltutl(-1_iknd,red,green,blue) iflag=0 10 deallocate(jtnode,jbndry,jtdof,iuvptr,itedge,ibedge, + vx0,vy0,ut,vt,jord,sf0) 20 if(iflag==0) then sp(11)='triplt: ok' else if(iflag==24) then write(unit=sp(11),fmt='(a12,i3,a8,i4)') + 'triplt error',iflag,': region',ip(24) else if(iflag==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' endif c ip(25)=iflag return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clenut(ntf,itdof,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords cy len=1 do i=1,ntf call locord(i,ndof,iord,iords,itdof) len=len+ndof enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine inplt(vx,vy,sf,itnode,ibndry,itdof,e,ip,rp,sp,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(22) :: kdist integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: ia integer(kind=iknd), allocatable, dimension(:,:) :: + jtnode,jbndry,jtdof,itedge,ibedge integer(kind=iknd), allocatable, dimension(:) :: jt,iclr real(kind=rknd), allocatable, dimension(:) :: vx0,vy0 real(kind=rknd), allocatable, dimension(:,:) :: sf0 real(kind=rknd), dimension(*) :: vx,vy,e real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(2) :: ut,vt real(kind=rknd), dimension(25) :: t,tl real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(4096) :: red,green,blue character(len=80), dimension(100) :: sp cy external sxy c c draw input data c ntf=ip(1) nvf=ip(2) nbf=ip(3) inplsw=ip(53) maxt=ip(83) icrsn=ip(68) itrgt=ip(69) mpisw=ip(48) nproc=ip(49) irgn=ip(50) if(mpisw==1) then mpirgn=ip(47) if(mpirgn/=0) then if(mpirgn/=irgn) return mpisw=-1 endif endif do i=1,ntf nproc=max(nproc,itnode(4,i)) enddo rl=rp(21) c ip(25)=0 c c initialize c if(itnode(3,1)==0) then if(mpisw==1.and.irgn/=1) return if(inplsw==1) then iclrsw=1 else if(inplsw==2) then iclrsw=2 else iclrsw=0 endif c nvv=nvf+3*nbf ntt=2*nvv c allocate(jtnode(5,ntt),jbndry(7,nbf),jtdof(8,1), + itedge(3,ntt),ibedge(2,nbf),iclr(ntt),jt(ntf+1), 1 vx0(nvf),vy0(nvf),sf0(2,nbf)) c call cpds(1_iknd,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf, + jtnode,jbndry,jtdof,vx0,vy0,sf0) c call mktris(nbf,nvv,ip,rp,vx0,vy0,jbndry,itnode, + sf0,jt,jtnode,itedge,ntt,iclrsw,sxy) call cedge3(nvf,ntt,nbf,jtnode,jbndry,ibedge,iflag) call binits(ip,rp,vx,vy,sf,jtnode,jbndry, + t,tl,q,jp,iclr,ntt,sxy) else if(mpisw==1) then if(icrsn==1) then ia(1)=max(4*itrgt,ntf) ia(2)=max(2*itrgt,nbf) ia(3)=max(2*itrgt,nvf) else ia(1)=ntf*nproc ia(2)=nbf*nproc ia(3)=nvf*nproc endif call exsze(ia,0_iknd) lent=ia(1) lenb=ia(2) lenv=ia(3) else lent=ntf lenb=nbf lenv=nvf endif c allocate(jtnode(5,lent),jbndry(7,lenb),jtdof(8,lent), + itedge(3,lent),ibedge(2,lenb),iclr(lent),jt(2), 1 vx0(lenv),vy0(lenv),sf0(2,lenb)) c call cpds(ntf,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf, + jtnode,jbndry,jtdof,vx0,vy0,sf0) c call binitt(lent,ip,rp,jtnode,itedge,jbndry,ibedge,jtdof, + vx0,vy0,sf0,maxt,e,iclr,kdist,t,tl,q,jp,sxy) endif c if(mpisw==1.and.itnode(3,1)/=0) then ia(1)=jp(1) ia(2)=jp(2) ia(3)=jp(3) call exsze(ia,1_iknd) ntf=ia(1) nvf=ia(2) nbf=ia(3) iflag=0 if(ntf>lent) iflag=83 if(nvf>lenv) iflag=84 if(nbf>lenb) iflag=86 if(iflag/=0) go to 10 call glbpix(vx0,vy0,sf0,jbndry,jtnode,iclr,ia, + ut,vt,jp,0_iknd) if(irgn==1) then call cedge1(nvf,ntf,nbf,jtnode,jbndry,itedge, + ibedge,iflag) else iflag=0 go to 10 endif endif c call clrmap(red,green,blue,jp) call pltutl(jp(18),red,green,blue) c c main plot c call pframe(4_iknd) call title0(sp(2),0_iknd) call pframe(-4_iknd) call pframe(5_iknd) call tplot(vx0,vy0,jbndry,jtnode,sf0,t,jp, + itedge,iclr,rl,sxy) if(itnode(3,1)==0) then if(jp(21)==1) call rlabel(jp,jtnode,jt,vx,vy,q,t) if(jp(21)==2) then llen=jp(2) call vlabel(llen,jp,jtnode,itedge,jbndry, + ibedge,vx0,vy0,sf0,q,t,rl,sxy) endif if(jp(21)>=3) call blabel(jp,jtnode,jbndry, + ibedge,vx0,vy0,sf0,q,t,rl,sxy) else if(jp(21)==1) call tlabel(jp,jtnode,vx0,vy0,q,t) if(jp(21)==2.or.jp(21)==8) then llen=jp(2) call vlabel(llen,jp,jtnode,itedge,jbndry, + ibedge,vx0,vy0,sf0,q,t,rl,sxy) endif if(jp(21)==9) then ndf=ip(4) call dlabel(ndf,jp,jtnode,itdof,vx0,vy0,q,t) endif if(jp(21)>=3.and.jp(21)<=6) call blabel(jp,jtnode, + jbndry,ibedge,vx0,vy0,sf0,q,t,rl,sxy) if(jp(21)==7) call plabel(nproc,jp,jtnode,vx0,vy0,q,t) endif call pframe(-5_iknd) c c legend c call pframe(2_iknd) if(jp(9)<=0) then call legnd1(jp) else if(jp(9)==8) then call legnd5(jp,kdist) else if(jp(9)==1) then call legnd1(jp) else if(jp(9)>=5.and.jp(9)<=7) then call legnd4(jp,tl,kdist) else call legnd2(jp,tl) endif call pframe(-2_iknd) c c small plot c call pframe(3_iknd) jp(20)=1 call tplot(vx0,vy0,jbndry,jtnode,sf0,tl,jp, + itedge,iclr,rl,sxy) call legnd0(t) call pframe(-3_iknd) c call pltutl(-1_iknd,red,green,blue) iflag=0 10 deallocate(jtnode,jbndry,jtdof,itedge,ibedge,iclr, + vx0,vy0,sf0,jt) if(iflag==0) then sp(11)='inplt: ok' else if(iflag==20) then write(unit=sp(11),fmt='(a11,i3,a22)') + 'inplt error',iflag,': insufficient storage' else if(iflag==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine setfun(ntf,nvf,nbf,ndf,maxd,ngf,itype,icont,icplt, + u,v1,v2,e,vx,vy,sf,iuvptr,ut,vt,itnode,ibndry,rl,itdof, 1 qxy,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3,ntf) :: icurv integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,nbf) :: ibedge integer(kind=iknd), dimension(2,*) :: iuvptr integer(kind=iknd), dimension(3) :: iords real(kind=rknd), dimension(*) :: vx,vy,u,v1,v2,ut,vt,e real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(ndf) :: gm real(kind=rknd), dimension(ndf,2) :: ua real(kind=rknd), dimension(4,100) :: qv real(kind=rknd), dimension(100) :: gv,gx,gy,xp,yp real(kind=rknd), dimension(3) :: tx,ty,x,y,xn,yn real(kind=rknd), dimension(3,100) :: c cy external qxy,sxy c c iuvptr(1,1)=1 do i=1,ntf call locord(i,ndof,iord,iords,itdof) iuvptr(1,i+1)=iuvptr(1,i)+ndof iuvptr(2,i)=itdof(8,i) do j=iuvptr(1,i),iuvptr(1,i+1)-1 ut(j)=0.0e0_rknd vt(j)=0.0e0_rknd enddo enddo c c scalar function c if(itype<1.or.itype>6) then icplt=1 do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=u(idof(j)) enddo enddo c c scalar function, plot grad u c else if(itype==1.or.itype==2) then icplt=0 if(itype==1) icplt=1 call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,iflag) call ccurv(ntf,nbf,ibndry,ibedge,icurv) do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) call cnode0(c,iord,iords) call afmap(i,itnode,vx,vy,tx,ty,x,y,det) call cnode2(i,itnode,ibndry,itdof,icurv,vx,vy, + sf,xp,yp,isw,sxy) js=iuvptr(1,i)-1 do j=1,ndof call beval(c(1,j),x,y,gv,gx,gy,iord,iords) c c isoparamtric map for elements with curved edges c if(isw/=0) then p11=0.0e0_rknd p12=0.0e0_rknd p21=0.0e0_rknd p22=0.0e0_rknd 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,iords) endif ux=0.0e0_rknd uy=0.0e0_rknd do k=1,ndof ux=ux+u(idof(k))*gx(k) uy=uy+u(idof(k))*gy(k) enddo if(itype==2) then ut(js+j)=ux vt(js+j)=uy else ut(js+j)=sqrt(ux**2+uy**2) endif enddo enddo c c user function qxy c else if(itype==3.or.itype==4) then icplt=0 if(itype==3) icplt=1 do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) call cnode0(c,iord,iords) call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl, + ndof,qv,c,itdof,qxy) js=iuvptr(1,i)-1 if(itype==3) then do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=qv(1,j) enddo else do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=qv(2,j) vt(js+j)=qv(3,j) enddo endif enddo c c piecewise constant function defined on elements c else if(itype==5) then icplt=1 do i=1,ntf js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=e(i) enddo enddo c c vector function c else if(itype==6) then icplt=0 do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=v1(idof(j)) vt(js+j)=v2(idof(j)) enddo enddo endif c c average discontinuous function c if(icont==0) return if(icplt==1) then do i=1,ndf ua(i,1)=0.0e0_rknd gm(i)=0.0e0_rknd enddo do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,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)))) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) gm(idof(j))=gm(idof(j))+area ua(idof(j),1)=ua(idof(j),1)+area*ut(js+j) enddo enddo do i=1,ndf ua(i,1)=ua(i,1)/gm(i) enddo do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=ua(idof(j),1) enddo enddo else do i=1,ndf ua(i,1)=0.0e0_rknd ua(i,2)=0.0e0_rknd gm(i)=0.0e0_rknd enddo do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,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)))) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) gm(idof(j))=gm(idof(j))+area ua(idof(j),1)=ua(idof(j),1)+area*ut(js+j) ua(idof(j),2)=ua(idof(j),2)+area*vt(js+j) enddo enddo do i=1,ndf ua(i,1)=ua(i,1)/gm(i) ua(i,2)=ua(i,2)/gm(i) enddo do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ut(js+j)=ua(idof(j),1) vt(js+j)=ua(idof(j),2) enddo enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine fqual(itri,iedge,icplt,iuvptr,ut,vt,umax,vmax,qual) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: iuvptr real(kind=rknd), dimension(*) :: ut,vt cy data index/1,2,3,2,3,1,3,1,2/ c c test geometry c qual=0.0e0_rknd if(iedge==0) return ss=0.1e0_rknd ii=iuvptr(1,itri)-1 u2=ut(ii+index(2,iedge)) u3=ut(ii+index(3,iedge)) qual=abs(u2-u3)/(abs(u2)+abs(u3)+ss*umax) if(icplt/=1) then v2=vt(ii+index(2,iedge)) v3=vt(ii+index(3,iedge)) qual=abs(v2-v3)/(abs(v2)+abs(v3)+ss*vmax)+qual endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine crsn1(mlen,ntf,nvf,nbf,ndf,ndtrgt,icplt,itnode, + ibndry,itdof,vx,vy,sf,rl,iuvptr,ut,vt,maxua,va,itedge, 1 ibedge,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge,iuvptr integer(kind=iknd), dimension(mlen) :: vtype,iseed, + p,q,mark,list integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(500) :: elist,tlist,vlist, + blist,elist0,tlist0,vlist0,blist0 integer(kind=iknd), dimension(3) :: ibmptr,iords,iv real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxua,*) :: va real(kind=rknd), dimension(*) :: vx,vy,ut,vt real(kind=rknd), dimension(3) :: bump,e real(kind=rknd), dimension(mlen) :: qual cy external sxy c c check to see if we have solved problem on current finest grid c call crsn2(ntf,nvf,ndf,ndtrgt,icplt,itdof,iuvptr,ut,vt) if(ndf<=ndtrgt) return angmin=1.0e-3_rknd arcmax=0.26e0_rknd c umax=0.0e0_rknd vmax=0.0e0_rknd if(icplt==1) then nga=1 do i=1,iuvptr(1,ntf+1)-1 umax=max(umax,abs(ut(i))) enddo else nga=2 do i=1,iuvptr(1,ntf+1)-1 umax=max(umax,abs(ut(i))) vmax=max(vmax,abs(vt(i))) enddo endif c c initialize iseed, vtype c call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) c call cedge5(nbf,itedge,ibedge,1_iknd) qmax=0.0e0_rknd do i=1,ntf call rmtst(i,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,1_iknd) call fqual(i,iedge,icplt,iuvptr,ut,vt,umax,vmax,qual(i)) qmax=max(qmax,qual(i)) enddo qmax=100.0e0_rknd*qmax do i=1,ntf mark(i)=0 p(i)=i q(i)=i call rmtst(i,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,1_iknd) if(iedge==0) then qual(i)=-qmax else qual(i)=-qual(i) endif enddo c c initialize heap c nn=ntf/2 do k=nn,1,-1 call updhp(k,nvf,p,q,qual,0_iknd) enddo last=ntf c c main elimination loop c last=ntf ndf0=maxua c c main elimination loop c do nn=ntf,1,-1 i=p(1) if(qual(i)<=-qmax) exit p(1)=p(last) p(last)=i q(p(last))=last q(p(1))=1 last=last-1 call updhp(1_iknd,last,p,q,qual,0_iknd) c call locord(i,ndof,iord,iords,itdof) if(ndf0-iord**2/2<=ndtrgt) exit call rmtst(i,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,1_iknd) if(iedge==0) stop 4144 call rmknot(iedge,i,iv,itnode,itedge,ibndry, + ibedge,itdof,vx,vy,sf,1_iknd,nga,maxua,va,ibmptr, 1 bump,1_iknd,e,iseed,vtype,incdf,-1_iknd,rl,sxy) ndf0=ndf0+incdf jtri=iv(3) if(jtri>0) then kk=q(jtri) if(kk==last) then last=last-1 else p(kk)=p(last) p(last)=jtri q(p(last))=last q(p(kk))=kk last=last-1 call updhp(kk,last,p,q,qual,1_iknd) endif endif c c update vertices in connected to i c llen=0 do m=1,2 if(iv(m)==0) cycle c call cirlst(iv(m),itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) call tstvty(iv(m),itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist,tlist,elist, 1 len,sxy) do jj=1,len j=vlist(jj) if(j==0) cycle call cirlst(j,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist0,tlist0,elist0,blist0,len0) call tstvty(j,itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist0,tlist0, 1 elist0,len0,sxy) js=1 if(vtype(j)>=7) js=2 do kk=js,len0 k=tlist0(kk) if(mark(k)/=nn) then llen=llen+1 list(llen)=k mark(k)=nn endif enddo enddo enddo do m=1,llen j=list(m) call rmtst(j,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,1_iknd) if(iedge>0) then call fqual(j,iedge,icplt,iuvptr,ut,vt,umax,vmax,qq) qual(j)=-qq else qual(j)=-qmax endif kk=q(j) call updhp(kk,last,p,q,qual,1_iknd) enddo enddo call clnup1(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge, + vx,vy,sf,maxua,va,icplt,iseed,itdof) c c improve geometry c call eswapa(ntf,nvf,nbf,nga,1_iknd,itnode,itedge,ibndry,ibedge, + vx,vy,ibmptr,bump,1_iknd,e,0_iknd,1_iknd,itdof,maxua,va) call cedge5(nbf,itedge,ibedge,0_iknd) c if(icplt==1) then do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,ndof ut(js+j)=va(idof(j),1) enddo enddo else do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,ndof ut(js+j)=va(idof(j),1) vt(js+j)=va(idof(j),2) enddo enddo endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine crsn2(ntf,nvf,ndf,ndtrgt,icplt,itdof,iuvptr,ut,vt) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(2,*) :: iuvptr integer(kind=iknd), dimension(ntf) :: torder integer(kind=iknd), dimension(10) :: iptr integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(3) :: iords,jords real(kind=rknd), dimension(*) :: ut,vt real(kind=rknd), dimension(100) :: gq cy external sxy c c reduce dimension by reducing degree of approximation c c order elements by degree c mxord=9 do i=1,mxord+1 iptr(i)=0 enddo do itri=1,ntf call locord(itri,ndof,iord,iords,itdof) iptr(iord+1)=iptr(iord+1)+1 enddo iptr(1)=1 do i=2,mxord+1 iptr(i)=iptr(i)+iptr(i-1) enddo do itri=1,ntf call locord(itri,ndof,iord,iords,itdof) torder(iptr(iord))=itri iptr(iord)=iptr(iord)+1 enddo do i=mxord,2,-1 iptr(i)=iptr(i-1) enddo iptr(1)=1 c c reduce degrees c ndf1=iuvptr(1,ntf+1)-1 do mord=mxord,2,-1 do ii=ntf,iptr(mord),-1 itri=torder(ii) call locord(itri,ndof,iord,iords,itdof) jord=iord-1 do j=1,3 jords(j)=jord enddo jdof=((jord+1)*(jord+2))/2 kk=iuvptr(1,itri) call p2q2d(ut(kk),gq,iord,jord,iords,jords) do j=1,jdof ut(kk+j-1)=gq(j) enddo if(icplt/=1) then call p2q2d(vt(kk),gq,iord,jord,iords,jords) do j=1,jdof vt(kk+j-1)=gq(j) enddo endif ndf1=ndf1-(ndof-jdof) iuvptr(2,itri)=jord*(1+16+16**2+16**3) itdof(8,itri)=iuvptr(2,itri) enddo if(ndf10) 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)>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)/=0) then nbnew=nbnew+1 mark(i)=nbnew do j=1,7 ibndry(j,nbnew)=ibndry(j,i) enddo do j=1,2 ibedge(j,nbnew)=ibedge(j,i) sf(j,nbnew)=sf(j,i) enddo k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew)>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)>=0) cycle k=-ibndry(4,i) ibndry(4,i)=-mark(k) 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)/=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 call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof mark(idof(j))=1 enddo enddo ndnew=0 do i=1,ndf if(mark(i)==0) cycle ndnew=ndnew+1 mark(i)=ndnew va(ndnew,1)=va(i,1) if(icplt/=1) va(ndnew,2)=va(i,2) enddo ndf=ndnew do i=1,ntf call l2gmap(i,idof,ndof,iord,iords,itdof) do j=1,ndof idof(j)=mark(idof(j)) enddo call g2lmap(i,idof,itdof) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cvz(ntf,ndf,icplt,vx,vy,iuvptr,ut,vt, + itnode,itdof,maxua,va) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(2,*) :: iuvptr real(kind=rknd), dimension(*) :: vx,vy,ut,vt real(kind=rknd), dimension(ndf) :: gm real(kind=rknd), dimension(maxua,*) :: va cy if(icplt==1) then do i=1,ndf va(i,1)=0.0e0_rknd gm(i)=0.0e0_rknd 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,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ivj=idof(j) gm(ivj)=gm(ivj)+area va(ivj,1)=va(ivj,1)+area*ut(js+j) enddo enddo do i=1,ndf va(i,1)=va(i,1)/gm(i) enddo else do i=1,ndf va(i,1)=0.0e0_rknd va(i,2)=0.0e0_rknd gm(i)=0.0e0_rknd 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,iord,iords,itdof) js=iuvptr(1,i)-1 do j=1,iuvptr(1,i+1)-iuvptr(1,i) ivj=idof(j) gm(ivj)=gm(ivj)+area va(ivj,1)=va(ivj,1)+area*ut(js+j) va(ivj,2)=va(ivj,2)+area*vt(js+j) enddo enddo do i=1,ndf va(i,1)=va(i,1)/gm(i) va(i,2)=va(i,2)/gm(i) enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cpds(ntf,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf, + jtnode,jbndry,jtdof,vx0,vy0,sf0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode,jtnode integer(kind=iknd), dimension(7,*) :: ibndry,jbndry integer(kind=iknd), dimension(8,*) :: itdof,jtdof real(kind=rknd), dimension(*) :: vx,vy,vx0,vy0 real(kind=rknd), dimension(2,*) :: sf,sf0 cy c copy data structures c do i=1,ntf do j=1,5 jtnode(j,i)=itnode(j,i) enddo do j=1,8 jtdof(j,i)=itdof(j,i) enddo enddo do i=1,nbf do j=1,7 jbndry(j,i)=ibndry(j,i) enddo do j=1,2 sf0(j,i)=sf(j,i) enddo enddo do i=1,nvf vx0(i)=vx(i) vy0(i)=vy(i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cplot(jp,itnode,ibndry,itedge,order, + vx,vy,iuvptr,ut,sf,q,t,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3072) :: ibdy integer(kind=iknd), dimension(*) :: order integer(kind=iknd) :: ccolor integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: iuvptr real(kind=rknd), dimension(*) :: vx,vy,ut real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(9) :: x,y,z,f,x0,y0,z0,f0 real(kind=rknd), dimension(3) :: bx,by,bz,bf,xt,yt,zt real(kind=rknd), dimension(3072) :: xp,yp,up,vp cy external sxy 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_rknd xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) if(i3d==0) then zratio=0.0e0_rknd else zratio=t(4) endif eps=t(7) smin=t(19) smax=t(20) zmin=fscale(smin,iscale,0_iknd) zmax=fscale(smax,iscale,0_iknd) smin=smin-abs(smin)*eps smax=smax+abs(smax)*eps if(zmax>zmin) then zscale=(1.0e0_rknd-eps)*real(ncolor,rknd)/(zmax-zmin) else zscale=0.0e0_rknd endif c c shading (reset (dxx,dyy,dzz) for a different light source) c if(nshade>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,sf,q,i3d,1_iknd,iuvptr,ut,ut,rl,sxy) 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_iknd)-zmin)*zscale bf(mm)=max(bf(mm),-1.0e0_rknd) bf(mm)=min(bf(mm),real(ncolor+1,rknd)) 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>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<0.0e0_rknd) then ishade=-nshade else aa=min(1.0e0_rknd,abs(aa)) aa=(1.0e0_rknd-4.0e0_rknd*acos(aa)/pi)* + real(nshade+1,rknd) ishade=min(int(abs(aa)),nshade) if(aa<0.0e0_rknd) ishade=-ishade endif endif c c order function values c kmin=1 if(bf(kmin)>bf(2)) kmin=2 if(bf(kmin)>bf(3)) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(bf(kmid)>bf(kmax)) kmid=kmax kmax=6-kmin-kmid c c find min and max color values for this triangle c mnc=int(bf(kmin))+1 mxc=int(bf(kmax))+1 if(bf(kmax)==real(mxc-1,rknd)) mxc=max(mxc-1,mnc) c do mm=mnc,mxc 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_rknd 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)-real(j,rknd))*cc if(sm>=0.0e0_rknd) 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==1) k=len0 kaft=m+1 if(m==len0) kaft=1 do kba=1,2 sk=(f0(k)-real(j,rknd))*cc if(sk>0.0e0_rknd) then len=len+1 s=sk/(sk-sm) x(len)=x0(m)*s + +x0(k)*(1.0e0_rknd-s) y(len)=y0(m)*s + +y0(k)*(1.0e0_rknd-s) z(len)=z0(m)*s + +z0(k)*(1.0e0_rknd-s) f(len)=f0(m)*s + +f0(k)*(1.0e0_rknd-s) endif k=kaft enddo endif enddo enddo if(len>2) then mc=ccolor(mm,ishade,jp) call pwindw(x,y,z,len,t,mc) endif enddo c c contour lines c if(lines/=3) go to 10 if(bf(kmin)>=bf(kmax)) go to 10 mnc=int(bf(kmin))+1 if(bf(kmin)>real(mnc-1,rknd)) mnc=mnc+1 mxc=min(ncolor,int(bf(kmax)))+1 c c move boundary edges slightly into the interior... c do m=mnc,mxc s=(bf(kmax)-real(m-1,rknd))/(bf(kmax)-bf(kmin)) s=max(0.02e0_rknd,s) s=min(0.98e0_rknd,s) x(1)=bx(kmin)*s+bx(kmax)*(1.0e0_rknd-s) y(1)=by(kmin)*s+by(kmax)*(1.0e0_rknd-s) z(1)=bz(kmin)*s+bz(kmax)*(1.0e0_rknd-s) if(bf(kmid)>max(bf(kmin),real(m-1,rknd)))then s=(bf(kmid)-real(m-1,rknd))/(bf(kmid)-bf(kmin)) s=max(0.02e0_rknd,s) s=min(0.98e0_rknd,s) x(2)=bx(kmin)*s+bx(kmid)*(1.0e0_rknd-s) y(2)=by(kmin)*s+by(kmid)*(1.0e0_rknd-s) z(2)=bz(kmin)*s+bz(kmid)*(1.0e0_rknd-s) else if(bf(kmid)=0) then isw=1 else if(k==1) then isw=1 else if(k>1) then if(lines==1) then if(k==2.or.k==5) isw=1 else if(lines==2) then if(k==3.or.k==5) isw=1 endif endif if(isw==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_iknd,t,2_iknd) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine vplot(jp,itnode,ibndry,itedge,order, + vx,vy,iuvptr,ut,vt,sf,q,t,rll,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: iuvptr integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(3072) :: ibdy integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: order integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy,ut,vt real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(10) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3) :: z1,z2,rl real(kind=rknd), dimension(8) :: bu,bv,bx,by,bz real(kind=rknd), dimension(3,8) :: b real(kind=rknd), dimension(3072) :: xp,yp,up,vp cy external sxy 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==0) then zratio=0.0e0_rknd 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_iknd) zmax=fscale(rmax,iscale,0_iknd) c pi=3.141592653589793e0_rknd pi2=2.0e0_rknd*pi if(nshade>0.and.zmin/=zmax) then zscale=(1.0e0_rknd-eps)*real(2*nshade+1,rknd)/(zmax-zmin) else zscale=0.0e0_rknd endif zs=(zmax-zmin)/real(2*nshade+1,rknd) if(ncolor>0) then nr=max(64/ncolor,1) nnr=ncolor*nr dtheta=pi2/real(nnr,rknd) else dtheta=2.0e0_rknd*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,sf,q,i3d,0_iknd,iuvptr,ut,vt,rll,sxy) 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 call trnk(irank,z1,z2,rmax,eps) c call gbx(z1,z2,gmin,gmax,tmin,tmax,eps,irank) irmin=int((fscale(gmin,iscale,0_iknd)-zmin)*zscale)+1 irmax=int((fscale(gmax,iscale,0_iknd)-zmin)*zscale)+1 itmin=int(tmin/dtheta)+1 itmax=int(tmax/dtheta)+1 if(irank==1.or.irmax-irmin+itmax-itmin==0) then jrank=1 else jrank=0 irmin=max(1,irmin) irmax=min(2*nshade+1,irmax) if(irmin>irmax) go to 20 itmin=max(1,itmin-1) itmax=itmax+1 endif c do ir=irmin,irmax do it=itmin,itmax c c compute color index c icolor=it-1 if(icolor>=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==1) then do j=1,3 msides=3 do k=1,3 b(k,j)=0.0e0_rknd enddo b(j,j)=1.0e0_rknd enddo else c c set up box c t1=real(it-1,rknd)*dtheta t2=real(it,rknd)*dtheta c1=cos(t1) c2=cos(t2) s1=sin(t1) s2=sin(t2) rr1=zmin+real(ir-1,rknd)*zs r1=fscale(rr1,iscale,1_iknd) r1=max(r1,gmin*0.99e0_rknd) rr2=zmin+real(ir,rknd)*zs r2=fscale(rr2,iscale,1_iknd) r2=min(r2,gmax*1.05e0_rknd) 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==3) then call tribx3(b,msides,bu,bv,z1,z2) else call tribx2(b,msides,bu,bv,z1,z2) endif endif if(msides<=2) cycle 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) enddo 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==-1) then isw=1 else if(lines==0.and.k>=0) then isw=1 else if(k==1) then isw=1 else if(k>1) then if(lines==1) then if(k==2.or.k==5) isw=1 else if(lines==2) then if(k==3.or.k==5) isw=1 endif endif if(isw==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_iknd,t,2_iknd) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine torder(jp,itnode,itedge,order,ilen,vx,vy,q) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(*) :: order integer(kind=iknd), dimension(ilen) :: nblock integer(kind=iknd), dimension(4*ilen+1) :: list integer(kind=iknd) :: tblock real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3,3) :: q cy c c color surface plot c eps=1.0e1_rknd*epsilon(1.0e0_rknd) eps1=max(1.0e-4_rknd,eps*8.0e0_rknd) iordsw=jp(8) ntf=jp(1) c do i=1,ntf order(i)=i enddo if(iordsw==1) return if(ntf<=1) return c c find boundary interference list c call bblock(ntf,itnode,itedge,ilen,list,vx,vy,q,eps) 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>i) then it=tblock(itnode,i,iside,vx,vy,q,eps1) if(it==1) nblock(i)=nblock(i)+1 if(it==-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)==0) then order(mpt)=i nblock(i)=-mpt mpt=mpt+1 endif enddo if(mpt>ntf) go to 20 c do m=1,ntf if(m>=mpt) stop 1123 i=order(m) c c update nblock c if(list(i)ntf) go to 20 endif enddo endif c do iside =1,3 j=itedge(iside,i)/4 if(j<=0) cycle if(nblock(j)<0) cycle it=tblock(itnode,i,iside,vx,vy,q,eps1) if(it/=-1) cycle nblock(j)=nblock(j)-1 if(nblock(j)==0) then order(mpt)=j nblock(j)=-mpt mpt=mpt+1 if(mpt>ntf) go to 20 endif enddo enddo 20 if(jp(1)>=ntf) return mpt=0 newntf=jp(1) do i=1,ntf if(order(i)>newntf) cycle mpt=mpt+1 order(mpt)=order(i) enddo if(mpt/=newntf) stop 2255 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine plinit(ip,rp,itnode,ibndry,itdof,itedge,ibedge,vx,vy, + iuvptr,ut,vt,sf,icplt,ierrsw,e,kdist,q,t,tl,jp,maxua,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge,iuvptr integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(*) :: kdist integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy,ut,vt,e real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t,tl real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(5) :: bmin,bmax real(kind=rknd), dimension(maxua,2) :: ua cy external sxy c c check control parameters in ip c mpisw=ip(48) nproc=ip(49) irgn=ip(50) if(mpisw==1) then mpirgn=ip(47) if(mpirgn/=0.and.mpirgn==irgn) mpisw=-1 endif 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(3) ndf=ip(4) icrsn=ip(68) itrgt=ip(69) do i=1,ntf nproc=max(nproc,itnode(4,i)) enddo rl=rp(21) c c if(mpisw==1) then call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,iflag) call cedge5(nbf,itedge,ibedge,1_iknd) len=nvf call cutr1(len,ntf,nvf,nbf,irgn,itnode,itdof,ibndry, + vx,vy,sf,bmin,iuvptr,ut,vt,ibedge,1_iknd) else if(icrsn==1) then newnbf=0 do i=1,nbf if(ibndry(4,i)==0) cycle newnbf=newnbf+1 do j=1,7 ibndry(j,newnbf)=ibndry(j,i) enddo ibndry(4,newnbf)=1 ibndry(5,newnbf)=0 ibndry(6,newnbf)=0 enddo nbf=newnbf endif call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) c c coarsen the mesh c if(icrsn==1) then if(mpisw==1) then ndtrgt=max(3,itrgt/nproc) else ndtrgt=max(3,itrgt) endif c call cvz(ntf,ndf,icplt,vx,vy,iuvptr,ut,vt, + itnode,itdof,maxua,ua) c llen=max0(ntf,ndf) call crsn1(llen,ntf,nvf,nbf,ndf,ndtrgt,icplt,itnode, + ibndry,itdof,vx,vy,sf,rl,iuvptr,ut,vt,maxua,ua, 1 itedge,ibedge,sxy) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) endif c iscale=ip(58) if(iscale<0.or.iscale>2) iscale=0 lines=ip(59) if(lines<-1.or.lines>3) lines=0 if(icrsn==1.and.lines==0) lines=1 numbrs=ip(60) if(numbrs<0.or.numbrs>9) numbrs=0 if(mpisw==1.and.numbrs/=7) numbrs=0 if(icrsn==1.and.numbrs/=7 ) numbrs=0 nx=ip(61) ny=ip(62) nz=ip(63) mxcolr=max(2,ip(51)) mxcolr=min(4096,mxcolr) ncolor=max(1,ip(56)) i3d=1 if(numbrs/=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_rknd enddo q(i,i)=1.0e0_rknd enddo zratio=1.0e0_rknd call pbox(ntf,itnode,ibndry,itedge,vx,vy,icplt, + iuvptr,ut,vt,sf,q,zratio,bmin,bmax,rp,rl,sxy) c if(mpisw==1) call exbox(bmin,bmax,3_iknd) c if(rp(9)<=rp(8)) then t(19)=bmin(3) t(20)=bmax(3) else t(19)=rp(8) t(20)=rp(9) endif if(bmax(3)>bmin(3)) then t(4)=max(bmax(1)-bmin(1),bmax(2)-bmin(2))/ + max(t(20)-t(19),bmax(3)-bmin(3)) else t(4)=0.0e0_rknd endif if(min(bmin(3),t(19))<=0.0e0_rknd.and.iscale==1) iscale=2 jp(19)=iscale c c if(t(4)==0.0e0_rknd) i3d=0 if(i3d==0) then zratio=0.0e0_rknd else zratio=t(4) endif jp(22)=i3d iordsw=0 if(i3d==0) iordsw=1 if(nx==0.and.ny==0) iordsw=1 jp(8)=iordsw c if(mxcolr==2.or.ncolor==0) then maplen=2 nshade=0 else if(ncolor>=mxcolr-2) then nshade=0 maplen=mxcolr else nshade=(mxcolr-2)/ncolor nshade=(nshade-1)/2 if(icplt/=0) then if(nx==0.and.ny==0) nshade=0 if(numbrs/=0) nshade=0 if(zratio<=0.0e0_rknd) nshade=0 else nshade=min(nshade,5) if(max(abs(t(19)),abs(t(20)))==0.0e0_rknd) 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,icplt, + iuvptr,ut,vt,sf,q,zratio,bmin,bmax,rp,rl,sxy) c if(mpisw==1) call exbox(bmin,bmax,5_iknd) c size=t(14) xs=t(15) ys=t(16) zs=t(17) scale=size/max(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmax(1)+bmin(1))/2.0e0_rknd t(2)=ys-scale*(bmax(2)+bmin(2))/2.0e0_rknd t(5)=zs-scale*(bmax(3)+bmin(3))/2.0e0_rknd t(3)=scale c c parameters for legend plot c if(ierrsw==1) then jp(1)=ip(1) call cdist(jp,t,e,kdist) jp(1)=ntf num=2*min(ncolor,11) if(mpisw==1) call exdist(kdist,num) endif do i=1,25 tl(i)=t(i) enddo if(rmag<=1.0e0_rknd.or.jp(22)==0) then tl(2)=ys-scale*(bmax(4)+bmin(4))/2.0e0_rknd tl(5)=zs-scale*(bmax(5)+bmin(5))/2.0e0_rknd endif tl(12)=1.0e0_rknd c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pbox(ntf,itnode,ibndry,itedge,vx,vy,icplt, + iuvptr,ut,vt,sf,q,zratio,bmin,bmax,rp,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3072) :: ibdy integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: iuvptr real(kind=rknd), dimension(*) :: vx,vy,ut,vt real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(5) :: bmin,bmax real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(3) :: x,y,zu,zv,cc,z real(kind=rknd), dimension(3072) :: xp,yp,up,vp cy external sxy 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(89)+rp(91))/2.0e0_rknd yy=(rp(90)+rp(92))/2.0e0_rknd 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,sf,q,0_iknd,icplt,iuvptr,ut,vt,rl,sxy) do itri=1,3*ntri,3 do j=1,3 m=j+itri-1 x(j)=xp(m) y(j)=yp(m) if(icplt==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==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)=min(rr,bmin(1)) bmax(1)=max(rr,bmax(1)) rr=q(1,2)*x(j)+q(2,2)*y(j) bmin(4)=min(rr,bmin(4)) bmax(4)=max(rr,bmax(4)) rr=rr+q(3,2)*z(j) bmin(2)=min(rr,bmin(2)) bmax(2)=max(rr,bmax(2)) rr=q(1,3)*x(j)+q(2,3)*y(j) bmin(5)=min(rr,bmin(5)) bmax(5)=max(rr,bmax(5)) rr=rr+q(3,3)*z(j) bmin(3)=min(rr,bmin(3)) bmax(3)=max(rr,bmax(3)) endif enddo if(icplt==1) cycle 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/=0.0e0_rknd) then do j=1,3 cc(j)=cc(j)/det enddo if(max(cc(1),cc(2),cc(3))<=1.0e0_rknd.and. + min(cc(1),cc(2),cc(3))>=0.0e0_rknd) 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)=min(rr,bmin(2)) rr=q(1,3)*xx+q(2,3)*yy bmin(3)=min(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<=0.0e0_rknd) cycle c2=-(u2*zu(j3)+v2*zv(j3))/aa if(c2>=0.0e0_rknd.and.c2<=1.0e0_rknd) 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)=min(rr,bmin(2)) rr=q(1,3)*xx+q(2,3)*yy+q(3,3)*zz bmin(3)=min(rr,bmin(3)) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tribx3(c,len,bu,bv,ut,vt) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(3,*) :: c real(kind=rknd), dimension(3,7) :: c0 real(kind=rknd), dimension(3) :: vt,ut real(kind=rknd), dimension(8) :: bu,bv cy 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_rknd-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)>=0.0e0_rknd) then len=len+1 do j=1,3 c(j,len)=c0(j,k) enddo else kbef=k-1 if(k==1) kbef=len0 kaft=k+1 if(k==len0) kaft=1 m=kbef do mba=1,2 if(c0(i,m)>0.0e0_rknd) 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_rknd-s) enddo endif m=kaft enddo endif enddo if(len<=2) then len=0 return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tribx2(c,len,bu,bv,ut,vt) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(3,*) :: c real(kind=rknd), dimension(3,7) :: c0 real(kind=rknd), dimension(3) :: vt,ut,at,a real(kind=rknd), dimension(8) :: bu,bv real(kind=rknd), dimension(4) :: f cy 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>=max(d23,d13)) then kmin=1 kmid=3 kmax=2 endif if(d23>=max(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=max(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)==0.0e0_rknd) f(j)=1.0e-7_rknd enddo c c compute kernal of a c au=(ut(1)+ut(2)+ut(3))/3.0e0_rknd av=(vt(1)+vt(2)+vt(3))/3.0e0_rknd 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_rknd if(qvabs(y2)) then c(kmax,len)=(bbu-ut(kmin))/x2 else c(kmax,len)=(bbv-vt(kmin))/y2 endif c(kmin,len)=1.0e0_rknd-c(kmax,len) c(kmid,len)=0.0e0_rknd endif kbef=k enddo if(len<=1) then len=0 return endif if(len>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)>=0.0e0_rknd) then len=len+1 do j=1,3 c(j,len)=c0(j,k) enddo else kbef=k-1 if(k==1) kbef=len0 kaft=k+1 if(k==len0) kaft=1 m=kbef do mba=1,2 if(c0(i,m)>0.0e0_rknd) 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_rknd-s) enddo endif m=kaft enddo endif enddo if(len<=2) then len=0 return endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine gbx(wu,wv,gmin,gmax,tmin,tmax,eps,irank) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: wu,wv real(kind=rknd), dimension(3) :: rr,ang,tu,tv,cc cy 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_rknd*2.0e0_rknd 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_rknd do j=1,3 gmax=max(gmax,rr(j)) gmin=min(gmin,rr(j)) ang(j)=0.0e0_rknd if(rr(j)>0.0e0_rknd) then arg=min(tu(j)/rr(j),1.0e0_rknd) arg=max(-1.0e0_rknd,arg) theta=acos(arg) if(tv(j)<0.0e0_rknd) theta=pi2-theta tmin=min(tmin,theta) tmax=max(tmax,theta) ang(j)=theta endif enddo if(gmax<=0.0e0_rknd) then tmin=0.0e0_rknd tmax=0.0e0_rknd return endif if(irank==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/=0.0e0_rknd) then do j=1,3 cc(j)=cc(j)/det enddo if(max(cc(1),cc(2),cc(3))<=1.0e0_rknd+eps.and. + min(cc(1),cc(2),cc(3))>-eps) then gmin=0.0e0_rknd tmin=0.0e0_rknd tmax=pi2 return endif endif c c look on edges c umax=0.0e0_rknd 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>0.0e0_rknd) then c1=-(u1*tu(j3)+v1*tv(j3))/a1 if(c1>=0.0e0_rknd.and.c1<=1.0e0_rknd) then ut=tu(j3)+c1*u1 vt=tv(j3)+c1*v1 s=sqrt(ut*ut+vt*vt) gmin=min(gmin,s) endif endif c c check for crossing of positive x axis c if(v1/=0.0e0_rknd) then c1=-tv(j3)/v1 if(c1>=0.0e0_rknd.and.c1<=1.0e0_rknd) + umax=max(umax,tu(j3)+c1*u1) endif c enddo if(umax>eps*gmax) then do j=1,3 if(tv(j)>=0.0e0_rknd) ang(j)=ang(j)+pi2 enddo tmin=min(ang(1),ang(2),ang(3)) tmax=max(ang(1),ang(2),ang(3)) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine trnk(irank,uu,vv,rmax,eps) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(3) :: uu,vv,ua,va cy c compute rank of 3 x 3 matrix, if irank=3, compute inverse c tol=max(1.0e-3_rknd,eps) au=(uu(1)+uu(2)+uu(3))/3.0e0_rknd av=(vv(1)+vv(2)+vv(3))/3.0e0_rknd do j=1,3 ua(j)=(uu(j)-au)/rmax va(j)=(vv(j)-av)/rmax 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>0.0e0_rknd) then dp=max(0.0e0_rknd,1.0e0_rknd-uv/(qu*qv)) else dp=0.0e0_rknd endif c c test for rank 1 c if(max(qu,qv)eps) then irank=3 c c test for rank 2 c else if(qutol) then irank=2 else if(qvtol) then irank=2 else if(dp=3.and.mxcolr<8) then ic=mxcolr-2 else ic=6 endif ngood=0 npoor=0 if(inplsw==2) then qgood=sqrt(3.0e0_rknd)/2.0e0_rknd-1.0e-4_rknd qpoor=0.6e0_rknd+1.0e-4_rknd qmin=1.0e0_rknd qave=0.0e0_rknd do i=1,ntf r=abs(geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)) qmin=min(qmin,r) qave=qave+r iclr(i)=mcic(2,ic) if(r>=qgood) then ngood=ngood+1 iclr(i)=mcic(1,ic) else if(r<=qpoor) then npoor=npoor+1 iclr(i)=mcic(3,ic) endif enddo c else if(inplsw==3) then agood=1.0e0_rknd/2.0e0_rknd+1.0e-4_rknd apoor=2.0e0_rknd/3.0e0_rknd-1.0e-4_rknd angmx=0.0e0_rknd amxave=0.0e0_rknd do i=1,ntf r=cangmx(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) angmx=max(angmx,r) amxave=amxave+r iclr(i)=mcic(2,ic) if(r<=agood) then ngood=ngood+1 iclr(i)=mcic(1,ic) else if(r>=apoor) then npoor=npoor+1 iclr(i)=mcic(3,ic) endif enddo qmin=-180.0e0_rknd*angmx qave=180.0e0_rknd*amxave c else if(inplsw==4) then bgood=acos(4.0e0_rknd/5.0e0_rknd)/pi-1.0e-4_rknd bpoor=acos(13.0e0_rknd/14.0e0_rknd)/pi+1.0e-4_rknd angmn=1.0e0_rknd amnave=0.0e0_rknd do i=1,ntf r=cangmn(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy) angmn=min(angmn,r) amnave=amnave+r iclr(i)=mcic(2,ic) if(r>=bgood) then ngood=ngood+1 iclr(i)=mcic(1,ic) else if(r<=bpoor) then npoor=npoor+1 iclr(i)=mcic(3,ic) endif enddo qmin=180.0e0_rknd*angmn qave=180.0e0_rknd*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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clrmap(red,green,blue,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), save, dimension(7) :: ir,ig,ib real(kind=rknd), dimension(*) :: red,green,blue cy data ir/1,1,1,0,0,0,1/ data ig/0,0,1,1,1,0,0/ data ib/1,0,0,0,1,1,1/ 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_rknd theta=1.0e0_rknd c c background color (white) c red(1)=1.0e0_rknd green(1)=1.0e0_rknd blue(1)=1.0e0_rknd c c line-drawing color (black) c red(2)=0.0e0_rknd green(2)=0.0e0_rknd blue(2)=0.0e0_rknd c if(maplen<=2) return c if(ncolor>=mxcolr-2) then jcolor=mxcolr-2 else jcolor=ncolor endif c c the primary set of colors c red(3)=real(ir(7),rknd) green(3)=real(ig(7),rknd) blue(3)=real(ib(7),rknd) if(jcolor==1) go to 20 if(icplt/=0) then h=5.0e0_rknd/real(jcolor-1,rknd) else h=6.0e0_rknd/real(jcolor,rknd) endif do ii=2,jcolor i=ii+2 x=6.0e0_rknd-h*real(ii-1,rknd) k=1+int(x) dl=real(k,rknd)-x dr=1.0e0_rknd-dl red(i)=dl*real(ir(k),rknd)+dr*real(ir(k+1),rknd) red(i)=max(0.0e0_rknd,red(i))**gamma red(i)=min(1.0e0_rknd,red(i)) green(i)=dl*real(ig(k),rknd)+dr*real(ig(k+1),rknd) green(i)=max(0.0e0_rknd,green(i))**gamma green(i)=min(1.0e0_rknd,green(i)) blue(i)=dl*real(ib(k),rknd)+dr*real(ib(k+1),rknd) blue(i)=max(0.0e0_rknd,blue(i))**gamma blue(i)=min(1.0e0_rknd,blue(i)) enddo c c shading c 20 if(nshade==0) return if(icplt/=0) then bmax=0.5e0_rknd/real(nshade,rknd) wmax=0.5e0_rknd/real(nshade,rknd) else bmax=0.45e0_rknd/real(nshade,rknd) wmax=0.75e0_rknd/real(nshade,rknd) endif do j=1,nshade jplus=j*ncolor+2 jminus=jplus+nshade*ncolor fb=(1.0e0_rknd-real(j,rknd)*bmax)**theta fw=(1.0e0_rknd-real(j,rknd)*wmax)**theta w=1.0e0_rknd-fw do i=1,ncolor k=i+jplus red(k)=red(i+2)*fw+w red(k)=max(red(k),0.0e0_rknd) red(k)=min(red(k),1.0e0_rknd) green(k)=green(i+2)*fw+w green(k)=max(green(k),0.0e0_rknd) green(k)=min(green(k),1.0e0_rknd) blue(k)=blue(i+2)*fw+w blue(k)=max(blue(k),0.0e0_rknd) blue(k)=min(blue(k),1.0e0_rknd) k=i+jminus red(k)=red(i+2)*fb red(k)=max(red(k),0.0e0_rknd) red(k)=min(red(k),1.0e0_rknd) green(k)=green(i+2)*fb green(k)=max(green(k),0.0e0_rknd) green(k)=min(green(k),1.0e0_rknd) blue(k)=blue(i+2)*fb blue(k)=max(blue(k),0.0e0_rknd) blue(k)=min(blue(k),1.0e0_rknd) enddo enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function ccolor(icolor,ishade,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor cy c compute the color index c ncolor=jp(5) nshade=jp(16) mxcolr=jp(17) if(icolor<=0.or.icolor>ncolor + .or.abs(ishade)>nshade) then ccolor=1 else if(ishade==0) then ccolor=icolor+2-((icolor-1)/(mxcolr-1))*(mxcolr-1) if(ccolor>mxcolr) ccolor=1 else if(ishade>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine incirc(x1,y1,x2,y2,x3,y3,xc,yc,r) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) cy 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_rknd 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine arc(x1,y1,x2,y2,xc,yc,theta1,theta2,r,alen) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) cy 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_rknd 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_rknd wm=(w1+w2)/2.0e0_rknd dd=sqrt(vm**2+wm**2) vm=vm/dd wm=wm/dd c r=sqrt(r1*r2) theta=max(-1.0e0_rknd,vm) theta=min(1.0e0_rknd,theta) theta=acos(theta) if(wm<0.0e0_rknd) theta=-theta c dtheta=min(1.0e0_rknd,dd) dtheta=acos(dtheta) if(v1*wm-w1*vm>0.0e0_rknd) dtheta=-dtheta theta1=(theta+dtheta)/pi theta2=(theta-dtheta)/pi alen=abs(dtheta*r*2.0e0_rknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tbdy(xp,yp,up,vp,ibdy,ntri,it,itnode,ibndry,itedge, + vx,vy,sf,q,i3d,icplt,iuvptr,ut,vt,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ibdy integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3) :: iadj,icurv integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(2,*) :: iuvptr integer(kind=iknd), dimension(3) :: iords,jords integer(kind=iknd), dimension(8,1) :: ktdof real(kind=rknd), dimension(*) :: vx,vy,ut,vt,xp,yp,up real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(21,21) :: c1,c2,c3,b1,b2,b3,x,y,u real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3) :: xr,dr,rad,theta1,theta2,c real(kind=rknd), dimension(*) :: vp real(kind=rknd), dimension(100) :: gx,gy,gv,tu,tv real(kind=rknd), dimension(21,21) :: v real(kind=rknd), dimension(12) :: values common /pltmg1/ic(3,363),jc(12) cy external sxy data index/1,2,3,2,3,1,3,1,2/ data ktdof/0,0,0,0,0,0,0,0/ c c compute parameterization of triangle it in terms of c baricentric coordinates c pi=3.141592653589793e0_rknd irefn=1 do j=1,3 if(itedge(j,it)>0) then k=itedge(j,it)/4 icurv(j)=0 iadj(j)=0 if(itnode(5,it)/=itnode(5,k)) iadj(j)=2 if(itnode(4,it)/=itnode(4,k)) iadj(j)=iadj(j)+3 else iadj(j)=1 k=-itedge(j,it) if(ibndry(4,k)==4) iadj(j)=5 if(ibndry(4,k)==3) iadj(j)=3 if(ibndry(3,k)==0) then icurv(j)=0 else if(ibndry(3,k)>0) then icurv(j)=k iv1=itnode(index(2,j),it) iv2=itnode(index(3,j),it) call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2), + sf(1,k),sf(2,k),theta1(j),theta2(j),rad(j), 1 alen) aa=abs(theta2(j)-theta1(j))*32.0e0_rknd mm=min(int(aa+0.5e0_rknd),8) irefn=max(irefn,mm) else icurv(j)=ibndry(3,k) if(itnode(index(2,j),it)==ibndry(1,k)) then theta1(j)=sf(1,k) theta2(j)=sf(2,k) else theta1(j)=sf(2,k) theta2(j)=sf(1,k) endif irefn=max(irefn,8) endif endif enddo c c make sure there is adaquate refinment, and that dofs are verts c get function values c if(icplt>=0) then ktdof(8,1)=iuvptr(2,it) call locord(1_iknd,ndof,jord,jords,ktdof) iord=max(jord,jords(1),jords(2),jords(3)) iords(1)=iord iords(2)=iord iords(3)=iord call p2q2d(ut(iuvptr(1,it)),tu,jord,iord,jords,iords) if(icplt==0) then call p2q2d(vt(iuvptr(1,it)),tv,jord,iord,jords,iords) endif irefn=max(2*iord,irefn) irefn=((irefn+iord-1)/iord)*iord else iord=1 endif ndof=(iord+1)*(iord+2)/2 c c set up initial baricentric coodinates c do k=1,irefn+1 do j=1,irefn+2-k c2(k,j)=real(k-1,rknd)/real(irefn,rknd) c3(k,j)=real(j-1,rknd)/real(irefn,rknd) c1(k,j)=1.0e0_rknd-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_rknd y(k,j)=0.0e0_rknd u(k,j)=0.0e0_rknd v(k,j)=0.0e0_rknd enddo enddo c c simple case c if(irefn==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>=0) then u(1,1)=tu(1) u(2,1)=tu(2) u(1,2)=tu(3) endif if(icplt==0) then v(1,1)=tv(1) v(2,1)=tv(2) v(1,2)=tv(3) endif go to 30 endif c c modify barycentric coordinates for curved edges c do j=1,3 if(icurv(j)==0) cycle kt=icurv(j) itag=-icurv(j) iv1=itnode(index(2,j),it) iv2=itnode(index(3,j),it) iv3=itnode(j,it) dt=(theta2(j)-theta1(j))/real(irefn,rknd) 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 if(kt>0) then tt=(theta1(j)+dt*real(m-1,rknd))*pi xx=sf(1,kt)+rad(j)*cos(tt)-vx(iv3) yy=sf(2,kt)+rad(j)*sin(tt)-vy(iv3) else tt=(theta1(j)+dt*real(m-1,rknd)) do mm=1,12 values(mm)=0.0e0_rknd enddo call sxy(rl,tt,itag,values) xx=values(1)-vx(iv3) yy=values(2)-vy(iv3) endif mm=irefn+2-m if(j==1) then c2(mm,m)=(xx*y2-yy*x2)/det c3(mm,m)=(x1*yy-y1*xx)/det c1(mm,m)=1.0e0_rknd-c2(mm,m)-c3(mm,m) else if(j==2) then c3(1,mm)=(xx*y2-yy*x2)/det c1(1,mm)=(x1*yy-y1*xx)/det c2(1,mm)=1.0e0_rknd-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_rknd-c1(m,1)-c2(m,1) endif enddo enddo c c smoothing c if(iord==1) then itmax=100 tol=1.0e-2_rknd do i=1,itmax cc=0.0e0_rknd 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)+ 1 c2(k-1,j+1))/6.0e0_rknd cc3=(c3(k,j-1)+c3(k,j+1)+c3(k+1,j)+ + c3(k-1,j)+c3(k+1,j-1)+ 1 c3(k-1,j+1))/6.0e0_rknd cc=max(cc,abs(cc2-c2(k,j)),abs(cc3-c3(k,j))) c2(k,j)=cc2 c3(k,j)=cc3 c1(k,j)=1.0e0_rknd-cc2-cc3 enddo enddo if(cc<=tol) exit enddo 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>=0) u(k,j)=c1(k,j)*tu(1)+ + c2(k,j)*tu(2)+c3(k,j)*tu(3) if(icplt==0) v(k,j)=c1(k,j)*tv(1)+ + c2(k,j)*tv(2)+c3(k,j)*tv(3) 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)) c c isoparametric map c inc=irefn/iord do k=jc(iord)+3,jc(iord+1)-1 m=k-jc(iord)+1 j2=ic(2,k)*inc+1 j3=ic(3,k)*inc+1 gx(m)=c1(j2,j3)*gx(1)+c2(j2,j3)*gx(2)+c3(j2,j3)*gx(3) gy(m)=c1(j2,j3)*gy(1)+c2(j2,j3)*gy(2)+c3(j2,j3)*gy(3) enddo 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,iords) x(k,j)=0.0e0_rknd y(k,j)=0.0e0_rknd u(k,j)=0.0e0_rknd v(k,j)=0.0e0_rknd 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>=0) u(k,j)=u(k,j)+gv(m)*tu(m) if(icplt==0) v(k,j)=v(k,j)+gv(m)*tv(m) enddo enddo enddo endif c c do orientation c if(i3d==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)>dr(iback)) iback=2 if(dr(3)>dr(iback)) iback=3 imid=index(2,iback) ifront=index(3,iback) if(dr(ifront)>dr(imid)) imid=ifront ifront=6-iback-imid c c swapping c jmid=2 if(iback==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==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/=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 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==1) ibdy(k+3)=iadj(3) if(i==1) ibdy(k+2)=iadj(2) if(i+j==irefn+1) ibdy(k+1)=iadj(1) k=k+3 if(i+j==irefn+1) cycle 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 enddo enddo ntri=irefn**2 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function tblock(itnode,it,iside,vx,vy,q,eps) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd) :: tblock real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3,3) :: q cy 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>eps) tblock=1 if(qq<-eps) tblock=-1 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine bblock(ntf,itnode,itedge,ilen,list,vx,vy,q,eps) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(*) :: list integer(kind=iknd), dimension(2,3*ilen) :: tlist integer(kind=iknd) :: tblock,endin,endout integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(ilen+ntf+1) :: cen cy data index/1,2,3,2,3,1,3,1,2/ c c compute boundary types (ilen>=ntf) c llen=4*ilen+1 c eps1=max(1.0e-4_rknd,eps*8.0e0_rknd) 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 j=1,3 if(itedge(j,i)>0) cycle ity=tblock(itnode,i,j,vx,vy,q,eps1) if(ity==0) cycle if(ity==1) then if(kin==0) then endin=endin+1 list(endin)=j+4*i kin=j else list(endin)=6-j-kin+4*i endif else if(kout==0) then istrt=istrt-1 list(istrt)=j+4*i kout=j else list(istrt)=6-j-kout+4*i endif endif enddo enddo c c out of space c if(istrt<=endin) stop 7760 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_rknd do ic=1,2 if(ic==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_rknd hmax=max(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_iknd,i-1_iknd,cen(iptr),list(iptr)) enddo enddo c c now make list of triangle pairs that interfere c jstrt=1 num=0 do 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=max(x1i,x2i) yimax=max(y1i,y2i) ximin=min(x1i,x2i) yimin=min(y1i,y2i) epsi=eps*(yimax-yimin+ximax-ximin) c istrt=jstrt do jj=istrt,endin c c simple tests to cut down compares c if(cen(jj)+hmax<=cen(ii)) then jstrt=jj cycle endif if(ximin>=cen(jj)+hmax/2.0e0_rknd) cycle if(ximax<=cen(jj)-hmax/2.0e0_rknd) exit c jt=list(jj)/4 if(it==jt) cycle 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=max(x1j,x2j) xjmin=min(x1j,x2j) yjmax=max(y1j,y2j) yjmin=min(y1j,y2j) epsj=eps*(yjmax-yjmin+xjmax-xjmin)+epsi c c simple tests to disregard this element c c* if(yimin+epsj>=yjmax) cycle if(ximin+epsj>=xjmax) cycle if(xjmin+epsj>=ximax) cycle c xx=(max(ximin,xjmin)+min(ximax,xjmax))/2.0e0_rknd yi=(y1i*(x2i-xx)+y2i*(xx-x1i))/(x2i-x1i) yj=(y1j*(x2j-xx)+y2j*(xx-x1j))/(x2j-x1j) if(yi-8.0e0_rknd*eps>=yj) cycle c c this takes care of very special cases c if(abs(yi-yj)<=8.0e0_rknd*eps) then kout=0 do k=1,3 if(itedge(k,it)>0) cycle ity=tblock(itnode,it,k,vx,vy,q,eps1) if(ity==-1) kout=kout+1 enddo if(kout==2) cycle kin=0 do k=1,3 if(itedge(k,jt)>0) cycle jty=tblock(itnode,jt,k,vx,vy,q,eps1) if(jty==1) kin=kin+1 enddo if(kin==2) cycle endif c c we have found a conflicting pair c num=num+1 if(num>3*ilen) stop 7761 tlist(1,num)=it tlist(2,num)=jt c enddo enddo c c make final list c do i=1,ntf+1 list(i)=0 enddo if(num<=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)>llen+1) stop 7762 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 end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkheap(i,llen,d,list) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: list real(kind=rknd), dimension(*) :: d cy 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>llen) return if(ksond(kson)) kson=kson+1 endif if(d(k)>=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd0(t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(6) :: x,y,z real(kind=rknd), dimension(25) :: t,tt real(kind=rknd), dimension(3,3) :: q cy 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_rknd 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)>1.0e0_rknd) then xl=max(x0,t(8)) xr=min(x1,t(9)) yb=max(y0,t(10)) yt=min(y1,t(11)) c c mark the box in the window c x(1)=(xl+xr)/2.0e0_rknd x(2)=x(1) y(1)=y0 y(2)=yb call pline(x,y,z,2_iknd,2_iknd) y(1)=yt y(2)=y1 call pline(x,y,z,2_iknd,2_iknd) x(1)=x0 x(2)=xl y(1)=(yb+yt)/2.0e0_rknd y(2)=y(1) call pline(x,y,z,2_iknd,2_iknd) x(1)=xr x(2)=x1 call pline(x,y,z,2_iknd,2_iknd) 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_iknd,2_iknd) 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_iknd,2_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine linit(t,q) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q cy c c initial for legends and graphs c size=0.9e0_rknd do i=1,25 t(i)=0.0e0_rknd enddo t(3)=1.0e0_rknd t(5)=0.5e0_rknd t(7)=1.0e1_rknd*epsilon(1.0e0_rknd) t(12)=1.0e0_rknd t(14)=size t(15)=0.5e0_rknd t(16)=0.5e0_rknd t(17)=0.5e0_rknd do i=1,3 do j=1,3 q(i,j)=0.0e0_rknd enddo q(i,i)=1.0e0_rknd enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine zoombx(rp,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(25) :: t cy c compute the zoom-in window c size=t(14) xs=t(15) ys=t(16) rmag=max(1.0e0_rknd,rp(10)) cenx=max(0.0e0_rknd,rp(11)) cenx=min(1.0e0_rknd,cenx) ceny=max(0.0e0_rknd,rp(12)) ceny=min(1.0e0_rknd,ceny) h=1.0e0_rknd/(2.0e0_rknd*rmag) hx=xs-size/2.0e0_rknd hy=ys-size/2.0e0_rknd 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkrot(nx,ny,nz,q) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3) :: d cy c compute rotation matrix c d(1)=real(nx,rknd) d(2)=real(ny,rknd) d(3)=real(nz,rknd) do i=1,3 do j=1,3 q(j,i)=0.0e0_rknd enddo q(i,i)=1.0e0_rknd enddo dl=sqrt(d(1)*d(1)+d(2)*d(2)+d(3)*d(3)) if(dl>0.0e0_rknd) 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>0.0e0_rknd) 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)<0.0e0_rknd) q(1,1)=-q(1,1) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd1(jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor real(kind=rknd), dimension(4) :: x,y,z real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t character(len=80) :: ichr cy 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_rknd xr=xs+size/2.0e0_rknd yb=ys-size/2.0e0_rknd yt=ys+size/2.0e0_rknd s3=sqrt(3.0e0_rknd)/2.0e0_rknd c c compute ncol and nrow c s=sqrt(real(ncolor,rknd)/3.0e0_rknd) is=int(s) if(s-real(is,rknd)>1.0e-3_rknd) is=is+1 ncol=max(is,2) nrow=ncolor/ncol if(nrow*ncol3.0e0_rknd*dy) dx=3.0e0_rknd*dy if(dx<3.0e0_rknd*dy) dy=dx/3.0e0_rknd c c the main loop c icolor=0 do nr=1,nrow do nc=1,ncol icolor=icolor+1 if(icolor>ncolor) cycle c c level number c ichr=' ' if(icolor<10) then call sint(ichr(3:3),nchr,icolor) else call sint(ichr(2:2),nchr,icolor) endif ii=ccolor(icolor,0_iknd,jp) c x1=xl+real(nc-1,rknd)*dx x2=xl+real(nc,rknd)*dx xm=(2.0e0_rknd*x2+x1)/3.0e0_rknd y1=yt-real(nr,rknd)*dy y2=yt-real(nr-1,rknd)*dy ym=(y1+y2)/2.0e0_rknd call htext(x1,y1,xm,ym,4_iknd,ichr,1_iknd,q,t,2_iknd) c c triangle icon c x(1)=xm x(2)=(xm+x2)/2.0e0_rknd 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_iknd,jp) call pfill(x,y,z,3_iknd,ii) call pline(x,y,z,4_iknd,2_iknd) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd2(jp,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), save, dimension(3,6) :: mcic real(kind=rknd), dimension(4) :: x,y,z real(kind=rknd), dimension(25) :: tt,t real(kind=rknd), dimension(3,3) :: qq character(len=80) :: ichr character(len=80), save, dimension(3) :: title character(len=80), save, dimension(5) :: label cy 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_rknd xr=xs+size/2.0e0_rknd yb=ys-size/2.0e0_rknd yt=ys+size/2.0e0_rknd s3=2.0e0_rknd/sqrt(3.0e0_rknd) dx=(xr-xl)/14.5e0_rknd dy=(yt-yb)/6.0e0_rknd h=min(0.9e0_rknd*dy,dx) c do i=1,4 z(i)=zshift enddo c mxcolr=jp(17) if(mxcolr>=3.and.mxcolr<8) then ic=mxcolr-2 else ic=6 endif c inplsw=jp(9) call fstr(ichr,nchr,title(inplsw-1),0_iknd) xxl=xl+2.25e0_rknd*dx xxr=xxl+15.0e0_rknd*dx yyl=yt-dy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,15_iknd,ichr, + -1_iknd,qq,tt,2_iknd) c do i=1,5 yy=yt-real(i+1,rknd)*dy c c triangle icon c if(i<=3) then x(1)=xl+0.25e0_rknd*dx x(2)=x(1)+s3*h x(3)=(x(1)+x(2))/2.0e0_rknd 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_iknd,jp) call pfill(x,y,z,3_iknd,ii) call pline(x,y,z,4_iknd,2_iknd) endif c c label c call fstr(ichr,nchr,label(i),0_iknd) xxl=xl+2.25e0_rknd*dx xxr=xxl+7.0e0_rknd*dx yyl=yy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,7_iknd,ichr, + -1_iknd,qq,tt,2_iknd) c c value c ichr=' ' call sfix(ichr(4:4),nchr,t(20+i),3_iknd) cc call sreal(ichr(4:4),nchr,t(20+i),3_iknd,1_iknd) if(nchr<7) then ii=nchr-3 nchr=7 else ii=4 endif xxl=xl+9.25e0_rknd*dx xxr=xxl+5.0e0_rknd*dx call htext(xxl,yyl,xxr,yyr,nchr,ichr(ii:ii), + 1_iknd,qq,tt,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd3(jp,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(15) :: nchr real(kind=rknd), dimension(129) :: x,y,z real(kind=rknd), dimension(25) :: t,tt real(kind=rknd), dimension(3,3) :: qq real(kind=rknd), dimension(52) :: f character(len=80), dimension(15) :: ichr cy call linit(tt,qq) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c ncolor=jp(5) if(ncolor<=0) return nshade=jp(16) iscale=jp(19) c c set function values c funmin=fscale(t(19),iscale,0_iknd) funmax=fscale(t(20),iscale,0_iknd) df=(funmax-funmin)/real(2*nshade+1,rknd) do i=1,2*nshade+2 zz=funmin+df*real(i-1,rknd) f(i)=fscale(zz,iscale,1_iknd) enddo c xm=xs+0.15e0_rknd*size ym=ys rmax=0.35e0_rknd*size pi=3.141592653589793e0_rknd c if(t(19)>0.0e0_rknd) then rmin=rmax*0.15e0_rknd else rmin=0.0e0_rknd endif dr=(rmax-rmin)/real(2*nshade+1,rknd) dt=2.0e0_rknd*pi/real(ncolor,rknd) nn=max(64/ncolor,2) nn=min(nn,48) dq=dt/real(nn-1,rknd) n2=2*nn n3=n2+1 c c draw regions c do i=1,ncolor do j=1,2*nshade+1 theta=real(i-1,rknd)*dt r1=rmin+real(j-1,rknd)*dr r2=rmin+real(j,rknd)*dr k=j-nshade-1 ic=ccolor(i,k,jp) do k=1,nn ang=theta+real(k-1,rknd)*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_iknd) enddo enddo c c draw band across the bottom c yb=ys-size*0.45e0_rknd yt=ys+size*0.45e0_rknd xl=xs-size*0.5e0_rknd xr=xl+size*0.05e0_rknd xc=xr+0.02e0_rknd*size xf=xc+0.2e0_rknd*size c dy=(yt-yb)/real(2*nshade+1,rknd) do i=1,2*nshade+1 k=i-nshade-1 ic=ccolor(1_iknd,k,jp) x(1)=xl y(1)=yb+real(i-1,rknd)*dy z(1)=zshift x(2)=xr y(2)=y(1) z(2)=zshift x(3)=x(2) y(3)=yb+real(i,rknd)*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_iknd,ic) call pline(x,y,z,5_iknd,2_iknd) enddo c mxchr=0 do i=1,2*nshade+2 ichr(i)=' ' zc=f(i) if(zc<0.0e0_rknd) then call sreal(ichr(i),nchr(i),zc,3_iknd,1_iknd) else call sreal(ichr(i)(2:2),nn,zc,3_iknd,1_iknd) nchr(i)=nn+1 endif mxchr=max(mxchr,nchr(i)) enddo do i=1,2*nshade+2 yc=yb+dy*real(i-1,rknd)-dy/2.0e0_rknd yf=yc+dy call htext(xc,yc,xf,yf,mxchr,ichr(i),-1_iknd,qq,tt,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd4(jp,t,kdist) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(20) :: nchr integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(22) :: kdist real(kind=rknd), dimension(12) :: f real(kind=rknd), dimension(44) :: x,y,z real(kind=rknd), dimension(25) :: t,tt real(kind=rknd), dimension(3,3) :: qq character(len=80), dimension(15) :: ichr cy 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<=0) return ncolor=min(icolor,11) iscale=jp(19) c c set function values c zmin=fscale(t(19),iscale,0_iknd) zmax=fscale(t(20),iscale,0_iknd) df=(zmax-zmin)/real(ncolor,rknd) do i=1,ncolor+1 zz=zmin+df*real(i-1,rknd) f(i)=fscale(zz,iscale,1_iknd) enddo c c make boxes for each color c xf=xs xi=xf-size*0.45e0_rknd xc=xf+0.04e0_rknd*size xx=xc+0.4e0_rknd*size yi=ys-size*0.45e0_rknd yf=ys+size*0.45e0_rknd yinc=0.04e0_rknd*size tic=0.02e0_rknd*size if(icolor==ncolor) yf=yi+(yf-yi)*ncolor/11.0e0_rknd 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)/real(icolor,rknd) do i=1,icolor y(1)=yi+dy*real(i,rknd) y(2)=y(1) y(3)=yi+dy*real(i-1,rknd) y(4)=y(3) ii=ccolor(i,0_iknd,jp) call pfill(x,y,z,4_iknd,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_iknd,2_iknd) c c x(1)=xf scale=(yf-yi)/real(ncolor,rknd) do i=0,ncolor yp=yi+scale*i x(2)=xf+tic y(1)=yp y(2)=yp call pline(x,y,z,2_iknd,2_iknd) enddo c c compute error distribution c if(ierrsw==1.and.df/=0.0e0_rknd) then num=2*ncolor kdm=0 do i=1,num kdm=max(kdm,kdist(i)) enddo ddy=(yf-yi)/real(num,rknd) xxi=xi+0.05e0_rknd*(xf-xi) ddx=0.9e0_rknd*(xf-xi) do i=1,num j=2*i-1 x(j)=xxi+ddx*(real(kdist(i),rknd)/real(kdm,rknd)) x(j+1)=x(j) y(j+1)=yi+ddy*real(i,rknd) y(j)=yi+ddy*real(i-1,rknd) z(j)=zshift z(j+1)=zshift enddo num=2*num call pline(x,y,z,num,2_iknd) endif c c label the tick marks c mxchr=0 do i=1,ncolor+1 ichr(i)=' ' zc=f(i) if(zc<0.0e0_rknd) then call sreal(ichr(i)(2:2),nn,zc,3_iknd,1_iknd) nchr(i)=nn+1 else call sreal(ichr(i)(3:3),nn,zc,3_iknd,1_iknd) nchr(i)=nn+2 endif mxchr=max(mxchr,nchr(i)) enddo do i=1,ncolor+1 yc=yi+scale*real(i-1,rknd)-yinc/2.0e0_rknd yf=yc+yinc call htext(xc,yc,xx,yf,mxchr,ichr(i),-1_iknd,qq,tt,2_iknd) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdist(jp,t,e,kdist) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(22) :: kdist real(kind=rknd), dimension(*) :: e real(kind=rknd), dimension(25) :: t cy c num=2*min(jp(5),11) ntf=jp(1) iscale=jp(19) c c set function values c zmin=fscale(t(19),iscale,0_iknd) zmax=fscale(t(20),iscale,0_iknd) if(zmax>zmin) then dd=real(num,rknd)/(zmax-zmin) else dd=0.0e0_rknd endif c do i=1,num kdist(i)=0 enddo do i=1,ntf ff=(fscale(e(i),iscale,0_iknd)-zmin)*dd iq=max(1,int(ff)+1) iq=min(num,iq) kdist(iq)=kdist(iq)+1 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd5(jp,kdist) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(22) :: kdist real(kind=rknd), dimension(44) :: x,y,z real(kind=rknd), dimension(25) :: tt real(kind=rknd), dimension(3,3) :: qq character(len=80), dimension(15) :: ichr cy call linit(tt,qq) size=tt(14) zshift=tt(5) xs=tt(15) ys=tt(16) c ncolor=10 c c make boxes for each color c xf=xs xi=xf-size*0.45e0_rknd xc=xf+0.04e0_rknd*size xx=xc+0.4e0_rknd*size yi=ys-size*0.45e0_rknd yf=ys+size*0.45e0_rknd yinc=0.04e0_rknd*size 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)/real(ncolor,rknd) do i=1,ncolor y(1)=yi+dy*real(i,rknd) y(2)=y(1) y(3)=yi+dy*real(i-1,rknd) y(4)=y(3) ii=ccolor(i,0_iknd,jp) call pfill(x,y,z,4_iknd,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_iknd,2_iknd) c c c compute error distribution c kdm=0 do i=1,ncolor kdm=max(kdm,kdist(i)) enddo ddy=(yf-yi)/real(ncolor,rknd) xxi=xi+0.05e0_rknd*(xf-xi) ddx=0.9e0_rknd*(xf-xi) do i=1,ncolor j=2*i-1 x(j)=xxi+ddx*(real(kdist(i),rknd)/real(kdm,rknd)) x(j+1)=x(j) y(j+1)=yi+ddy*real(i,rknd) y(j)=yi+ddy*real(i-1,rknd) z(j)=zshift z(j+1)=zshift enddo num=2*ncolor call pline(x,y,z,num,2_iknd) c c label the tick marks c mxchr=0 do i=1,ncolor ichr(i)=' ' if(i<10) then call sint(ichr(i)(3:3),nn,i) else call sint(ichr(i)(2:2),nn,i) endif enddo mxchr=3 do i=1,ncolor yc=yi+dy*real(i-1,rknd)+yinc/2.0e0_rknd yf=yc+yinc call htext(xc,yc,xx,yf,mxchr,ichr(i),-1_iknd,qq,tt,2_iknd) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cdist1(jp,iclr,kdist) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(22) :: kdist integer(kind=iknd), dimension(*) :: iclr cy c mxord=10 ntf=jp(1) c do i=1,mxord kdist(i)=0 enddo do i=1,ntf iq=max(1,iclr(i)) iq=min(mxord,iq) kdist(iq)=kdist(iq)+1 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine legnd6(jp,iptr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), save, dimension(50) :: mcic integer(kind=iknd), save, dimension(6) :: jc real(kind=rknd), dimension(5) :: x,y,z real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: tt character(len=80) :: ichr character(len=80), save, dimension(5) :: title character(len=80), save, dimension(50) :: label cy 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_rknd xr=xs+size/2.0e0_rknd yb=ys-size/2.0e0_rknd yt=ys+size/2.0e0_rknd dx=(xr-xl)/20.5e0_rknd dy=(yt-yb)/9.0e0_rknd h=min(0.9e0_rknd*dy,dx) c call fstr(ichr,nchr,title(iptr),0_iknd) xxl=xl+2.25e0_rknd*dx xxr=xxl+17.0e0_rknd*dx yyl=yt-dy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + -1_iknd,q,tt,2_iknd) c i1=jc(iptr) i2=jc(iptr+1)-1 do i=i1,i2 yy=yt-real(i-i1+2,rknd)*dy c c square icon c x(1)=xl+0.25e0_rknd*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_iknd,jp) call pfill(x,y,z,4_iknd,ii) call pline(x,y,z,5_iknd,2_iknd) c c label c call fstr(ichr,nchr,label(i),0_iknd) xxl=xl+2.25e0_rknd*dx xxr=xxl+20.0e0_rknd*dx yyl=yy yyr=yyl+h call htext(xxl,yyl,xxr,yyr,20_iknd,ichr, + -1_iknd,q,tt,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- function fscale(f,iscale,invrse) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) cy c set scaling function c if(iscale==0) then c c linear scale c fscale=f return else if(iscale==1) then c c log scale c if(invrse==0) then fscale=log(f) return else fscale=exp(f) return endif else c c arcsinh scale c if(invrse==0) then af=abs(f) if(af<1.0e0_rknd) then q=sqrt(1.0e0_rknd+f*f)+af fx=log(q) fscale=fx+(af-sinh(fx))/cosh(fx) else q=1.0e0_rknd/f q=sqrt(1.0e0_rknd+q*q)+1.0e0_rknd fscale=log(q)+log(af) endif if(f<0.0e0_rknd) fscale=-fscale return else fscale=sinh(f) return endif endif end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dgrid cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(6) :: x,y,z real(kind=rknd), dimension(25) :: tt real(kind=rknd), dimension(3,3) :: q cy c helps locating current window (draw boundary in small window) c call linit(tt,q) zshift=1.0e0_rknd size=tt(14) x0=tt(15)-size/2.0e0_rknd x1=tt(15)+size/2.0e0_rknd y0=tt(16)-size/2.0e0_rknd y1=tt(16)+size/2.0e0_rknd c c mark magnified area c icolor=1 z(1)=zshift z(2)=zshift h=size/20.0e0_rknd do i=1,10 x(1)=x0+real(2*i-1,rknd)*h x(2)=x(1) y(1)=y0 y(2)=y1 call pline(x,y,z,2_iknd,icolor) x(1)=x0 x(2)=x1 y(1)=y0+real(2*i-1,rknd)*h y(2)=y(1) call pline(x,y,z,2_iknd,icolor) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine vlabel(len,jp,itnode,itedge,ibndry,ibedge, + vx,vy,sf,q,t,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(len) :: vtype,iseed integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(len) :: rad real(kind=rknd), dimension(3,3) :: q character(len=80) :: ichr cy external sxy data index/1,2,3,2,3,1,3,1,2/ c c print vertex number c ntf=jp(1) nvf=jp(2) nbf=jp(3) numbrs=jp(21) scale=t(3) c c if(numbrs==8) then angmin=1.0e-3_rknd arcmax=0.26e0_rknd call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) endif c rmax=0.05e0_rknd/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_rknd rad(j1)=min(h,rad(j1)) rad(j2)=min(h,rad(j2)) enddo enddo c do k=1,nvf xc=vx(k) yc=vy(k) r=rad(k) c if(numbrs==8) then kk=vtype(k) else kk=k endif call sint(ichr,nchr,kk) ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd delta=r/sqrt(1.0e0_rknd+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_iknd,q,t,2_iknd) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine blabel(jp,itnode,ibndry,ibedge,vx,vy,sf,q,t,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(12) :: values character(len=80) :: ichr cy external sxy 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_rknd/scale do ib=1,nbf r=rmax do k=1,2 if(ibedge(k,ib)==0) cycle 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_rknd d2=sqrt((x2+x3)**2+(y2+y3)**2)/5.0e0_rknd r=min(d1,d2,r) enddo c c j1=ibndry(1,ib) j2=ibndry(2,ib) jm=ibndry(3,ib) c i=ib if(numbrs==4) i=jm if(numbrs==5) i=ibndry(4,ib) if(numbrs==6) i=ibndry(7,ib) if(jm>0) then call midpt(vx(j1),vy(j1),vx(j2), + vy(j2),sf(1,ib),sf(2,ib),xc,yc) else if(jm<0) then itag=-jm theta=(sf(1,ib)+sf(2,ib))/2.0e0_rknd do m=1,12 values(m)=0.0e0_rknd enddo call sxy(rl,theta,itag,values) xc=values(1) yc=values(2) else if(numbrs==4) cycle xc=(vx(j1)+vx(j2))/2.0e0_rknd yc=(vy(j1)+vy(j2))/2.0e0_rknd endif c call sint(ichr,nchr,i) ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd delta=r/sqrt(1.0e0_rknd+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_iknd,q,t,2_iknd) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tlabel(jp,itnode,vx,vy,q,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(25) :: jp real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t character(len=80) :: ichr cy ntf=jp(1) scale=t(3) c rmax=0.05e0_rknd/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=min(rmax,r) c c compute number width (max 10 digits) c call sint(ichr,nchr,it) ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd delta=r/sqrt(1.0e0_rknd+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_iknd,q,t,2_iknd) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rlabel(jp,itnode,jt,vx,vy,q,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(*) :: jt real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t character(len=80) :: ichr cy ntf=jp(8) scale=t(3) c rmax=0.05e0_rknd/scale c do irgn=1,ntf c c compute center of inscribed circle c xc=0.0e0_rknd yc=0.0e0_rknd r=0.0e0_rknd 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>r) then r=rr xc=xcc yc=ycc endif enddo r=min(rmax,r) c c compute number width (max 10 digits) c call sint(ichr,nchr,irgn) ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd delta=r/sqrt(1.0e0_rknd+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_iknd,q,t,2_iknd) c enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine plabel(nproc,jp,itnode,vx,vy,q,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(25) :: jp real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(nproc) :: xc,yc,r character(len=80) :: ichr cy ntf=jp(1) cc nproc=jp(23) scale=t(3) c rmax=0.05e0_rknd/scale c do i=1,nproc r(i)=-1.0e0_rknd 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>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)=min(rmax,r(irgn)) c c compute number width (max 10 digits) c call sint(ichr,nchr,irgn) ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd delta=r(irgn)/sqrt(1.0e0_rknd+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_iknd,q,t,2_iknd) c enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dlabel(ndf,jp,itnode,itdof,vx,vy,q,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(100) :: idof integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(5) :: lptr real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(ndf) :: rad,x,y real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3) :: h character(len=80) :: ichr common /pltmg1/ic(3,363),jc(12) cy data index/1,2,3,2,3,1,3,1,2/ c c print vertex number c ntf=jp(1) scale=t(3) c rmax=0.05e0_rknd/scale do i=1,ndf rad(i)=rmax enddo c do it=1,ntf call l2gmap(it,idof,ndof,iord,iords,itdof) call mkgptr(iord,iords,lptr) c do j=1,3 j1=itnode(index(2,j),it) j2=itnode(index(3,j),it) h(j)=sqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2) c x(idof(j))=vx(itnode(j,it)) y(idof(j))=vy(itnode(j,it)) enddo c do j=1,3 ss=1.0e0_rknd/real(iords(j),rknd) h(j)=h(j)*ss/3.0e0_rknd ii=jc(iords(j))+3+(j-1)*(iords(j)-1)-lptr(j) do k=lptr(j),lptr(j+1)-1 kk=ii+k x(idof(k))=(x(idof(1))*real(ic(1,kk),rknd) + +x(idof(2))*real(ic(2,kk),rknd) 1 +x(idof(3))*real(ic(3,kk),rknd))*ss y(idof(k))=(y(idof(1))*real(ic(1,kk),rknd) + +y(idof(2))*real(ic(2,kk),rknd) 1 +y(idof(3))*real(ic(3,kk),rknd))*ss enddo enddo c ss=1.0e0_rknd/real(iord,rknd) ii=jc(iord)+3*iord-lptr(4) do k=lptr(4),ndof kk=ii+k x(idof(k))=(x(idof(1))*real(ic(1,kk),rknd) + +x(idof(2))*real(ic(2,kk),rknd) 1 +x(idof(3))*real(ic(3,kk),rknd))*ss y(idof(k))=(y(idof(1))*real(ic(1,kk),rknd) + +y(idof(2))*real(ic(2,kk),rknd) 1 +y(idof(3))*real(ic(3,kk),rknd))*ss enddo c hh=min(h(1),h(2),h(2)) do i=1,ndof rad(idof(i))=min(rad(idof(i)),hh) enddo enddo c do k=1,ndf xc=x(k) yc=y(k) r=rad(k) c call sint(ichr,nchr,k) ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd delta=r/sqrt(1.0e0_rknd+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_iknd,q,t,2_iknd) enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine title0(title,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q character(len=80) :: title,ichr cy c draw the title for the picture c call linit(t,q) size=t(14) xl=t(15)-size/2.0e0_rknd xr=t(15)+size/2.0e0_rknd if(isw==1) xr=xr+0.5e0_rknd yb=t(16)+size/2.0e0_rknd yt=t(16)+t(3)/2.0e0_rknd yl=yb+(yt-yb)*0.25e0_rknd yr=yb+(yt-yb)*0.75e0_rknd call fstr(ichr,nchr,title,0_iknd) call htext(xl,yl,xr,yr,nchr,ichr,0_iknd,q,t,2_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine gphplt(ip,rp,sp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(25) :: jp real(kind=rknd), dimension(10) :: red,green,blue real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(3,50) :: atime real(kind=rknd), allocatable, dimension(:) :: ptime,pstat character(len=80), dimension(100) :: sp cy c storage allocation c call setcom c ip(25)=0 c do i=1,25 jp(i)=0 enddo iprob=abs(ip(6)) mxcolr=max(2,ip(51)) igrsw=ip(54) if(igrsw>6.or.igrsw<-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)=min(mxcolr,jp(5)+2) jp(10)=igrsw jp(12)=mpisw iisw=0 if(mpisw==1) then iisw=1 allocate(ptime(nproc),pstat(4*nproc)) if(abs(igrsw)==2) call extim(atime,ptime) if(igrsw==-3) call exstat(rp,pstat) mpirgn=ip(47) if(mpirgn/=0) then if(mpirgn/=irgn) go to 10 mpisw=-1 jp(12)=mpisw else if(irgn/=1) go to 10 endif endif c jp(13)=ip(64) jp(14)=ip(65) jp(15)=ip(66) c call clrmap(red,green,blue,jp) c call pltutl(jp(18),red,green,blue) c call pgraph(jp,ip,rp,sp,atime,ptime,pstat) c call pltutl(-1_iknd,red,green,blue) c sp(11)='gphplt: ok' ip(25)=0 10 if(iisw==1) deallocate(ptime,pstat) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pgraph(jp,ip,rp,sp,atime,ptime,pstat) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), save :: len=50 real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(3,*) :: atime real(kind=rknd), dimension(*) :: ptime real(kind=rknd), dimension(4,*) :: pstat character(len=80), dimension(100) :: sp common /pltmg7/time(3,50),hist(22,30) cy c output graphs c iprob=jp(7) igrsw=jp(10) mpisw=jp(12) c c newton, mg history, ilu statistics c if(abs(igrsw)<=1) then call pframe(4_iknd) call title0(sp(3),0_iknd) if(igrsw==0) call nwtplt(hist(1,11),jp) c*** if(igrsw==0) call nwtprt(hist(1,11)) if(igrsw==1) call hbplt(hist(1,7),4_iknd,1_iknd,jp) if(igrsw==-1) call kaplt(ip,jp) call pframe(-4_iknd) c call pframe(2_iknd) if(igrsw/=1) then call hbplt(hist(1,7),4_iknd,1_iknd,jp) else call kaplt(ip,jp) endif call pframe(-2_iknd) c call pframe(3_iknd) if(igrsw/=0) then call nwtplt(hist(1,11),jp) else call kaplt(ip,jp) endif call pframe(-3_iknd) c c timing statistics c else if(abs(igrsw)==2) then if(mpisw/=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_iknd) call title0(sp(3),0_iknd) if(igrsw==2) call timplt(atime,jp) if(igrsw==-2) call pieplt(atime,jp) call pframe(-4_iknd) c call pframe(2_iknd) if(igrsw==2) call pieplt(atime,jp) if(igrsw==-2) call subplt(atime,jp) call pframe(-2_iknd) c call pframe(3_iknd) if(mpisw==1) then call aveplt(ptime,jp) c*** call aveprt(ptime,jp) else call kaplt(ip,jp) cc call nwtplt(hist(1,11),jp) endif call pframe(-3_iknd) c c continuation path / time step history c else if(igrsw==3) then if(iprob==3.or.iprob==7) then call pframe(4_iknd) call title0(sp(3),0_iknd) if(iprob==3) call pthplt(jp) if(iprob==7) call tmhist(jp,1_iknd) call pframe(-4_iknd) else if(iprob==2.or.iprob==4 + .or.iprob==5.or.iprob==6) then call pframe(5_iknd) call title0(sp(3),0_iknd) call ipmplt(jp) call pframe(-5_iknd) endif c call pframe(2_iknd) if(iprob==3) call legnd6(jp,2_iknd) if(iprob==2) call legnd6(jp,4_iknd) if(iprob>=4.and.iprob<=6) call legnd6(jp,4_iknd) if(iprob==7) call legnd6(jp,3_iknd) call pframe(-2_iknd) c call pframe(3_iknd) if(iprob==3) call hbplt(hist(1,14),1_iknd,2_iknd,jp) if(iprob==7) call tmhist(jp,2_iknd) call pframe(-3_iknd) c c load balance c else if(igrsw==-3) then call pframe(4_iknd) call title0(sp(3),0_iknd) call lbplt(jp,pstat,1_iknd) call pframe(-4_iknd) c call pframe(2_iknd) call lbplt(jp,pstat,0_iknd) call pframe(-2_iknd) c call pframe(3_iknd) call hbplt(hist(1,27),4_iknd,3_iknd,jp) call pframe(-3_iknd) c c error estimates c else if(abs(igrsw)==4) then call pframe(4_iknd) call title0(sp(3),0_iknd) call pframe(-4_iknd) c i1=(12-igrsw)/8 i2=3-i1 call pframe(5_iknd) call errplt(hist,i1,jp) call pframe(-5_iknd) c call pframe(2_iknd) call legnd6(jp,1_iknd) call pframe(-2_iknd) c call pframe(3_iknd) call errplt(hist,i2,jp) call pframe(-3_iknd) c c ip, rp, sp arrays c else if(abs(igrsw)>=5.and.abs(igrsw)<=6) then call pframe(1_iknd) call title0(sp(3),1_iknd) if(igrsw==5) call prtip(ip,jp) if(igrsw==-5) call prtsp(sp,jp) if(igrsw==6) call prtrp(rp,jp) call pframe(-1_iknd) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine prtip(ip,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: ip,ic integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(3) :: icolor real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q character(len=15), dimension(300) :: name0 character(len=15), dimension(100) :: name character(len=80) :: ichr cy c print ip array c call linit(t,q) mxcolr=jp(17) if(mxcolr>=8) then icolor(1)=2 icolor(2)=ccolor(2_iknd,0_iknd,jp) icolor(3)=ccolor(6_iknd,0_iknd,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)=='i') then call cint(name0(i),3_iknd,indx,jerr) name(indx)(4:10)=name0(i)(4:10) if(name0(i)(12:13)==' ') then ic(indx)=icolor(2) else ic(indx)=icolor(3) endif endif enddo c size=t(14) dy=size/25.0e0_rknd dx=(size+0.5e0_rknd)/4.0e0_rknd h=min(dy*0.9e0_rknd,dx/20.0e0_rknd) c do i=1,25 do j=1,4 k=(j-1)*25+i xl=real(j-1,rknd)*dx+.05e0_rknd+dx/10.0e0_rknd xr=xl+dx/2.0e0_rknd yl=0.95e0_rknd-(real(i,rknd)*dy) yr=yl+h call htext(xl,yl,xr,yr,10_iknd,name(k), + -1_iknd,q,t,ic(k)) xl=xl+dx/2.0e0_rknd xr=xl+3.0e0_rknd*dx/10.0e0_rknd ichr=' ' call sint(ichr(6:6),nchr,ip(k)) m=min(nchr,6) nchr=max(6,nchr) call htext(xl,yl,xr,yr,nchr,ichr(m:m), + 1_iknd,q,t,ic(k)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine prtrp(rp,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(3) :: icolor integer(kind=iknd), dimension(100) :: ic real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(100) :: rp character(len=15), dimension(300) :: name0 character(len=15), dimension(100) :: name character(len=80) :: ichr cy c print rp array c call linit(t,q) mxcolr=jp(17) if(mxcolr>=8) then icolor(1)=2 icolor(2)=ccolor(2_iknd,0_iknd,jp) icolor(3)=ccolor(6_iknd,0_iknd,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)/='r') cycle call cint(name0(i),3_iknd,indx,jerr) name(indx)(4:10)=name0(i)(4:10) if(name0(i)(12:13)==' ') then ic(indx)=icolor(2) else ic(indx)=icolor(3) endif enddo c size=t(14) dy=size/25.0e0_rknd dx=(size+0.5e0_rknd)/4.0e0_rknd h=min(dy*0.9e0_rknd,dx/20.0e0_rknd) c do i=1,25 do j=1,4 k=(j-1)*25+i xl=real(j-1,rknd)*dx+.05e0_rknd+dx/22.0e0_rknd xr=xl+10.0e0_rknd*dx/22.0e0_rknd yl=0.95e0_rknd-(real(i,rknd)*dy) yr=yl+h call htext(xl,yl,xr,yr,10_iknd,name(k), + -1_iknd,q,t,ic(k)) xl=xr+dx/22.0e0_rknd xr=xl+9.0e0_rknd*dx/22.0e0_rknd ichr=' ' call sreal(ichr(9:9),nchr,rp(k),3_iknd,0_iknd) m=min(nchr,9) nchr=max(9,nchr) call htext(xl,yl,xr,yr,nchr,ichr(m:m), + 1_iknd,q,t,ic(k)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine prtsp(sp,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(3) :: icolor integer(kind=iknd), dimension(100) :: ic real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q character(len=15), dimension(300) :: name0 character(len=15), dimension(100) :: name character(len=80) :: ichr character(len=80), dimension(100) :: sp cy c print sp array c call linit(t,q) mxcolr=jp(17) if(mxcolr>=8) then icolor(1)=2 icolor(2)=ccolor(2_iknd,0_iknd,jp) icolor(3)=ccolor(6_iknd,0_iknd,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)=='r') isw=0 if(name0(i)(15:15)=='i') isw=0 if(isw==1) then call cint(name0(i),3_iknd,indx,jerr) name(indx)(4:10)=name0(i)(4:10) if(name0(i)(12:13)==' ') then ic(indx)=icolor(2) else ic(indx)=icolor(3) endif endif enddo c size=t(14) dy=size/25.0e0_rknd dx=(size+0.5e0_rknd)/4.0e0_rknd h=min(dy*0.9e0_rknd,dx/20.0e0_rknd) c do i=1,25 do j=1,2 k=(j-1)*25+i xl=real(j-1,rknd)*dx*2.0e0_rknd + +.05e0_rknd+dx/10.0e0_rknd xr=xl+dx/2.0e0_rknd yl=0.95e0_rknd-(real(i,rknd)*dy) yr=yl+h call htext(xl,yl,xr,yr,10_iknd,name(k), + -1_iknd,q,t,ic(k)) xl=xl+dx/2.0e0_rknd xr=xl+1.5e0_rknd*dx call fstr(ichr,nchr,sp(k),0_iknd) if(nchr>0) call htext(xl,yl,xr,yr,nchr,ichr, + -1_iknd,q,t,ic(k)) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lbplt(jp,pstat,ipix) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(3) :: icolor integer(kind=iknd) :: ccolor real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(4) :: sfact real(kind=rknd), dimension(4,*) :: pstat real(kind=rknd), dimension(10) :: x,y,z,sr character(len=80) :: ichr character(len=80), save, dimension(2) :: label cy data label/'dofs','error'/ c c graph error c ntf=jp(1) if(ntf<=0) return nproc=jp(2) if(ipix==1) then jbeg=3 jend=4 icolor(1)=ccolor(2_iknd,0_iknd,jp) icolor(2)=ccolor(6_iknd,0_iknd,jp) else jbeg=1 jend=2 icolor(1)=ccolor(3_iknd,0_iknd,jp) icolor(2)=ccolor(1_iknd,0_iknd,jp) endif smx=0.0e0_rknd smn=0.0e0_rknd s2=log(2.0e0_rknd) do j=jbeg,jend sr(j)=0.0e0_rknd do i=1,nproc sr(j)=sr(j)+pstat(j,i) enddo if(sr(j)<=0.0e0_rknd) return sr(j)=real(nproc,rknd)/sr(j) do i=1,nproc ss=log(pstat(j,i)*sr(j))/s2 smx=max(smx,ss) smn=min(smn,ss) enddo enddo c call linit(t,q) size=t(14) xshift=t(15)-size/2.0e0_rknd yshift=t(16)-size/2.0e0_rknd zshift=t(5) t(1)=xshift t(2)=yshift t(3)=size sfact(1)=0.8e0_rknd/sqrt(2.0e0_rknd) sfact(2)=0.8e0_rknd sfact(3)=0.6e0_rknd sfact(4)=0.6e0_rknd c c set up input arrays c h=0.025e0_rknd h2=h/2.0e0_rknd xl=3.0e0_rknd*h xr=1.0e0_rknd-xl yl=xl yr=xr jmin=0 jmax=jmin+nproc+1 numx=jmax+1 imin=int(smn) if(smnreal(imax,rknd)) imax=imax+1 if(jmax-jmin<=12) then ix=1 else if(jmax-jmin<=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<=6) then numy=imax-imin+1 iy=1 else if(imax-imin<=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_rknd*h yyr=yyl+h ym=yyl+h2 hx=(xr-xl)/3.5e0_rknd do j=1,2 call fstr(ichr,nchr,label(j),0_iknd) ichr(nchr+1:nchr+1)=' ' xxl=xl+real(j-1,rknd)*hx xxr=xxl+real(nchr,rknd)*h xxm=xxr+h dxm=h dym=h itype=j+2 call symbl(xxm,ym,dxm,dym,itype,icolor(j),t) call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) 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)/real(jmax-jmin,rknd) dy=(yr-yl)/real(imax-imin,rknd) do j=jbeg,jend itype=j-jbeg+3 hh=h*sfact(itype) ic=2 if(nproc>64) ic=icolor(j-jbeg+1) do i=1,nproc xs=xl+dx*real(i,rknd) ss=log(pstat(j,i)*sr(j))/s2 ys=yl+dy*(ss-real(imin,rknd)) xx=xs*size+xshift yy=ys*size+yshift if(nproc<=64) + call symbl(xs,ys,hh,hh,itype,icolor(j-jbeg+1),t) c x(2)=xx y(2)=yy z(2)=zshift if(i>1) call pline(x,y,z,2_iknd,ic) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine timplt(time,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(2) :: icolor,jcolor integer(kind=iknd), dimension(50) :: map integer(kind=iknd), dimension(10) :: mcic,iptr integer(kind=iknd), save, dimension(10) :: order real(kind=rknd), dimension(3,*) :: time real(kind=rknd), dimension(5) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(2,50) :: t0 character(len=80) :: ichr character(len=80), dimension(36) :: name character(len=80), save, dimension(2) :: label character(len=80), dimension(50) :: name0 character(len=80), dimension(10) :: lab0 cy 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>=8) then icolor(1)=ccolor(6_iknd,0_iknd,jp) icolor(2)=ccolor(2_iknd,0_iknd,jp) jcolor(1)=icolor(1) jcolor(2)=icolor(2) else icolor(1)=ccolor(mxcolr-2_iknd,0_iknd,jp) if(mxcolr==4) then icolor(2)=ccolor(1_iknd,0_iknd,jp) else icolor(2)=ccolor(2_iknd,0_iknd,jp) endif jcolor(1)=2 jcolor(2)=2 endif size=t(14) zshift=t(5) xx=t(15)-size/2.0e0_rknd yy=t(16)-size/2.0e0_rknd c do i=1,ll+1 iptr(i)=0 enddo do i=1,num0 if(time(2,i)>0.0e0_rknd) 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_rknd s2=0.0e0_rknd do i=1,num0-1 if(time(2,i)>0.0e0_rknd) 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==0.0e0_rknd) return ss=1.0e0_rknd/abs(s2) c xxl=xx xxr=xx+size yyb=yy yyt=yy+size dx=(xxr-xxl)/4.3e0_rknd dy=(yyt-yyb)/(real(num,rknd)+3.75e0_rknd) h=size/43.0e0_rknd h2=h/2.0e0_rknd c c banner c yl=yyt-dy yr=yl+h ym=yl+h2 hx=(xxr-xxl)/4.0e0_rknd do j=1,2 call fstr(ichr,nchr,label(j),0_iknd) xl=xxl+real(j-1,rknd)*hx xr=xl+real(nchr,rknd)*h xm=xr+h2 call symbl(xm,ym,h,h,1_iknd,icolor(j),t) call htext(xl,yl,xr,yr,nchr,ichr,0_iknd,q,t,2_iknd) enddo c c horizontal axis c do i=1,5 z(i)=zshift enddo x(1)=xxl+2.2e0_rknd*dx x(2)=xxr x(3)=x(2) x(4)=x(1) x(5)=x(1) y(1)=yyt-(real(num,rknd)+1.75e0_rknd)*dy y(2)=y(1) y(3)=yyt-1.75e0_rknd*dy y(4)=y(3) y(5)=y(1) call pline(x,y,z,5_iknd,2_iknd) dd=(xxr-xxl-2.2e0_rknd*dx)/5.0e0_rknd do i=1,6 k=(i-1)*20 call sint(ichr,nchr,k) x(1)=xxl+2.2e0_rknd*dx+real(i-1,rknd)*dd x(2)=x(1) y(1)=yyt-(real(num,rknd)+1.75e0_rknd)*dy y(2)=y(1)-0.02e0_rknd*size call pline(x,y,z,2_iknd,2_iknd) xl=x(1)-real(nchr,rknd)*h/2.0e0_rknd xr=x(1)+real(nchr,rknd)*h/2.0e0_rknd yl=y(2)-2.0e0_rknd*h yr=y(2)-h call htext(xl,yl,xr,yr,nchr,ichr,0_iknd,q,t,2_iknd) enddo c do i=1,num c c names c call fstr(ichr,nchr,name(i),0_iknd) xl=xxl xr=xl+0.6e0_rknd*dx yl=yyt-real(i+1,rknd)*dy-0.75e0_rknd*dy yr=yl+h call htext(xl,yl,xr,yr,6_iknd,ichr,-1_iknd,q,t,2_iknd) if(max(t0(1,i),t0(2,i))<=0.0e0_rknd) cycle c c times c do k=1,2 xl=xr+0.05e0_rknd*dx xr=xl+0.7e0_rknd*dx if(t0(k,i)<=0.0e0_rknd) cycle ichr=' ' if(t0(k,i)>10.0e0_rknd) then ii=int(log10(t0(k,i)))+2 else ii=2 endif call sfix(ichr(6:6),nchr,t0(k,i),ii) if(nchr<8) then ii=nchr-2 nchr=8 else ii=6 endif call htext(xl,yl,xr,yr,nchr,ichr(ii:ii), + 1_iknd,q,t,jcolor(k)) enddo c c histogram c do k=2,1,-1 if(t0(k,i)>0.0e0_rknd) then xp=xr+0.1e0_rknd*dx if(k==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_iknd,icolor(k)) call pline(x,y,z,5_iknd,2_iknd) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine timpl0(time,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(50) :: icolor,map integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(10) :: mcic integer(kind=iknd), dimension(8) :: iptr integer(kind=iknd), save, dimension(7) :: order real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3,*) :: time real(kind=rknd), dimension(50) :: tim1,tim2 character(len=80) :: ichr character(len=80), dimension(10) :: label character(len=80), dimension(50) :: name,name0 cy 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_rknd yshift=t(16)-size/2.0e0_rknd 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)>0.0e0_rknd) 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_rknd tot1=0.0e0_rknd do i=1,len0 if(time(2,i)>0.0e0_rknd) 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_iknd,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<=0.0e0_rknd) return c xl=t(15)-size/2.0e0_rknd yt=t(16)+size/2.0e0_rknd hf=max(24.0e0_rknd,real(len+10,rknd)) h=size/hf ss=min(hf/real(len+1,rknd),4.0e0_rknd) dx=(size-4.0e0_rknd*h)/5.0e0_rknd do i=1,len yyl=yt-h*real(i,rknd)*ss yyr=yyl+h xm=xl+h/2.0e0_rknd ym=yyl+h/2.0e0_rknd call symbl(xm,ym,h,h,1_iknd,icolor(i),t) call fstr(ichr,nchr,name(i),0_iknd) xxl=xl+h*1.5e0_rknd xxr=xxl+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr, + -1_iknd,q,t,2_iknd) c tm=tim1(i) if(tm>0.0e0_rknd) then k=2 if(tm>10.0e0_rknd) k=int(log10(tm))+2 call sfix(ichr,nchr,tm,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr, + 1_iknd,q,t,2_iknd) c fr=tim1(i)/tot2*100.0e0_rknd k=1 if(fr>=10.0e0_rknd) k=2 call sfix(ichr,nchr,fr,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr, + 1_iknd,q,t,2_iknd) else xxr=xxr+2.0e0_rknd*dx endif c tm=tim2(i) k=2 if(tm>10.0e0_rknd) k=int(log10(tm))+2 call sfix(ichr,nchr,tm,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr, + 1_iknd,q,t,2_iknd) c fr=tim2(i)/tot2*100.0e0_rknd k=1 if(fr>=10.0e0_rknd) k=2 call sfix(ichr,nchr,fr,k) xxl=xxr+h xxr=xxr+dx call htext(xxl,yyl,xxr,yyr,nchr,ichr, + 1_iknd,q,t,2_iknd) c xm=xxr+h*1.5e0_rknd ym=yyl+h/2.0e0_rknd call symbl(xm,ym,h,h,1_iknd,icolor(i),t) c enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pieplt(time,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(20) :: icolor integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(50) :: map integer(kind=iknd), dimension(10) :: mcic real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3,*) :: time real(kind=rknd), dimension(21) :: th real(kind=rknd), dimension(20) :: dt,tim real(kind=rknd), dimension(90) :: x,y,z character(len=80) :: ichr character(len=80), dimension(10) :: label character(len=80), dimension(50) :: name cy 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_rknd yshift=t(16)-size/2.0e0_rknd 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_iknd,jp) tim(i)=0.0e0_rknd enddo do i=1,len tim(map(i))=tim(map(i))+time(2,i) enddo tot=0.0e0_rknd do i=1,num tot=tot+tim(i) enddo if(tot<=0.0e0_rknd) return pi=3.141592653589793e0_rknd th(1)=pi/2.0e0_rknd do i=1,num fr=tim(i)/tot dt(i)=fr*2.0e0_rknd*pi th(i+1)=th(i)+dt(i) enddo c c make pie chart c xcen=0.5e0_rknd ycen=0.4e0_rknd rad=0.35e0_rknd dd=pi/32.0e0_rknd 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)/real(m+1,rknd) theta=th(i) do j=1,m+2 ang=theta+dtheta*real(j-1,rknd) 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_iknd,icolor(i)) call pline(x,y,z,m+4_iknd,2_iknd) enddo c xl=t(15)-size/2.0e0_rknd yt=t(16)+size/2.0e0_rknd h=size/30.0e0_rknd h=size/27.0e0_rknd mm=num/2 do i=1,mm yyl=yt-h*real(i,rknd)*1.5e0_rknd yyr=yyl+h xs=xl xr=t(15) ii=i do j=1,2 xm=xs ym=yyl+h/2.0e0_rknd call symbl(xm,ym,h,h,1_iknd,icolor(ii),t) call fstr(ichr,nchr,label(ii),0_iknd) xxl=xs+h xxr=xxl+real(nchr,rknd)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + -1_iknd,q,t,2_iknd) fr=tim(ii)/tot*100.0e0_rknd k=1 if(fr>=10.0e0_rknd) k=2 call sfix(ichr,nchr,fr,k) xxr=xr-h if(j==2) xxr=xr xxl=xxr-real(nchr,rknd)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + 1_iknd,q,t,2_iknd) xs=t(15)+h xr=t(15)+size/2.0e0_rknd ii=num+1-i enddo enddo c label(num+1)='total time -- ' call fstr(ichr,nchr,label(num+1),0_iknd) xxl=xl+h xxr=xxl+real(nchr,rknd)*h yyl=yt yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + -1_iknd,q,t,2_iknd) k=2 if(tot>10.0e0_rknd) k=int(log10(tot))+2 call sfix(ichr,nchr,tot,k) ichr(nchr+1:nchr+8)=' seconds' xxl=t(15) xxr=xxl+real(nchr+8,rknd)*h call htext(xxl,yyl,xxr,yyr,nchr+8_iknd,ichr, + -1_iknd,q,t,2_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine subplt(time,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(50) :: icolor,map integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(10) :: mcic integer(kind=iknd), dimension(7) :: iptr real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3,*) :: time real(kind=rknd), dimension(50) :: tim character(len=80) :: ichr,nn character(len=80), dimension(10) :: label character(len=80), dimension(50) :: name,name0 cy 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_rknd yshift=t(16)-size/2.0e0_rknd 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)>0.0e0_rknd) 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_rknd do i=1,len0 if(time(2,i)>0.0e0_rknd) then k=map(i) name(iptr(k))=name0(i) tim(iptr(k))=time(2,i) icolor(iptr(k))=ccolor(mcic(k),0_iknd,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<=0.0e0_rknd) 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_rknd yt=t(16)+size/2.0e0_rknd hf=24.0e0_rknd h=size/hf mrt=iptr(mm+1)-iptr(1) mlt=iptr(num+1)-iptr(mm+1) mx=max(mrt,mlt) ss=min(hf/real(mx+1,rknd),4.0e0_rknd) do i=1,mx yyl=yt-h*real(i,rknd)*ss yyr=yyl+h xr=t(15) xs=xl ii=i if(i>=iptr(mm+1)) ii=0 do j=1,2 if(ii>0) then xm=xs ym=yyl+h/2.0e0_rknd call symbl(xm,ym,h,h,1_iknd,icolor(ii),t) call fstr(ichr,nchr,name(ii),0_iknd) xxl=xs+h xxr=xxl+real(nchr,rknd)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + -1_iknd,q,t,2_iknd) fr=tim(ii)/tot*100.0e0_rknd k=1 if(fr>=10.0e0_rknd) k=2 call sfix(ichr,nchr,fr,k) xxr=xr-h if(j==2) xxr=xr xxl=xxr-real(nchr,rknd)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + 1_iknd,q,t,2_iknd) endif xs=t(15)+h xr=t(15)+size/2.0e0_rknd ii=iptr(num+1)-i if(iireal(imax,rknd)) imax=imax+1 if(jmax-jmin<=12) then ix=1 else if(jmax-jmin<=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<=6) then numy=imax-imin+1 iy=1 else if(imax-imin<=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_rknd*h yyr=yyl+h xxl=xl ichr(1:4)='min ' val=tmn do j=1,2 if(val>10.0e0_rknd) then ii=int(log10(val))+2 else ii=2 endif call sfix(ichr(5:5),nchr,val,ii) nchr=nchr+4 xxr=xxl+real(nchr,rknd)*h call htext(xxl,yyl,xxr,yyr,nchr,ichr, + -1_iknd,q,t,2_iknd) xxl=(xl+xr)/2.0e0_rknd 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)/real(jmax-jmin,rknd) dy=(yr-yl)/real(imax-imin,rknd) itype=2 hh=h*sfact(itype) do i=1,nproc xs=xl+dx*real(i,rknd) ss=log(ptime(i)*ave)/s2 ys=yl+dy*(ss-real(imin,rknd)) 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>1) call pline(x,y,z,2_iknd,2_iknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine timdat(num0,name0,jcat,len0,label0,color0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(50) :: icat integer(kind=iknd), dimension(*) :: jcat,color0 integer(kind=iknd), save, dimension(10) :: color integer(kind=iknd), save :: num,len character(len=80), dimension(*) :: name0,label0 character(len=80), save, dimension(10) :: label character(len=80), save, dimension(50) :: name cy data num/36/ 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)/'hunfrm',2/ data name( 5),icat( 5)/'punfrm',2/ data name( 6),icat( 6)/'mvemsh',2/ data name( 7),icat( 7)/'errest',1/ data name( 8),icat( 8)/'cbump ',1/ data name( 9),icat( 9)/'cdlfn ',1/ data name(10),icat(10)/'expth ',3/ data name(11),icat(11)/'exflag',3/ data name(12),icat(12)/'bcast ',3/ data name(13),icat(13)/'ldbal ',3/ data name(14),icat(14)/'lbev ',3/ data name(15),icat(15)/'cutr ',3/ data name(16),icat(16)/'paste ',3/ data name(17),icat(17)/'paste1',3/ data name(18),icat(18)/'trigen',2/ c data name(19),icat(19)/'setgrb',5/ data name(20),icat(20)/'setgr2',5/ data name(21),icat(21)/'ja2ja ',5/ data name(22),icat(22)/'sfbilu',5/ data name(23),icat(23)/'sfhb ',5/ data name(24),icat(24)/'mg ',5/ data name(25),icat(25)/'blk3 ',5/ data name(26),icat(26)/'blk4 ',5/ data name(27),icat(27)/'blk5 ',5/ data name(28),icat(28)/'linsys',6/ data name(29),icat(29)/'rgnsys',6/ data name(30),icat(30)/'cev ',4/ data name(31),icat(31)/'swbrch',4/ data name(32),icat(32)/'predct',4/ data name(33),icat(33)/'tpick ',4/ data name(34),icat(34)/'tpickd',4/ data name(35),icat(35)/'pltmg ',4/ c data name(36),icat(36)/'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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine errplt(hist,igraph,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(22) :: ic integer(kind=iknd), save, dimension(6) :: icc integer(kind=iknd) :: ccolor real(kind=rknd), dimension(22) :: rn,e,w real(kind=rknd), dimension(25) :: t,x,y,z,xn,yn,zn real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(22,*) :: hist character(len=80) :: ichr character(len=80), save, dimension(4) :: label cy 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_rknd yy=t(16)-size/2.0e0_rknd t(1)=xx t(2)=yy t(3)=size mpisw=jp(12) ishift=0 if(mpisw==1) ishift=18 c num=int(hist(mxhist+2,ishift+1)) if(num<=0) return c c set up input arrays c e1=abs(hist(mxhist+2,ishift+igraph+2)) if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1 do i=1,num rn(i)=log10(hist(i,ishift+1)) w(i)=log10(hist(i,ishift+5)) e(i)=0.0e0_rknd qq=abs(hist(i,ishift+igraph+2))*e1 if(qq>0.0e0_rknd) e(i)=log10(qq) ii=int(hist(i,ishift+2))+2 if(ii<1) ii=1 if(ii>6) ii=6 if(mpisw==1) ii=2 ic(i)=ccolor(icc(ii),0_iknd,jp) enddo c wmx=w(1) wmn=w(1) rmx=rn(1) emx=e(1) emn=emx do i=1,num rmx=max(rn(i),rmx) wmx=max(w(i),wmx) wmn=min(w(i),wmn) emx=max(e(i),emx) emn=min(e(i),emn) enddo c numx=max(5,int(rmx)+2) c iminy=int(wmn) if(wmnreal(imaxy,rknd)) imaxy=imaxy+1 if(imaxy-iminy<4) then iminy=iminy-(4+iminy-imaxy)/2 imaxy=iminy+4 endif numy=imaxy-iminy+1 c iminz=int(emn) if(emnreal(imaxz,rknd)) imaxz=imaxz+1 if(imaxz-iminz<4) then iminz=iminz-(4+iminz-imaxz)/2 imaxz=iminz+4 endif numz=imaxz-iminz+1 c h=0.025e0_rknd xl=3.0e0_rknd*h xr=1.0e0_rknd-xl yl=xl yr=xr zl=xl zr=xr c c banners c call fstr(ichr,nchr,label(igraph),0_iknd) xxl=0.0e0_rknd xxr=1.0e0_rknd yyl=1.0e0_rknd-h yyr=1.0e0_rknd call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) c c set up rotated coordinate system c call mkrot(jp(13),jp(14),jp(15),q) c xmin=min(0.0e0_rknd,q(1,1))+min(0.0e0_rknd,q(2,1)) xmax=max(0.0e0_rknd,q(1,1))+max(0.0e0_rknd,q(2,1)) ymin=min(0.0e0_rknd,q(1,2))+min(0.0e0_rknd,q(2,2)) ymax=max(0.0e0_rknd,q(1,2))+max(0.0e0_rknd,q(2,2))+q(3,2) zmin=min(0.0e0_rknd,q(1,3)) + +min(0.0e0_rknd,q(2,3)) 1 +min(0.0e0_rknd,q(3,3)) zmax=max(0.0e0_rknd,q(1,3)) + +max(0.0e0_rknd,q(2,3)) 1 +max(0.0e0_rknd,q(3,3)) c scale=size/max(xmax-xmin,ymax-ymin) xshift=xx+(size-scale*(xmax+xmin))/2.0e0_rknd yshift=yy+(size-scale*(ymax+ymin))/2.0e0_rknd zshift= (size-scale*(zmax+zmin))/2.0e0_rknd t(1)=xshift t(2)=yshift t(5)=zshift t(3)=scale c dx=(xr-xl)/real(numx-1,rknd) dz=(zr-zl)/real(numz-1,rknd) dy=(yr-yl)/real(numy-1,rknd) do i=1,num x(i)=xl+dx*rn(i) y(i)=yl+dy*(w(i)-real(iminy,rknd)) z(i)=zl+dz*(e(i)-real(iminz,rknd)) 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)>0.0e0_rknd) then call xygrid(xl,xr,yl,yr,zl,h,t,q, + numx,0_iknd,1_iknd,numy,0_iknd,4_iknd) else call pline(xn,yn,zn,num,2_iknd) endif isw=1 if(q(2,3)<0.0e0_rknd) 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_iknd) else call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1_iknd) 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)<=0.0e0_rknd) then call xygrid(xl,xr,yl,yr,zl,h,t,q, + numx,0_iknd,1_iknd,numy,0_iknd,4_iknd) else call pline(xn,yn,zn,num,2_iknd) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine nwtplt(hist,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(2) :: icolor integer(kind=iknd) :: ccolor real(kind=rknd), dimension(22,2) :: e real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(22,*) :: hist character(len=80) :: ichr character(len=80), save, dimension(6) :: label cy 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_rknd yshift=t(16)-size/2.0e0_rknd mxhist=20 t(1)=xshift t(2)=yshift t(3)=size c lab1=int(hist(mxhist+1,2)) if(lab1==-1) then lab=5 icolor(1)=ccolor(1_iknd,0_iknd,jp) icolor(2)=ccolor(3_iknd,0_iknd,jp) else if(lab1==-2) then lab=3 icolor(1)=ccolor(4_iknd,0_iknd,jp) icolor(2)=ccolor(5_iknd,0_iknd,jp) else lab=1 icolor(1)=ccolor(6_iknd,0_iknd,jp) icolor(2)=ccolor(2_iknd,0_iknd,jp) endif num1=int(hist(mxhist+1,1)) num=min(num1,mxhist) if(num<=0) return do j=1,2 e1=abs(hist(mxhist+2,j)) if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1 do i=1,num qq=abs(hist(i,j))*e1 e(i,j)=0.0e0_rknd if(qq>0.0e0_rknd) e(i,j)=log10(qq) enddo enddo c h=0.025e0_rknd h2=h/2.0e0_rknd xl=3.0e0_rknd*h xr=1.0e0_rknd-xl yl=xl yr=xr jmin=max(num1-mxhist,0) jmax=jmin+max(((num1-jmin-1)/4)*4+4,8) if(jmax-jmin==8) then numx=5 is=2 else if(jmax-jmin<=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=max(e(i,1),e(i,2),emx) emn=min(e(i,1),e(i,2),emn) enddo imin=int(emn) if(emnreal(imax,rknd)) imax=imax+1 if(imax-imin<4) then imin=imin-(4+imin-imax)/2 imax=imin+4 endif numy=imax-imin+1 c c banner c yyl=yr+1.8e0_rknd*h yyr=yyl+h ym=yyl+h2 xxl=xl-2.0e0_rknd*h do j=1,2 call fstr(ichr,nchr,label(lab+j-1),0_iknd) xxr=xxl+real(nchr,rknd)*h xm=xxr+h2 call symbl(xm,ym,h,h,1_iknd,icolor(j),t) call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) xxl=(xl+xr)/2.0e0_rknd enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin, + is,numy,imin,1_iknd) c c graph c dx=(xr-xl)/real(jmax-jmin,rknd) hx=dx/4.0e0_rknd dy=(yr-yl)/real(numy-1,rknd) do i=1,num xs=xl+dx*real(i,rknd)-hx/2.0e0_rknd do j=1,2 xm=xs+real(j-1,rknd)*hx hy=dy*(e(i,j)-real(imin,rknd)) ym=yl+hy/2.0e0_rknd call symbl(xm,ym,hx,hy,1_iknd,icolor(j),t) enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine kaplt(ip,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(5) :: icolor integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(20) :: ratio real(kind=rknd), dimension(2) :: x,y,z character(len=80) :: ichr character(len=80), save, dimension(4) :: label cy data label/'matrix','ilu','hb','lu'/ c c graph storage c nb=ip(91) if(nb<=0) return ndf=ip(90) method=ip(9) c do i=1,3 do j=1,3 q(i,j)=0.0e0_rknd enddo q(i,i)=1.0e0_rknd enddo call linit(t,q) c size=t(14) xshift=t(15)-size/2.0e0_rknd yshift=t(16)-size/2.0e0_rknd t(1)=xshift t(2)=yshift t(3)=size zshift=t(5) c num=4 icolor(1)=ccolor(5_iknd,0_iknd,jp) icolor(2)=ccolor(4_iknd,0_iknd,jp) icolor(3)=ccolor(3_iknd,0_iknd,jp) icolor(4)=ccolor(1_iknd,0_iknd,jp) icolor(5)=1 c c set up input arrays c lenja=ip(92) lenju=ip(97) lenju0=ip(95) lenjuc=ip(100) ispd=ip(8) c lena=ip(93)+ip(94) lenu=ip(93)+ip(98) lenhb=lenjuc lenu0=ip(93)+ip(96) c lenax=lena*2-ndf lenux=lenu*2-ndf lenhbx=lenjuc*2 -(nb+1) lenu0x=lenu0*2-ndf c if(ispd/=1) then lena=lenax lenu=lenux lenhb=lenhbx lenu0=lenu0x endif c if(method<0) then lenhb=0 lenhbx=0 lenjuc=0 endif if(abs(method)==2) then lenu=0 lenux=0 lenju=0 endif c ratio(1)=real(lenax,rknd)/real(ndf,rknd) ratio(2)=real(lenux,rknd)/real(ndf,rknd) ratio(3)=real(lenhbx,rknd)/real(ndf,rknd) ratio(4)=real(lenu0x,rknd)/real(ndf,rknd) c ratio(5)=real(lena,rknd)/real(lenu0,rknd) ratio(6)=real(lenu,rknd)/real(lenu0,rknd) ratio(7)=real(lenhb,rknd)/real(lenu0,rknd) ratio(8)=1.0e0_rknd c ratio(9)=real(lenja,rknd)/real(lenu0,rknd) ratio(10)=real(lenju,rknd)/real(lenu0,rknd) ratio(11)=real(lenjuc,rknd)/real(lenu0,rknd) ratio(12)=real(lenju0,rknd)/real(lenu0,rknd) c xl=t(15)-size/2.0e0_rknd yt=t(16)+size/2.0e0_rknd h=1.0e0_rknd/20.0e0_rknd h2=h/2.0e0_rknd yyl=yt do i=1,num cc yyl=yt-h*real(i,rknd)*2.0e0_rknd if(ratio(i)==0.0e0_rknd) cycle xxl=xl yyl=yyl-h*2.0e0_rknd xm=xxl+h ym=yyl+h2 call symbl(xm,ym,h,h,1_iknd,icolor(i),t) c call fstr(ichr,nchr,label(i),0_iknd) xxl=xl+3.0e0_rknd*h xxr=xxl+real(nchr,rknd)*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd) ii=3 if(ratio(i)>=10.0e0_rknd) ii=4 if(ratio(i)>=100.0e0_rknd) ii=5 call sreal(ichr,nchr,ratio(i),ii,0_iknd) xxl=xl+8.0e0_rknd*h xxr=xl+14.0e0_rknd*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1_iknd,q,t,2_iknd) fr=ratio(i+num)*100.0e0_rknd call sreal(ichr,nchr,fr,3_iknd,0_iknd) xxl=xl+15.0e0_rknd*h xxr=xl+19.0e0_rknd*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,1_iknd,q,t,2_iknd) enddo c c h=0.025e0_rknd xl=3.0e0_rknd*h xr=1.0e0_rknd-xl yl=xl yr=xl+size/2.0e0_rknd c c bar graph c hy=size/10.0e0_rknd ym=yl-hy/2.0e0_rknd do i=num,1,-1 cc ym=yl+hy*real(9-2*i,rknd)/2.0e0_rknd if(ratio(4+i)==0.0e0_rknd) cycle ym=ym+hy hx=(xr-xl)*ratio(4+i) xm=xl+hx/2.0e0_rknd call symbl(xm,ym,hx,hy,1_iknd,icolor(i),t) z(1)=zshift z(2)=z(1) x(1)=(xl+(xr-xl)*ratio(8+i))*size+xshift x(2)=x(1) y(1)=(ym-hy/2.0e0_rknd)*size+yshift y(2)=(ym+hy/2.0e0_rknd)*size+yshift call pline(x,y,z,2_iknd,2_iknd) enddo c c axis c numx=5 numy=0 ix=25 jmin=0 imin=0 iy=0 call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine hbplt(hist,numhst,lab,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(22,4) :: icolor integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(4) :: num1,num integer(kind=iknd), dimension(2,4) :: jc integer(kind=iknd) :: ccolor real(kind=rknd), dimension(22,4) :: e real(kind=rknd), dimension(22,*) :: hist real(kind=rknd), dimension(25) :: t,x,y,z real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(4) :: ave,sfact character(len=80) :: ichr character(len=80), save, dimension(3) :: rate cy data rate/'linear systems','singular vector', + 'spectral bisection'/ c c graph error c call linit(t,q) size=t(14) xshift=t(15)-size/2.0e0_rknd yshift=t(16)-size/2.0e0_rknd zshift=t(5) mxhist=20 t(1)=xshift t(2)=yshift t(3)=size jc(1,1)=ccolor(4_iknd,0_iknd,jp) jc(2,1)=ccolor(6_iknd,0_iknd,jp) jc(1,2)=ccolor(2_iknd,0_iknd,jp) jc(2,2)=ccolor(5_iknd,0_iknd,jp) jc(1,3)=ccolor(3_iknd,0_iknd,jp) jc(2,3)=ccolor(1_iknd,0_iknd,jp) jc(1,4)=1 jc(2,4)=2 sfact(1)=0.8e0_rknd/sqrt(2.0e0_rknd) sfact(2)=0.8e0_rknd sfact(3)=0.6e0_rknd sfact(4)=0.6e0_rknd 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)=min(num1(j),mxhist) if(num(j)>0) then e1=abs(hist(mxhist+2,j)) if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1 do i=1,num(j) qq=abs(hist(i,j))*e1 e(i,j)=0.0e0_rknd if(qq>0.0e0_rknd) e(i,j)=log10(qq) ee=e(i,j) if(hist(i,j)>=0.0e0_rknd) then icolor(i,j)=jc(1,j) else icolor(i,j)=jc(2,j) endif enddo ave(j)=10.0e0_rknd**(e(num(j),j)/real(num1(j),rknd)) endif enddo n1max=num1(1) n1min=num1(1) do j=1,numhst if(num1(j)>0) then n1max=max(num1(j),n1max) n1min=min(num1(j),n1min) endif enddo if(n1max==0) return c h=0.025e0_rknd h2=h/2.0e0_rknd xl=3.0e0_rknd*h xr=1.0e0_rknd-xl yl=xl yr=xr if(n1max-n1min+4<=mxhist) then jmin=max(n1max-mxhist,0) c* jmax=jmin+max(((n1max-jmin-1)/4)*4+4,8) jmax=jmin+mxhist else jmin=max(n1min-4,0) jmax=jmin+((n1max-jmin-1)/4)*4+4 endif if(jmax-jmin==8) then numx=5 is=2 else if(jmax-jmin<=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)<=0) cycle do i=1,num(j) emx=max(e(i,j),emx) emn=min(e(i,j),emn) enddo enddo imin=int(emn) if(emnreal(imax,rknd)) imax=imax+1 if(imax-imin<4) then imin=imin-(4+imin-imax)/2 imax=imin+4 endif numy=imax-imin+1 c c banners c yyl=yr+1.8e0_rknd*h yyr=yyl+h ym=yyl+h2 call fstr(ichr,nchr,rate(lab),0_iknd) xxl=h xxr=xxl+10.0e0_rknd*h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd) do j=1,numhst if(num(j)<=0) cycle call sreal(ichr,nchr,ave(j),2_iknd,0_iknd) xxl=real(6+7*j,rknd)*h xxr=xxl+5.0e0_rknd*h xm=xxl-h call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd) call symbl(xm,ym,h,h,j,jc(1,j),t) enddo c c axis c call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin, + is,numy,imin,1_iknd) c c graph c dy=(yr-yl)/real(numy-1,rknd) dx=(xr-xl)/real(jmax-jmin,rknd) do j=1,numhst hh=h*sfact(j) ishift=max(num1(j)-mxhist,0)-jmin i0=max(1,-ishift) do i=i0,num(j) xs=xl+dx*real(i+ishift,rknd) ys=yl+dy*(e(i,j)-real(imin,rknd)) 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>1) call pline(x(i0),y(i0),z(i0),nn,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pthplt(jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor real(kind=rknd), dimension(5) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q character(len=80) :: ichr character(len=80), save :: label common /pltmg6/path(101,6) cy 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_rknd yy=t(16)-size/2.0e0_rknd num=int(path(101,1)) if(num<=0) return rlmax=path(1,1) rlmin=rlmax rmax=path(1,2) rmin=rmax do i=1,num rlmax=max(rlmax,path(i,1)) rlmin=min(rlmin,path(i,1)) rmax=max(rmax,path(i,2)) rmin=min(rmin,path(i,2)) enddo dr=(rlmax-rlmin)/20.0e0_rknd if(dr==0.0e0_rknd) dr=abs(rlmax)/20.0e0_rknd if(dr==0.0e0_rknd) dr=1.0e0_rknd rlmax=rlmax+dr rlmin=rlmin-dr dr=(rmax-rmin)/20.0e0_rknd if(dr==0.0e0_rknd) dr=abs(rmax)/20.0e0_rknd if(dr==0.0e0_rknd) dr=1.0e0_rknd rmax=rmax+dr rmin=rmin-dr c h=0.025e0_rknd*size xl=xx+7.0e0_rknd*h xr=xx+size-h yb=yy+2.5e0_rknd*h yt=yb+size-5.5e0_rknd*h c srl=(xr-xl)/(rlmax-rlmin) sr=(yt-yb)/(rmax-rmin) xshift=(xr+xl)/2.0e0_rknd-srl*(rlmax+rlmin)/2.0e0_rknd yshift=(yb+yt)/2.0e0_rknd-sr*(rmax+rmin)/2.0e0_rknd c c banners c call fstr(ichr,nchr,label,0_iknd) xxl=xx xxr=xx+size yyl=yy+size-1.25e0_rknd*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) 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_iknd,2_iknd) dx=(xr-xl)/10.0e0_rknd dr=(rlmax-rlmin)/10.0e0_rknd do i=1,11 x(1)=xl+real(i-1,rknd)*dx x(2)=x(1) y(1)=yb y(2)=yb-0.5e0_rknd*h call pline(x,y,z,2_iknd,2_iknd) if(i-(i/2)*2==0) cycle xk=rlmin+real(i-1,rknd)*dr call sreal(ichr,nchr,xk,3_iknd,0_iknd) xxl=x(1)-real(nchr,rknd)*h/4.0e0_rknd xxr=x(1)+real(nchr,rknd)*h/4.0e0_rknd yyl=y(2)-1.75e0_rknd*h/2.0e0_rknd yyr=yyl+h/2.0e0_rknd call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) enddo c c vertical axis c x(1)=xl x(2)=x(1) y(1)=yb y(2)=yt call pline(x,y,z,2_iknd,2_iknd) dy=(yt-yb)/10.0e0_rknd dr=(rmax-rmin)/10.0e0_rknd do i=1,11 xk=rmin+real(i-1,rknd)*dr call sreal(ichr,nchr,xk,3_iknd,0_iknd) x(1)=xl x(2)=x(1)-0.5e0_rknd*h y(1)=yb+real(i-1,rknd)*dy y(2)=y(1) call pline(x,y,z,2_iknd,2_iknd) xxl=max(x(1)-real(nchr+3,rknd)*h/2.0e0_rknd,xx) xxr=x(1)-h yyl=y(1)-h/4.0e0_rknd yyr=y(1)+h/4.0e0_rknd call htext(xxl,yyl,xxr,yyr,nchr,ichr,1_iknd,q,t,2_iknd) enddo c c mark points c do i=1,num x(1)=path(i,1)*srl+xshift-h/2.0e0_rknd 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_rknd y(2)=y(1) y(3)=y(1)+h y(4)=y(3) y(5)=y(1) iic=int(path(i,6)) if(iic>6) cycle ic=ccolor(iic,0_iknd,jp) call pfill(x,y,z,4_iknd,ic) call pline(x,y,z,5_iknd,2_iknd) enddo c c draw interpolant c if(num>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cpth(l0,l1,r0,r1,l0dot,l1dot,r0dot,r1dot,it1, + xscale,yscale,xshift,yshift,zshift,xl,xr,yb,yt) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd) :: l0,l1,l0dot,l1dot real(kind=rknd), dimension(101) :: x,y,z cy c compute the parabola thru two points and evaluate c if(it1>=7) return dr=r1-r0 dl=l1-l0 al=sqrt(dr*dr+dl*dl) if(al==0.0e0_rknd) 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==1.or.it1==3) go to 10 w0=2.0e0_rknd*yd0*yd1 w1=-(xd0*yd1+xd1*yd0) a=sqrt(w0*w0+w1*w1) if(abs(a)<1.0e-2_rknd) go to 10 c2=w0/a s2=w1/a ud0=c2*xd0+s2*yd0 if(abs(ud0)<=1.0e-2_rknd) 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_rknd/(4.0e0_rknd*b*ud0) t=b*vd0/ud0 pr=r0+(c*2.0e0_rknd*ud0-s*vd0)*t pl=l0+(c*vd0+s*2.0e0_rknd*ud0)*t c c compute number of points c num=int(abs(r0-r1)*yscale*50.0e0_rknd) + +int(abs(l0-l1)*xscale*50.0e0_rknd) num=min(101,num) if(num<=2) go to 10 u0=c*(r0-pr)+s*(l0-pl) u1=c*(r1-pr)+s*(l1-pl) h=(u1-u0)/real(num-1,rknd) do i=1,num u=u0+real(i-1,rknd)*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)xr) go to 10 if(y(i)yt) go to 10 enddo call pline(x,y,z,num,2_iknd) 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_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tmhist(jp,iptr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor real(kind=rknd), dimension(5) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(101) :: rr character(len=80) :: ichr character(len=80), save, dimension(2) :: label common /pltmg6/path(101,6) cy 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_rknd yy=t(16)-size/2.0e0_rknd zshift=t(5) num=int(path(101,1)) if(num<=1) return tmin=path(1,1) tmax=path(num,1) if(tmax<=tmin) return rr(1)=0.0e0_rknd rr(2)=log10(path(2,iptr+1)) rmax=rr(2) rmin=rmax do i=2,num rr(i)=log10(path(i,iptr+1)) rmax=max(rmax,rr(i)) rmin=min(rmin,rr(i)) enddo irmax=int(rmax)+1 irmin=int(rmin)-1 c h=0.025e0_rknd*size xl=xx+7.0e0_rknd*h xr=xx+size-h yb=yy+2.5e0_rknd*h yt=yb+size-5.5e0_rknd*h c st=(xr-xl)/(tmax-tmin) sr=(yt-yb)/real(irmax-irmin,rknd) xshift=(xr+xl)/2.0e0_rknd-st*(tmax+tmin)/2.0e0_rknd yshift=(yb+yt)/2.0e0_rknd-sr*real(irmax+irmin,rknd)/2.0e0_rknd c c banners c call fstr(ichr,nchr,label(iptr),0_iknd) xxl=xx xxr=xx+size yyl=yy+size-1.25e0_rknd*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) 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_iknd,2_iknd) dx=(xr-xl)/10.0e0_rknd dt=(tmax-tmin)/10.0e0_rknd do i=1,11 x(1)=xl+real(i-1,rknd)*dx x(2)=x(1) y(1)=yb y(2)=yb-0.5e0_rknd*h call pline(x,y,z,2_iknd,2_iknd) if(i-(i/2)*2==0) cycle xk=tmin+real(i-1,rknd)*dt call sreal(ichr,nchr,xk,3_iknd,0_iknd) xxl=x(1)-real(nchr,rknd)*h/4.0e0_rknd xxr=x(1)+real(nchr,rknd)*h/4.0e0_rknd yyl=y(2)-1.75e0_rknd*h/2.0e0_rknd yyr=yyl+h/2.0e0_rknd call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) enddo c c vertical axis c x(1)=xl x(2)=x(1) y(1)=yb y(2)=yt call pline(x,y,z,2_iknd,2_iknd) dy=(yt-yb)/10.0e0_rknd if(irmax-irmin<10) then nn=irmax-irmin+1 inc=1 else nn=(irmax-irmin)/2+1 inc=2 endif dy=(yt-yb)/real(nn-1,rknd) do i=1,nn k=irmin+(i-1)*inc call sint(ichr,nchr,k) x(1)=xl x(2)=x(1)-0.5e0_rknd*h y(1)=yb+real(i-1,rknd)*dy y(2)=y(1) call pline(x,y,z,2_iknd,2_iknd) xxl=max(x(1)-real(nchr+3,rknd)*h/2.0e0_rknd,xx) xxr=x(1)-h yyl=y(1)-h/4.0e0_rknd yyr=y(1)+h/4.0e0_rknd call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd) enddo c c mark points c do i=2,num x(1)=path(i,1)*st+xshift-h/2.0e0_rknd 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_rknd y(2)=y(1) y(3)=y(1)+h y(4)=y(3) y(5)=y(1) ic=ccolor(4_iknd,0_iknd,jp) if(int(path(i,6))<0) ic=ccolor(6_iknd,0_iknd,jp) call pfill(x,y,z,4_iknd,ic) call pline(x,y,z,5_iknd,2_iknd) if(i>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_iknd,2_iknd) endif enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ipmplt(jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(100) :: ic integer(kind=iknd), save, dimension(6) :: icc integer(kind=iknd) :: ccolor real(kind=rknd), dimension(100) :: rn,rho,rmu,x,y,z,xn,yn,zn real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q character(len=80) :: ichr character(len=80), save :: label common /pltmg6/path(101,6) cy 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_rknd yy=t(16)-size/2.0e0_rknd t(1)=xx t(2)=yy t(3)=size c num=int(path(101,1)) if(num<=0) return c c set up input arrays c do i=1,num rmu(i)=log10(path(i,1)) rho(i)=log10(abs(path(i,2))) rn(i)=log10(path(i,3)) ii=int(path(i,6)) if(ii<1) ii=1 if(ii>6) ii=6 ic(i)=ccolor(icc(ii),0_iknd,jp) enddo c rnmax=rn(1) rmumax=rmu(1) rmumin=rmumax rhomax=rho(1) rhomin=rhomax do i=1,num rnmax=max(rn(i),rnmax) rmumax=max(rmu(i),rmumax) rmumin=min(rmu(i),rmumin) rhomax=max(rho(i),rhomax) rhomin=min(rho(i),rhomin) enddo c numx=max(5,int(rnmax)+2) iminy=int(rmumin) if(rmuminreal(imaxy,rknd)) imaxy=imaxy+1 if(imaxy-iminy<4) then iminy=iminy-(4+iminy-imaxy)/2 imaxy=iminy+4 endif numy=imaxy-iminy+1 iminz=int(rhomin) if(rhominreal(imaxz,rknd)) imaxz=imaxz+1 if(imaxz-iminz<4) then iminz=iminz-(4+iminz-imaxz)/2 imaxz=iminz+4 endif numz=imaxz-iminz+1 c h=0.025e0_rknd xl=3.0e0_rknd*h xr=1.0e0_rknd-xl yl=xl yr=xr zl=xl zr=xr c c banners c call fstr(ichr,nchr,label,0_iknd) xxl=0.0e0_rknd xxr=1.0e0_rknd yyl=1.0e0_rknd-h yyr=1.0e0_rknd call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) c c set up rotated coordinate system c call mkrot(jp(13),jp(14),jp(15),q) c xmin=min(0.0e0_rknd,q(1,1))+min(0.0e0_rknd,q(2,1)) xmax=max(0.0e0_rknd,q(1,1))+max(0.0e0_rknd,q(2,1)) ymin=min(0.0e0_rknd,q(1,2))+min(0.0e0_rknd,q(2,2)) ymax=max(0.0e0_rknd,q(1,2))+max(0.0e0_rknd,q(2,2))+q(3,2) zmin=min(0.0e0_rknd,q(1,3)) + +min(0.0e0_rknd,q(2,3))+min(0.0e0_rknd,q(3,3)) zmax=max(0.0e0_rknd,q(1,3)) + +max(0.0e0_rknd,q(2,3))+max(0.0e0_rknd,q(3,3)) c scale=size/max(xmax-xmin,ymax-ymin) xshift=xx+(size-scale*(xmax+xmin))/2.0e0_rknd yshift=yy+(size-scale*(ymax+ymin))/2.0e0_rknd zshift= (size-scale*(zmax+zmin))/2.0e0_rknd t(1)=xshift t(2)=yshift t(5)=zshift t(3)=scale c dx=(xr-xl)/real(numx-1,rknd) dz=(zr-zl)/real(numz-1,rknd) dy=(yr-yl)/real(numy-1,rknd) do i=1,num x(i)=xl+dx*rn(i) y(i)=yl+dy*(rmu(i)-real(iminy,rknd)) z(i)=zl+dz*(rho(i)-real(iminz,rknd)) 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)>0.0e0_rknd) then call xygrid(xl,xr,yl,yr,zl,h,t,q, + numx,0_iknd,1_iknd,numy,iminy,1_iknd) else call pline(xn,yn,zn,num,2_iknd) endif isw=1 if(q(2,3)<0.0e0_rknd) 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_iknd) else call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1_iknd) 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)<=0.0e0_rknd) then call xygrid(xl,xr,yl,yr,zl,h,t,q, + numx,0_iknd,1_iknd,numy,iminy,1_iknd) else call pline(xn,yn,zn,num,2_iknd) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dbugi(sub,name,nrow,ncol,ia) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ia character(len=6) :: sub,name character(len=80) :: list,blank cy blank=' ' call filutl(blank,0_iknd) if(nrow==1.and.ncol==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_iknd) call filutl(blank,0_iknd) return else write(unit=list,fmt='(a11,a6,3x,a9,a6)') + 'subroutine:',sub,'variable:',name call filutl(list,0_iknd) call filutl(blank,0_iknd) endif if(ncol==1) then do irow=1,nrow,6 i5=min(irow+5,nrow) write(unit=list,fmt='(a4,i6,3x,6i8)') + 'row:',irow,(ia(i),i=irow,i5) call filutl(list,0_iknd) 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_iknd) enddo endif call filutl(blank,0_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dbugr(sub,name,nrow,ncol,a) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: a character(len=6) :: sub,name character(len=80) :: list,blank cy blank=' ' call filutl(blank,0_iknd) if(nrow==1.and.ncol==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_iknd) call filutl(blank,0_iknd) return else write(unit=list,fmt='(a11,a6,3x,a9,a6)') + 'subroutine:',sub,'variable:',name call filutl(list,0_iknd) call filutl(blank,0_iknd) endif if(ncol==1) then do irow=1,nrow,4 i3=min(irow+3_iknd,nrow) write(unit=list,fmt='(a4,i6,3x,4e12.4)') + 'row:',irow,(a(i),i=irow,i3) call filutl(list,0_iknd) 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_iknd) enddo endif call filutl(blank,0_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine prtpth(irgn,nproc,ipath) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(6,*) :: ipath character(len=80) :: list,blank cy blank=' ' call filutl(blank,0_iknd) write(unit=list,fmt='(a6,i3,3x,a5,i3)') + 'nproc:',nproc,'irgn:',irgn call filutl(list,0_iknd) 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_iknd) write(unit=list,fmt='(a7,i3,2(3x,a6,2i6))') + 'region:',i,'verts:',iv1,iv2,'edges:',ie1,ie2 call filutl(list,0_iknd) call filutl(blank,0_iknd) do k=ie1,ie2 write(unit=list,fmt='(a7,i6,2x,6i6)') + 'column:',k,(ipath(j,k),j=1,6) call filutl(list,0_iknd) 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_iknd) write(unit=list,fmt='(a8,i3,2(3x,a6,2i6))') + 'nproc+2:',i,'verts:',iv1,iv2,'edges:',ie1,ie2 call filutl(list,0_iknd) call filutl(blank,0_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine aveprt(ptime,jp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp real(kind=rknd), dimension(*) :: ptime character(len=80) :: list cy ntf=jp(1) if(ntf<=0) return nproc=jp(2) tmx=ptime(1) tmn=ptime(1) ave=0.0e0_rknd do i=1,nproc tmx=max(tmx,ptime(i)) tmn=min(tmn,ptime(i)) ave=ave+ptime(i) enddo ave=ave/real(nproc,rknd) 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_iknd) c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine nwtprt(hist) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(22,2) :: e real(kind=rknd), dimension(22,*) :: hist character(len=80) :: list character(len=80), save, dimension(3) :: label cy 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==-1) then lab=3 else if(lab1==-2) then lab=2 else lab=1 endif num1=int(hist(mxhist+1,1)) num=min(num1,mxhist) if(num<=0) return do j=1,2 e1=abs(hist(mxhist+2,j)) if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1 do i=1,num qq=abs(hist(i,j))*e1 e(i,j)=0.0e0_rknd if(qq>0.0e0_rknd) e(i,j)=log10(qq) enddo enddo c list=label(lab) call filutl(list,0_iknd) do i=1,num write(unit=list,fmt='(a10,i4,2f9.2)') + 'iteration:',i,e(i,1),e(i,2) call filutl(list,0_iknd) enddo if(num<=1) return r1=10.0e0_rknd**((e(num,1)-e(1,1))/real(num-1,rknd)) r2=10.0e0_rknd**((e(num,2)-e(1,2))/real(num-1,rknd)) write(unit=list,fmt='(a20,2f9.2)') + 'convergence factors:',r1,r2 call filutl(list,0_iknd) end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xyaxis(xl,xr,yl,yr,h,t,q,numx,iminx, + incx,numy,iminy,incy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(2) :: x,y,z character(len=80) :: ichr cy 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_rknd 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_iknd,2_iknd) do i=1,numx k=iminx+(i-1)*incx call sint(ichr,nchr,k) xx=xl+real(i-1,rknd)*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_iknd,2_iknd) xxl=xx-real(nchr,rknd)*h2 xxr=xx+real(nchr,rknd)*h2 yyl=yl-2.25e0_rknd*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) 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_iknd,2_iknd) do i=1,numy k=iminy+(i-1)*incy call sint(ichr,nchr,k) yy=yl+real(i-1,rknd)*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_iknd,2_iknd) xxl=xl-real(2*nchr+1,rknd)*h2 xxr=xl-h2 yyl=yy-h2 yyr=yy+h2 call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine symbl(xm,ym,hx,hy,itype,icolor,t) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(5) :: iptr integer(kind=iknd), save, dimension(14) :: px,py real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(5) :: x,y,z cy data iptr/1,5,9,12,15/ data px/-1,1,1,-1,1,0,-1,0,-1,1,0,0,1,-1/ data py/-1,-1,1,1,0,1,0,-1,-1,-1,1,-1,1,1/ 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 px0=real(px(i+istart-1),rknd)/2.0e0_rknd py0=real(py(i+istart-1),rknd)/2.0e0_rknd x(i)=(xm+hx*px0)*scale+xshift y(i)=(ym+hy*py0)*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_iknd,2_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xygrid(xl,xr,yl,yr,zl,h,t,q,numx,iminx, + incx,numy,iminy,incy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(25) :: t,t0 real(kind=rknd), dimension(3,3) :: q,q0 real(kind=rknd), dimension(2) :: x,y,z character(len=80) :: ichr cy 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_rknd zm=zl-h2 zp=zl+h2 do i=1,25 t0(i)=t(i) enddo c c x - axis c if(q(2,3)==0.0e0_rknd.and.q(3,3)==0.0e0_rknd) go to 10 nn=numy if(q(3,3)==0.0e0_rknd) nn=1 do i=1,nn yy=yl+real(i-1,rknd)*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_iknd,2_iknd) 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+real(i-1,rknd)*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_iknd,2_iknd) xxl=xx-real(nchr,rknd)*h2 xxr=xx+real(nchr,rknd)*h2 yyl=zl-2.25e0_rknd*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q0,t0,2_iknd) enddo c c y-axis c 10 if(q(1,3)==0.0e0_rknd.and.q(3,3)==0.0e0_rknd) return nn=numx if(q(3,3)==0.0e0_rknd) nn=1 do i=1,nn xx=xl+real(i-1,rknd)*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_iknd,2_iknd) 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+real(i-1,rknd)*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_iknd,2_iknd) xxl=yy-real(nchr,rknd)*h2 xxr=yy+real(nchr,rknd)*h2 yyl=zl-2.25e0_rknd*h yyr=yyl+h call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q0,t0,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,incz) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(25) :: t,t0 real(kind=rknd), dimension(3,3) :: q,q0 real(kind=rknd), dimension(3) :: x,y,z character(len=80) :: ichr cy dz=(zr-zl)/(numz-1) xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h2=h/2.0e0_rknd xp=xl+h2 yp=yl+h2 do i=1,25 t0(i)=t(i) enddo if(abs(q(1,3))abs(q(2,3))) kmin=2 if(abs(q(kmin,3))>abs(q(3,3))) kmin=3 kmid=index(2,kmin) kmax=index(3,kmin) if(abs(q(kmid,3))>abs(q(kmax,3))) kmid=kmax kmax=6-kmin-kmid c if(q(kmax,3)>0.0e0_rknd) 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)>0.0e0_rknd) 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)>0.0e0_rknd) then order(3)=2*kmin-1 order(4)=2*kmin else order(4)=2*kmin-1 order(3)=2*kmin endif c tol=1.0e-3_rknd istrt=6 if(abs(q(kmin,3))>tol) then istrt=4 else if(abs(q(kmid,3))>tol) then istrt=5 endif endif xshift=t(1) yshift=t(2) zshift=t(5) scale=t(3) h2=h/2.0e0_rknd do i=istrt,6 ii=order(i) do j=1,4 xx=x-h2+h*real(px(face(j,ii)),rknd) yy=y-h2+h*real(py(face(j,ii)),rknd) zz=zl+(z-zl)*real(pz(face(j,ii)),rknd) 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_iknd,icolor) call pline(xn,yn,zn,5_iknd,2_iknd) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mktris(nbf,nvv,ip,rp,vx,vy,ibndry,itnode,sf,jt, + jtnode,jtedge,ntf,iclrsw,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode,jtnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3*nbf) :: jb integer(kind=iknd), dimension(*) :: jt integer(kind=iknd), dimension(3,*) :: jtedge integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(nvv) :: index real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp cy external sxy c c make a crude triangulation of the skeleton c ntr=ip(1) nvr=ip(2) nbr=ip(3) rl=rp(21) c c make jb c call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb, + iflag,rl,sxy) if(iflag/=0) then ip(25)=iflag return endif c 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==1) then j5tag=itnode(4,itag) else if(iclrsw==2) then j5tag=itag else j5tag=itnode(5,itag) endif call trisk(nn,vx,vy,index,ntf,jtnode,j4tag,j5tag) 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) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine trisk(nvf,vx,vy,index,ntf,itnode,i4tag,i5tag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(2*nvf) :: istart,istop integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(nvf) :: list integer(kind=iknd), dimension(*) :: index real(kind=rknd), dimension(*) :: vx,vy cy 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_rknd eps=1.0e1_rknd*epsilon(1.0e0_rknd) 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 l=ibegin+2,iend if(kk==iend) exit 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>eps) cycle ac=geom(index(kb-1),index(kb),index(ka),vx,vy) c c boundary bends away from ibegin c if(ac<=eps.or.llist<=2) then iwind=0 sn=1.0e0_rknd 20 if(kk==iend) exit kk=kk+1 list(llist)=kk ak=sn*geom(index(ibegin),index(kb),index(kk),vx,vy) if(ak>eps) then qq=geom(index(ibegin),index(kk-1),index(kk),vx,vy) if(qq>eps) then iwind=iwind-1 if(iwind<0) cycle 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<=eps) then ac=geom(index(ka-1),index(kb),index(ka),vx,vy) c c if we skip outside view c if(ac>=eps.or.llist<=2) then sn=1.0e0_rknd 50 if(kk==iend) exit kk=kk+1 list(llist)=kk ak=sn*geom(index(ibegin),index(kb),index(kk), + vx,vy) if(ak>eps) then if(sn==1.0e0_rknd) then qq=geom(index(ka-1),index(ka),index(kk), + vx,vy) if(qqeps) then ac=geom(index(ka),index(kb),index(kb-1),vx,vy) if(ac>-eps) cycle c c now we have to work through the backward bending branch c llist=llist-1 60 if(kk==iend) exit kk=kk+1 list(llist)=kk ak=geom(index(ibegin),index(kb),index(kk),vx,vy) if(ak>=eps) go to 60 ka=list(llist) kb=kasave else llist=llist-1 list(llist)=ka endif go to 30 c enddo c c make new triangles c 80 if(list(llist)/=iend) then if(llist<2) stop 8094 list(llist)=iend kb=list(llist-1) aa=geom(index(ibegin),index(kb),index(iend),vx,vy) if(aa<=0.0e0_rknd) 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)/=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(nrsv0) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine eswapk(nt1,nt2,itnode,itedge,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy cy 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_rknd c c the main loop c do itnum=1,itmax ichng=0 do i=nt1,nt2 do j=1,3 k=itedge(j,i)/4 if(k<=i) cycle 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(min(q1,q2)0) then ll=itedge(j,i)-4*li itedge(ll,li)=4*i+j endif lk=itedge(kj,k)/4 if(lk>0) then ll=itedge(kj,k)-4*lk itedge(ll,lk)=4*k+kj endif enddo enddo if(ichng<=0) return enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cedgek(nvf,nt1,nt2,nb1,nb2,itnode,ibndry,itedge,jb) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(*) :: jb integer(kind=iknd), + dimension(nvf+nb2-nb1+1+3*(nt2-nt1+1)) :: list cy 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=max(itnode(j2,i),itnode(j3,i)) imin=min(itnode(j2,i),itnode(j3,i)) kold=imin 40 k=list(kold) if(k<=0) then c c add triangle i, edge j to list c if(iptr<=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=max(itnode(j2,ii),itnode(j3,ii)) if(imax==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>=0.0e0_rknd) 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=min(ibndry(1,i),ibndry(2,i)) imax=max(ibndry(1,i),ibndry(2,i)) 70 k=list(kold) if(k<=0) stop 5555 ii=list(k+1)/4 jj=list(k+1)-4*ii j2=index(2,jj) j3=index(3,jj) iimax=max(itnode(j2,ii),itnode(j3,ii)) if(imax==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine binits(ip,rp,vx,vy,sf,itnode,ibndry,t,tl,q,jp, + iclr,ntf,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(*) :: iclr integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(2) :: tmin,tmax real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(25) :: t,tl real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3) :: bmin,bmax cy external sxy c c find box containing the solution c call linit(t,q) call zoombx(rp,t) c ntr=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) mpisw=ip(48) irgn=ip(50) if(mpisw==1) then mpirgn=ip(47) if(mpirgn/=0.and.mpirgn==irgn) mpisw=-1 endif icrsn=ip(68) do i=1,25 jp(i)=0 enddo jp(1)=ntf jp(8)=ntr jp(2)=nvf jp(3)=nbf jp(24)=ndf jp(4)=1 jp(12)=mpisw rl=rp(21) c inplsw=0 jp(9)=inplsw c numbrs=ip(60) if(numbrs<0.or.numbrs>9) numbrs=0 if(mpisw==1.and.numbrs/=7) numbrs=0 if(icrsn==1.and.numbrs/=7) numbrs=0 jp(21)=numbrs lines=ip(59) if(lines/=-1) lines=1 jp(20)=lines c mxcolr=max(2,ip(51)) mxcolr=min(4096,mxcolr) jp(17)=mxcolr c c compute scaled coordinates c call xybox(nbf,vx,vy,sf,ibndry,bmin,bmax,diam,rl,sxy) c size=t(14) xs=t(15) ys=t(16) scale=size/max(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmin(1)+bmax(1))/2.0e0_rknd t(2)=ys-scale*(bmin(2)+bmax(2))/2.0e0_rknd 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)=min(itnode(5,i),tmin(1)) tmax(1)=max(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)=min(mxcolr,jp(5)+2) c do i=1,25 tl(i)=t(i) enddo tl(12)=1.0e0_rknd c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine binitt(lent,ip,rp,itnode,itedge,ibndry,ibedge,itdof, + vx,vy,sf,maxt,e,iclr,kdist,t,tl,q,jp,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), dimension(25) :: jp integer(kind=iknd), dimension(*) :: iclr,kdist integer(kind=iknd), dimension(4) :: num integer(kind=iknd), dimension(3) :: iords integer(kind=iknd), dimension(2) :: tmin,tmax integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(maxt,*) :: e real(kind=rknd), dimension(lent) :: ht real(kind=rknd), dimension(100) :: rp real(kind=rknd), dimension(25) :: t,tl real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3) :: bmin,bmax real(kind=rknd), dimension(2) :: val cy external sxy c c make temporary copies of main data structures for graphics c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) maxt=ip(83) maxv=ip(84) ifirst=ip(5) mpisw=ip(48) nproc=ip(49) irgn=ip(50) if(mpisw==1) then mpirgn=ip(47) if(mpirgn/=0.and.mpirgn==irgn) mpisw=-1 endif inplsw=ip(53) if(inplsw>8.or.inplsw<0) inplsw=0 icrsn=ip(68) itrgt=ip(69) rl=rp(21) do i=1,ntf nproc=max(nproc,itnode(4,i)) enddo c if(inplsw==6) then do i=1,ntf ht(i)=e(i,1) enddo else if(inplsw==7) then do i=1,ntf ht(i)=e(i,2) enddo else do i=1,ntf ht(i)=0.0e0_rknd enddo endif c c reduce to elements in region irgn c if(mpisw==1) then call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) call cedge5(nbf,itedge,ibedge,1_iknd) len=nvf call cutr1(len,ntf,nvf,nbf,irgn,itnode,itdof,ibndry, + vx,vy,sf,ht,num,bmin,bmax,ibedge,0_iknd) else if(icrsn==1) then newnbf=0 do i=1,nbf if(ibndry(4,i)/=0) then newnbf=newnbf+1 do j=1,7 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,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 jp(9)=inplsw c numbrs=ip(60) if(numbrs<0.or.numbrs>9) numbrs=0 if(mpisw==1.and.numbrs/=7) numbrs=0 if(icrsn==1.and.numbrs/=7) numbrs=0 jp(21)=numbrs lines=ip(59) if(lines<-1.or.lines>2) lines=0 if(icrsn==1.and.lines==0) lines=1 jp(20)=lines c mxcolr=max(2,ip(51)) mxcolr=min(4096,mxcolr) jp(17)=mxcolr c c compute scaled coordinates c call xybox(nbf,vx,vy,sf,ibndry,bmin,bmax,diam,rl,sxy) c if(mpisw==1) then call exbox(bmin,bmax,2_iknd) 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/max(bmax(1)-bmin(1),bmax(2)-bmin(2)) t(1)=xs-scale*(bmin(1)+bmax(1))/2.0e0_rknd t(2)=ys-scale*(bmin(2)+bmax(2))/2.0e0_rknd t(3)=scale c c c comput number of colors for the case of triangles c if(inplsw>=2.and.inplsw<=4) then jp(5)=6 call tinit(jp,itnode,iclr,vx,vy,num,val) c if(mpisw==1) call exqual(num,val) c t(21)=100.0e0_rknd*real(num(1),rknd)/real(num(4),rknd) t(22)=100.0e0_rknd*real(num(2),rknd)/real(num(4),rknd) t(23)=100.0e0_rknd*real(num(3),rknd)/real(num(4),rknd) t(24)=abs(val(1)) t(25)=val(2)/real(num(4),rknd) else if(inplsw>=5.and.inplsw<=7) then ncolor=min(ip(56),mxcolr-2) ncolor=max(1,ncolor) jp(5)=ncolor if(inplsw==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>0) ii=1 bmin(3)=ht(1) bmax(3)=ht(1) do i=1,ntf iclr(i)=ii bmin(3)=min(ht(i),bmin(3)) bmax(3)=max(ht(i),bmax(3)) enddo c if(mpisw==1) call exbox(bmin(3),bmax(3),1_iknd) c if(rp(9)<=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)<=0.0e0_rknd) iscale=2 jp(19)=iscale zmin=fscale(t(19),iscale,0_iknd) zmax=fscale(t(20),iscale,0_iknd) if(zmax>zmin) then dd=real(ncolor,rknd)/(zmax-zmin) do i=1,ntf zz=fscale(ht(i),iscale,0_iknd) iq=max(1,int((zz-zmin)*dd)+1) iclr(i)=min(ncolor,iq) enddo endif c call cdist(jp,t,ht,kdist) nn=2*min(ncolor,11) if(mpisw==1) call exdist(kdist,nn) jp(6)=1 else if(inplsw==1) then jp(5)=nproc jp(7)=0 c do i=1,ntf iclr(i)=max(0,itnode(4,i)) enddo else if(inplsw==8) then mxord=10 jp(5)=mxord jp(7)=0 c if(ifirst==0) then do i=1,ntf call locord(i,ndof,iord,iords,itdof) iclr(i)=iord enddo else ii=max(ifirst,1_iknd) ii=min(ii,mxord) do i=1,ntf iclr(i)=ii enddo endif c call cdist1(jp,iclr,kdist) if(mpisw==1) call exdist(kdist,mxord) else ii=5 tmin(1)=itnode(5,1) tmax(1)=itnode(5,1) do i=1,ntf tmin(1)=min(itnode(5,i),tmin(1)) tmax(1)=max(itnode(5,i),tmax(1)) enddo c if(mpisw==1) call exibox(tmin,tmax,1_iknd) c jp(5)=tmax(1)-tmin(1)+1 do i=1,ntf iclr(i)=itnode(ii,i)-tmin(1)+1 enddo endif jp(18)=min(mxcolr,jp(5)+2) c do i=1,25 tl(i)=t(i) enddo tl(12)=1.0e0_rknd c c coarsen the mesh c if(icrsn==1) then c call crsn0(nvf,ntf,nbf,itnode,ibndry,itdof,vx,vy, + sf,rl,itedge,ibedge,iclr,maxv,maxt,nproc,sxy) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag) c if(mpisw==1) then ndtrgt=max(3,itrgt/nproc) else ndtrgt=max(3,itrgt) endif if(inplsw<5.or.nvf<=ndtrgt) go to 20 c itmax=10 do itnum=1,itmax if(itnum<=1) then call smth1(ntf,itedge,iclr) else call smth2(ntf,itedge,itnode,vx,vy,iclr) endif call crsn0(nvf,ntf,nbf,itnode,ibndry,itdof,vx,vy, + sf,rl,itedge,ibedge,iclr,maxv,maxt, 1 nproc,sxy) call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge, + ibedge,iflag) if(nvf<=ndtrgt) exit 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cutr1(mlen,ntf,nvf,nbf,irgn,itnode,itdof,ibndry, + vx,vy,sf,e,iuvptr,ut,vt,ibedge,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge,iuvptr integer(kind=iknd), dimension(mlen) :: mark integer(kind=iknd), save, dimension(3,3) :: index real(kind=rknd), dimension(*) :: vx,vy,e,ut,vt real(kind=rknd), dimension(2,*) :: sf cy 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)/=0) then k1=ibedge(1,i)/4 krgn=itnode(4,k1) if(krgn==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==irgn.and.k2rgn/=irgn) kk=ibedge(1,i) if(k1rgn/=irgn.and.k2rgn==irgn) kk=ibedge(2,i) endif if(kk/=0) then newnbf=newnbf+1 do j=1,7 ibndry(j,newnbf)=ibndry(j,i) enddo do j=1,2 sf(j,newnbf)=sf(j,i) enddo kt=kk/4 ke=kk-4*kt if(ibndry(1,newnbf)/=itnode(index(2,ke),kt)) then ii=ibndry(1,newnbf) ibndry(1,newnbf)=ibndry(2,newnbf) ibndry(2,newnbf)=ii if(ibndry(3,newnbf)<0) then ss=sf(1,newnbf) sf(1,newnbf)=sf(2,newnbf) sf(2,newnbf)=ss endif endif if(ibndry(4,newnbf)==0) then ibndry(4,newnbf)=3 if(j1rgn/=j2rgn) ibndry(4,newnbf)=4 else if(ibndry(4,newnbf)<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)/=irgn) cycle newntf=newntf+1 do j=1,5 itnode(j,newntf)=itnode(j,i) enddo do j=1,8 itdof(j,newntf)=itdof(j,i) enddo if(isw==1) then iuvptr(1,newntf+1)=iuvptr(1,newntf) + +iuvptr(1,i+1)-iuvptr(1,i) iuvptr(2,newntf)=iuvptr(2,i) js=iuvptr(1,i)-iuvptr(1,newntf) do j=iuvptr(1,newntf),iuvptr(1,newntf+1)-1 ut(j)=ut(js+j) vt(j)=vt(js+j) enddo else e(newntf)=e(i) 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)==0) cycle newnvf=newnvf+1 mark(i)=newnvf vx(newnvf)=vx(i) vy(newnvf)=vy(i) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine crsn0(nvf,ntf,nbf,itnode,ibndry,itdof,vx,vy, + sf,rl,itedge,ibedge,icolor,maxv,maxt,nproc,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(maxv) :: iseed,vtype integer(kind=iknd), dimension(maxt) :: p,q,mark,list integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: icolor integer(kind=iknd), dimension(500) :: elist,tlist,vlist, + blist,elist0,tlist0,vlist0,blist0 integer(kind=iknd), dimension(3) :: ibmptr,iv integer(kind=iknd), dimension(8,*) :: itdof real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(3) :: bump,e,gf real(kind=rknd), dimension(maxt) :: qual cy external sxy c c check to see if we have solved problem on current finest grid c angmin=1.0e-3_rknd arcmax=0.26e0_rknd do i=1,ntf itnode(4,i)=itnode(4,i)+(nproc+1)*icolor(i) enddo c c initailize iseed, vtype c call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,rl, + itedge,ibedge,vtype,iseed,angmin,arcmax,sxy) call cedge5(nbf,itedge,ibedge,1_iknd) c c initialize qual, p,q c do i=1,ntf mark(i)=0 p(i)=i q(i)=i call rmtst(i,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,0_iknd) if(iedge>0) then qual(i)=1.0e0_rknd else qual(i)=0.0e0_rknd endif enddo c c initialize heap c nn=ntf/2 do k=nn,1,-1 call updhp(k,nvf,p,q,qual,0_iknd) enddo last=ntf c c main elimination loop c do nn=ntf,1,-1 i=p(1) if(qual(i)==0.0e0_rknd) exit p(1)=p(last) p(last)=i q(p(last))=last q(p(1))=1 last=last-1 call updhp(1_iknd,last,p,q,qual,0_iknd) c call rmtst(i,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,0_iknd) if(iedge==0) stop 6266 call rmknot(iedge,i,iv,itnode,itedge,ibndry, + ibedge,itdof,vx,vy,sf,1_iknd,ngf,3_iknd,gf,ibmptr, 1 bump,1_iknd,e,iseed,vtype,incdf,0_rknd,rl,sxy) jtri=iv(3) if(jtri>0) then kk=q(jtri) if(kk==last) then last=last-1 else p(kk)=p(last) p(last)=jtri q(p(last))=last q(p(kk))=kk last=last-1 call updhp(kk,last,p,q,qual,1_iknd) endif endif c c update vertices in connected to i c llen=0 do m=1,2 if(iv(m)==0) cycle c call cirlst(iv(m),itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist,tlist,elist,blist,len) call tstvty(iv(m),itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist,tlist,elist, 1 len,sxy) is=1 if(vtype(iv(m))>=7) is=2 do jj=is,len+1 j=vlist(jj) if(j==0) cycle call cirlst(j,itnode,itedge,ibndry,ibedge, + iseed,vtype,vlist0,tlist0,elist0,blist0,len0) call tstvty(j,itnode,ibndry,vx,vy,sf,rl,itedge, + vtype,angmin,arcmax,vlist0,tlist0, 1 elist0,len0,sxy) js=1 if(vtype(j)>=7) js=2 do kk=js,len0 k=tlist0(kk) if(mark(k)/=nn) then llen=llen+1 list(llen)=k mark(k)=nn endif enddo enddo enddo do m=1,llen j=list(m) call rmtst(j,iedge,itnode,itedge,ibndry, + ibedge,vx,vy,iseed,vtype,0_iknd) if(iedge>0) then qual(j)=1.0e0_rknd else qual(j)=0.0e0_rknd endif kk=q(j) call updhp(kk,last,p,q,qual,1_iknd) enddo enddo c do i=1,ntf itnode(4,i)=itnode(4,i)-(nproc+1)*icolor(i) enddo call clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge,vx,vy, + sf,icolor,iseed) c c improve geometry c call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag) call cedge5(nbf,itedge,ibedge,1_iknd) call eswapa(ntf,nvf,nbf,1_iknd,1_iknd,itnode,itedge,ibndry, + ibedge,vx,vy,ibmptr,bump,1_iknd,e, 1 0_iknd,0_iknd,itdof,1_iknd,e) call cedge5(nbf,itedge,ibedge,0_iknd) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge, + vx,vy,sf,icolor,mark) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(2,*) :: ibedge integer(kind=iknd), dimension(*) :: mark,icolor real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf cy 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)/=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)>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)>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)/=0) then nbnew=nbnew+1 mark(i)=nbnew do j=1,7 ibndry(j,nbnew)=ibndry(j,i) enddo do j=1,2 ibedge(j,nbnew)=ibedge(j,i) sf(j,nbnew)=sf(j,i) enddo k=ibedge(1,nbnew)/4 ke=ibedge(1,nbnew)-4*k itedge(ke,k)=-nbnew if(ibedge(2,nbnew)>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)>=0) cycle k=-ibndry(4,i) ibndry(4,i)=-mark(k) 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)/=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<0.0e0_rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine smth1(ntf,itedge,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: icolor integer(kind=iknd), dimension(3) :: ic integer(kind=iknd), dimension(3,*) :: itedge cy itmax=2 c do itnum=1,itmax ichng=0 do i=1,ntf num=0 do j=1,3 if(itedge(j,i)<=0) cycle num=num+1 ii=itedge(j,i)/4 ic(num)=icolor(ii) enddo ii=icolor(i) if(num==2) then if(ic(1)==ic(2).and.ii/=ic(1)) then ichng=ichng+1 icolor(i)=ic(1) endif else if(num==3) then isw=0 if(ic(1)==ic(2)) isw=isw+1 if(ic(1)==ic(3)) isw=isw+1 if(isw>0.and.ii/=ic(1)) then ichng=ichng+1 icolor(i)=ic(1) elseif(ic(2)==ic(3).and.ii/=ic(2)) then ichng=ichng+1 icolor(i)=ic(2) endif else if(num==1) then if(ii/=ic(1)) then ichng=ichng+1 icolor(i)=ic(1) endif endif enddo if(ichng==0) return enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine smth2(ntf,itedge,itnode,vx,vy,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: icolor integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(5,*) :: itnode real(kind=rknd), dimension(*) :: vx,vy cy itmax=1 theta=0.05e0_rknd 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=min(hh,hmin) hmax=max(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<=thrsh) then num=2 q=real(2*icolor(i),rknd)+0.5e0_rknd do j=1,3 if(itedge(j,i)<=0) cycle num=num+2 ii=itedge(j,i)/4 q=q+real(icolor(ii)+icolor(i),rknd) enddo q=q/real(num,rknd) icolor(i)=int(q) endif enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine tplot(vx,vy,ibndry,itnode,sf,t,jp,itedge,iclr,rl,sxy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(3,*) :: itedge integer(kind=iknd), dimension(25) :: jp integer(kind=iknd) :: ccolor integer(kind=iknd), dimension(*) :: iclr integer(kind=iknd), save, dimension(3,3) :: index integer(kind=iknd), dimension(3072) :: ibdy integer(kind=iknd), dimension(2,1) :: iuvptr real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(2) :: x,y,z real(kind=rknd), dimension(3,3) :: q real(kind=rknd), dimension(3) :: bx,by,bz,ut,vt real(kind=rknd), dimension(3072) :: xp,yp,up,vp cy external sxy data index/1,2,3,2,3,1,3,1,2/ 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_rknd c do i=1,3 do j=1,3 q(i,j)=0.0e0_rknd enddo q(i,i)=1.0e0_rknd enddo 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,sf,q,0_iknd,-1_iknd,iuvptr,ut,vt,rl,sxy) ic=iclr(ii) icolor=ccolor(ic,0_iknd,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_iknd,t,icolor) c c line drawing c do m=1,3 k=ibdy(itri+m-1) isw=0 if(lines==-1) then isw=1 else if(lines==0.and.k>=0) then isw=1 else if(k==1) then isw=1 else if(k>1) then if(lines==1) then if(k==2.or.k==5) isw=1 else if(lines==2) then if(k==3.or.k==5) isw=1 endif endif if(isw==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_iknd,t,2_iknd) endif enddo enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sfix(list,length,val,ndig) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd) :: mlen character(len=*) :: list character(len=1), save :: zero='0',minus='-',dot='.' character(len=100) :: temp cy c compute character string for fixed point number c if(val==0.0e0_rknd) then length=ndig+1 do i=1,length list(i:i)=zero enddo list(2:2)=dot return endif zc=abs(val) zz=log10(zc) iex=int(zz) mdig=min(ndig,ndig-iex) mdig=max(0,mdig) tt=zc*(10.0e0_rknd**mdig)+0.5e0_rknd n=int(tt) if(n==0) then do i=1,ndig+2 list(i:i)=zero enddo if(val>=0.0e0_rknd) then length=ndig+1 list(2:2)=dot else length=ndig+2 list(1:1)=minus list(3:3)=dot endif return endif call sint(temp,mlen,n) if(mlen<=ndig) then do i=mlen,1,-1 temp(ndig-mlen+i+1:ndig-mlen+i+1)=temp(i:i) enddo do i=1,ndig+1-mlen temp(i:i)=zero enddo mlen=ndig+1 endif if(val>0.0e0_rknd) then length=mlen+1 ishift=0 else length=mlen+2 ishift=1 list(1:1)=minus endif do i=1,mlen-mdig list(i+ishift:i+ishift)=temp(i:i) enddo ishift=ishift+1 list(mlen-mdig+ishift:mlen-mdig+ishift)=dot do i=mlen-mdig+1,mlen list(i+ishift:i+ishift)=temp(i:i) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine htext(xl,yl,xr,yr,nchr,cchr,ijust,q,t,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(80) :: ichr integer(kind=iknd), save, dimension(640) :: symbcd integer(kind=iknd), save, dimension(94) :: istart integer(kind=iknd), save, dimension(128) :: map real(kind=rknd), save, dimension(94) :: width real(kind=rknd), dimension(2) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(3,3) :: q character(len=*) :: cchr character(len=1) :: cc cy 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,40)/ + 18.0e0_rknd,21.0e0_rknd,21.0e0_rknd,21.0e0_rknd, 1 19.0e0_rknd,18.0e0_rknd,21.0e0_rknd,22.0e0_rknd, 2 8.0e0_rknd,16.0e0_rknd,21.0e0_rknd,17.0e0_rknd, 3 24.0e0_rknd,22.0e0_rknd,22.0e0_rknd,21.0e0_rknd, 4 22.0e0_rknd,21.0e0_rknd,20.0e0_rknd,16.0e0_rknd, 5 22.0e0_rknd,18.0e0_rknd,24.0e0_rknd,20.0e0_rknd, 6 18.0e0_rknd,20.0e0_rknd,19.0e0_rknd,19.0e0_rknd, 7 18.0e0_rknd,19.0e0_rknd,18.0e0_rknd,12.0e0_rknd, 8 19.0e0_rknd,19.0e0_rknd, 8.0e0_rknd,10.0e0_rknd, 9 17.0e0_rknd, 8.0e0_rknd,30.0e0_rknd,19.0e0_rknd/ data (width(i),i=41,80)/ + 19.0e0_rknd,19.0e0_rknd,19.0e0_rknd,13.0e0_rknd, 1 17.0e0_rknd,12.0e0_rknd,19.0e0_rknd,16.0e0_rknd, 2 22.0e0_rknd,17.0e0_rknd,16.0e0_rknd,17.0e0_rknd, 3 20.0e0_rknd,20.0e0_rknd,20.0e0_rknd,20.0e0_rknd, 4 20.0e0_rknd,20.0e0_rknd,20.0e0_rknd,20.0e0_rknd, 5 20.0e0_rknd,20.0e0_rknd,26.0e0_rknd,26.0e0_rknd, 6 14.0e0_rknd,14.0e0_rknd,10.0e0_rknd,10.0e0_rknd, 7 22.0e0_rknd,26.0e0_rknd,16.0e0_rknd,20.0e0_rknd, 8 24.0e0_rknd,24.0e0_rknd,14.0e0_rknd,14.0e0_rknd, 9 27.0e0_rknd,22.0e0_rknd,14.0e0_rknd,14.0e0_rknd/ data (width(i),i=81,94)/ + 21.0e0_rknd,10.0e0_rknd,10.0e0_rknd,10.0e0_rknd, 1 18.0e0_rknd,24.0e0_rknd,25.0e0_rknd,24.0e0_rknd, 2 16.0e0_rknd, 8.0e0_rknd,26.0e0_rknd,22.0e0_rknd, 3 14.0e0_rknd, 8.0e0_rknd/ 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-sign(1_iknd,iword))/2)* 1 (2**nbits-min(1,mod(-iword,2**(nstart-nbits)))) c if(nchr<=0) return if(xl>=xr) return if(yl>=yr) return c do i=1,nchr cc=cchr(i: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_rknd do i=1,nchr ic=ichr(i) if(ic<1.or.ic>94) then wid=wid+20.0e0_rknd else wid=wid+width(ic) endif enddo wid=wid/21.0e0_rknd c height=min(dx/wid,dy) if(height94) then c c plot a space c xi=xi+20.0e0_rknd*rscale else c c plot a single symbol c is=istart(ic) ib=30 70 ipen=ixtrct(ib,3_iknd,symbcd(is)) if(ipen==0)then xi=xi+rscale*width(ic) cycle endif ix=ixtrct(ib-3_iknd,6_iknd,symbcd(is)) iy=ixtrct(ib-9_iknd,6_iknd,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==2) then x(2)=xx y(2)=yy z(2)=zz call lwindw(x,y,z,2_iknd,t,icolor) endif x(1)=xx y(1)=yy z(1)=zz ib=45-ib if(ib==30)is=is+1 go to 70 endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pwindw(x,y,z,llen,t,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(22) :: xn,yn,zn,x0,y0,z0 real(kind=rknd), dimension(4) :: cx,cy,cc cy c map a polygon onto the current window c rmag=t(12) if(rmag<=1.0e0_rknd) then call pfill(x,y,z,llen,icolor) return endif c nmax=22 eps=t(7)/rmag shift=(1.0e0_rknd-t(14))/2.0e0_rknd c cx(1)=1.0e0_rknd cx(2)=-cx(1) cx(3)=0.0e0_rknd cx(4)=cx(3) c cy(1)=cx(3) cy(2)=cx(4) cy(3)=cx(1) cy(4)=cx(2) c 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>=eps) then num=num+1 xn(num)=x0(i) yn(num)=y0(i) zn(num)=z0(i) else ibef=i-1 if(i==1) ibef=len iaft=i+1 if(i==len) iaft=1 j=ibef do jj=1,2 s=x0(j)*cx(k)+y0(j)*cy(k)+cc(k) if(s>eps) then num=num+1 f=s/(s-si) xn(num)=x0(i)*f+x0(j)*(1.0e0_rknd-f) yn(num)=y0(i)*f+y0(j)*(1.0e0_rknd-f) zn(num)=z0(i)*f+z0(j)*(1.0e0_rknd-f) endif j=iaft enddo endif enddo if(num<=2) return if(num>=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lwindw(x,y,z,n,t,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z real(kind=rknd), dimension(25) :: t real(kind=rknd), dimension(2) :: xx,yy,zz cy c draw the part of the picture within the current window c rmag=t(12) if(rmag<=1.0e0_rknd) 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_rknd-t(14))/2.0e0_rknd c c the main loop c do 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)=xr) cycle c if(xx(jl)xr) then f=(xr-xx(jl))/(xx(jr)-xx(jl)) xx(jr)=xr yy(jr)=yy(jr)*f+yy(jl)*(1.0e0_rknd-f) zz(jr)=zz(jr)*f+zz(jl)*(1.0e0_rknd-f) endif c c fit line into window in y direction c jb=1 if(yy(2)=yt) cycle c if(yy(jb)yt) then f=(yt-yy(jb))/(yy(jt)-yy(jb)) yy(jt)=yt xx(jt)=xx(jt)*f+xx(jb)*(1.0e0_rknd-f) zz(jt)=zz(jt)*f+zz(jb)*(1.0e0_rknd-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_iknd,icolor) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ascutl(id,fname,mode,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(10) :: istack integer(kind=iknd), save :: length,ifirst=1,next character(len=1) :: mode character(len=80), save :: sname character(len=80) :: fname common /asc/maxid,irw(10),iunit(10) cy 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==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=='c') then c c ckeck for valid id c if(id<=0.or.id>maxid) then iflag=4 return endif if(irw(id)==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>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_iknd) c c open for write c if(mode=='w') then open(unit=iunit(id),form='formatted',status='unknown', + file=sname,access='sequential',err=10) irw(id)=1 else if(mode=='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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ascstr(id,sval,length,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=*) :: sval common /asc/maxid,irw(10),iunit(10) cy 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<=0.or.id>maxid) then iflag=4 return endif if(irw(id)==0) then iflag=5 return endif if(irw(id)<0) then read(iunit(id),fmt='(2000a1)',end=10,err=20) + (sval(i:i),i=1,length) else write(iunit(id),fmt='(2000a1)',err=30) + (sval(i:i),i=1,length) endif flush(iunit(id)) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ascint(id,ival,length,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ival common /asc/maxid,irw(10),iunit(10) cy c write an integer array c iflag =0 if(id<=0.or.id>maxid) then iflag=4 return endif if(irw(id)==0) then iflag=5 return endif if(irw(id)<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 flush(iunit(id)) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine ascflt(id,rval,length,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: rval common /asc/maxid,irw(10),iunit(10) cy c write a real array c iflag =0 if(id<=0.or.id>maxid) then iflag=4 return endif if(irw(id)==0) then iflag=5 return endif if(irw(id)<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 flush(iunit(id)) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine rdwrt(fname,isave,vx,vy,sf,ibndry,itnode,itdof, + ipath,e,ip,rp,sp,iu,ru,su,gf) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(7,*) :: ibndry integer(kind=iknd), dimension(6,*) :: ipath integer(kind=iknd), dimension(5,*) :: itnode integer(kind=iknd), dimension(100) :: ip,iu integer(kind=iknd), dimension(8,*) :: itdof integer(kind=iknd), save :: jfirst=1 real(kind=rknd), dimension(*) :: vx,vy,e,gf real(kind=rknd), dimension(2,*) :: sf real(kind=rknd), dimension(100) :: rp,ru real(kind=rknd), dimension(101,6) :: path0 real(kind=rknd), dimension(22,30) :: hist0 real(kind=rknd), dimension(3,50) :: time0 character(len=4) :: keychk,keywrd character(len=80) :: fname,sname character(len=80), dimension(100) :: sp,su common /pltmg7/time(3,50),hist(22,30) common /pltmg6/path(101,6) common /atest6/nproc,myid,mpisw,mpiint,mpiflt cy c isave = 0, write a file c isave = 1, read a file c iflag=0 sp(11)='rdwrt: ok' call stfile(sname,fname) if(rknd==rsngl) then if(iknd==isngl) then keywrd='rwss' else keywrd='rwds' endif else if(rknd==rdble) then if(iknd==isngl) then keywrd='rwsd' else keywrd='rwdd' endif else if(iknd==isngl) then keywrd='rwsq' else keywrd='rwdq' endif endif c if(isave==0_iknd) then keychk=keywrd jfirst=1 call xdrutl(id,sname,'w',jflag) else if(isave==1_iknd) 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,4,jflag) if(keychk/=keywrd) then iflag=16 sp(11)='rdwrt: wrong keyword' go to 30 endif c c integer arrays c if(iknd==isngl) then call xdrint(id,ip,100,jflag) else call xdrlng(id,ip,100,jflag) endif c ntf=ip(1) nvf=ip(2) nbf=ip(3) ndf=ip(4) ifirst=ip(5) maxd=ip(85) maxt=ip(83) ip(48)=mpisw ip(49)=nproc ip(50)=myid+1 c lipath=ip(72) ngf=ip(77) c if(iknd==isngl) then call xdrint(id,iu,100,jflag) call xdrint(id,itnode,5*ntf,jflag) call xdrint(id,ibndry,7*nbf,jflag) if(itnode(3,1)/=0.and.ifirst==0) then if(lipath>0) call xdrint(id,ipath,6*lipath,jflag) call xdrint(id,itdof,8*ntf,jflag) endif else call xdrlng(id,iu,100,jflag) call xdrlng(id,itnode,5*ntf,jflag) call xdrlng(id,ibndry,7*nbf,jflag) if(itnode(3,1)/=0.and.ifirst==0) then if(lipath>0) call xdrlng(id,ipath,6*lipath,jflag) call xdrlng(id,itdof,8*ntf,jflag) endif endif c c real arrays c if(rknd==rsngl) then call xdrflt(id,rp,100,jflag) call xdrflt(id,ru,100,jflag) call xdrflt(id,vx,nvf,jflag) call xdrflt(id,vy,nvf,jflag) call xdrflt(id,sf,2*nbf,jflag) if(itnode(3,1)/=0.and.ifirst==0) then do k=1,ngf call xdrflt(id,gf((k-1)*maxd+1),ndf,jflag) enddo if(jfirst==1) then call xdrflt(id,path,606,jflag) call xdrflt(id,hist,660,jflag) call xdrflt(id,time,150,jflag) jfirst=0 else call xdrflt(id,path0,606,jflag) call fixpth(path,path0) call xdrflt(id,hist0,660,jflag) call fixhst(hist,hist0) call xdrflt(id,time0,150,jflag) endif do k=1,2 call xdrflt(id,e((k-1)*maxt+1),ntf,jflag) enddo endif else if(rknd==rdble) 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) call xdrdbl(id,sf,2*nbf,jflag) if(itnode(3,1)/=0.and.ifirst==0) then do k=1,ngf call xdrdbl(id,gf((k-1)*maxd+1),ndf,jflag) enddo if(jfirst==1) then call xdrdbl(id,path,606,jflag) call xdrdbl(id,hist,660,jflag) call xdrdbl(id,time,150,jflag) jfirst=0 else call xdrdbl(id,path0,606,jflag) call fixpth(path,path0) call xdrdbl(id,hist0,660,jflag) call fixhst(hist,hist0) call xdrdbl(id,time0,150,jflag) endif do k=1,2 call xdrdbl(id,e((k-1)*maxt+1),ntf,jflag) enddo endif else call xdrqud(id,rp,100,jflag) call xdrqud(id,ru,100,jflag) call xdrqud(id,vx,nvf,jflag) call xdrqud(id,vy,nvf,jflag) call xdrdbl(id,sf,2*nbf,jflag) if(itnode(3,1)/=0.and.ifirst==0) then do k=1,ngf call xdrqud(id,gf((k-1)*maxd+1),ndf,jflag) enddo if(jfirst==1) then call xdrqud(id,path,606,jflag) call xdrqud(id,hist,660,jflag) call xdrqud(id,time,150,jflag) jfirst=0 else call xdrqud(id,path0,606,jflag) call fixpth(path,path0) call xdrqud(id,hist0,660,jflag) call fixhst(hist,hist0) call xdrqud(id,time0,150,jflag) endif do k=1,2 call xdrqud(id,e((k-1)*maxt+1),ntf,jflag) enddo 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine fixpth(path,path0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(101,6) :: path0,path cy 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>num) go to 10 if(num0>1) then do i=1,num0-1 do j=1,6 if(path0(i,j)/=path(i,j)) go to 10 enddo enddo endif if(path0(num0,1)/=path(num0,1)) go to 10 if(path0(num0,2)/=path(num0,2)) go to 10 it=int(path(num0,6)) it0=int(path0(num0,6)) if(it==it0.and.it/=6) then if(path0(num0,3)/=path(num0,3)) go to 10 if(path0(num0,4)/=path(num0,4)) go to 10 if(path0(num0,5)/=path(num0,5)) go to 10 endif c c restore old path c if(num>=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)=real(7,rknd) path(101,1)=real(num,rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine fixhst(hist,hist0) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(22,30) :: hist0,hist cy 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>num) go to 10 istart=7 c c save error histories c if(num0>1) then do i=1,num0 isw=0 do j=1,6 if(hist0(i,j)/=hist(i,j)) isw=1 enddo if(isw==1) then if(num>=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)=real(num,rknd) 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine reset(num,name,nptr,labels,values,ip,rp,sp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: ip,nptr integer(kind=isngl), dimension(101) :: sptr real(kind=rknd), dimension(*) :: rp character(len=15), dimension(*) :: name character(len=80), dimension(*) :: sp,labels,values character(len=80), dimension(100) :: sval character(len=80) :: list,ss,msg character(len=1) :: cmd character(len=1), dimension(100) :: typ,mark character(len=6) :: cmdtyp character(len=9), dimension(100) :: tval common /atest3/mode,jnlsw,jnlr,jnlw,ibatch common /atest4/jcmd,cmdtyp,list cy 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==-1) call disply(name,num,ip,rp,sp) c if(ierr/=0) then ss='command error' call filutl(ss,0_iknd) endif if(length>1.and.ierr==0) return c c x-windows display c if(jnlsw==0) then do i=1,num mark(i)='f' sptr(i)=nptr(i) call cint(name(i),3_iknd,indx,jerr) tval(i)(1:9)=name(i)(5:13) if(tval(i)(9:9)==' ') 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)=='i') then call sint(sval(i),length,ip(indx)) else if(name(i)(15:15)=='r') then call sreal(sval(i),length,rp(indx),5_iknd,0_iknd) else sval(i)=sp(indx) endif enddo sptr(num+1)=nptr(num+1) c if(num==1.and.typ(1)=='f') then call xfile(list,sval,tval,jcmd) if(sp(indx)/=sval(1)) mark(1)='t' else call xreset(list,num,typ,sval,mark,tval, + sptr,labels,values,jcmd) endif c do i=1,num if(mark(i)=='t') then call cint(name(i),3_iknd,indx,jerr) if(name(i)(15:15)=='i') then call cint(sval(i),80_iknd,ival,jerr) if(jerr==0) ip(indx)=ival else if(name(i)(15:15)=='r') then call creal(sval(i),80_iknd,rval,jerr) if(jerr==0) rp(indx)=rval else jerr=0 sp(indx)=sval(i) endif if(jerr==0) then ss=' ' if(name(i)(15:15)=='l') then call fstr(ss,length,sval(i),1_iknd) else call fstr(ss,length,sval(i),0_iknd) endif write(unit=msg,fmt='(a1,a6,a1,a72)') + cmd,name(i)(5:10),'=',ss call star0(msg) call filutl(msg,1_iknd) endif endif enddo c else if(jnlsw/=-2) then call getcmd(list) endif c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine menu(ip,rp,sp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save, dimension(24) :: st integer(kind=iknd), dimension(*) :: ip integer(kind=iknd), save, dimension(525) :: iptr integer(kind=iknd), save, dimension(301) :: nptr integer(kind=iknd), dimension(101) :: sptr integer(kind=iknd), save :: iustat,lowera=97,lowerz=122 integer(kind=iknd), save :: mpibtn=0,ifirst=-1,ncmd real(kind=rknd), dimension(*) :: rp character(len=1), save, dimension(24) :: sty character(len=6) :: cmdtyp character(len=15), save, dimension(300) :: name character(len=15), dimension(100) :: sname character(len=15), save, dimension(24) :: ctable character(len=80), dimension(100) :: sp character(len=80) :: list,filnam character(len=80), save :: ulist character(len=80), dimension(500) :: file character(len=80), save, dimension(500) :: labels,values character(len=80), dimension(200) :: slabel,svalue common /atest3/mode,jnlsw,jnlr,jnlw,ibatch common /atest4/jcmd,cmdtyp,list common /atest6/nproc,myid,mpisw,mpiint,mpiflt cy c if(ifirst==-1) then call mpiutl(1_iknd) mode=0 do i=1,100 ip(i)=0 rp(i)=0.0e0_rknd 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==1) then jcmd=ncmd sp(12)(1:6)='quit ' mode=ip(42) jnlsw=mode if(mode>1.or.mode<-1) then sp(11)='menu: bad value for mode' return endif if(myid/=0) then if(mode==1) then call mkjnl(sp,kflag) if(kflag/=0) go to 40 call stfile(filnam,sp(10)) call ascutl(jnlr,filnam,'r',kflag) if(kflag/=0) go to 40 jnlsw=2 mode=-2 else mode=-2 jnlsw=mode endif else if(mode==0) then call xwinit(ncmd,ctable,sp(13)) call grinit(ip(43)) do i=1,ncmd if(ctable(i)(10:15)=='mpicmd') then mpibtn=i call xmpi(mpisw,mpibtn) endif enddo else if(mode==1) then call mkjnl(sp,kflag) if(kflag/=0) go to 40 call stfile(filnam,sp(10)) call ascutl(jnlr,filnam,'r',kflag) if(kflag/=0) go to 40 endif call stfile(filnam,sp(8)) call ascutl(jnlw,filnam,'w',kflag) if(kflag/=0) go to 40 call stfile(filnam,sp(9)) call ascutl(ibatch,filnam,'w',kflag) if(kflag/=0) go to 40 c ulist=' ' list=' ' iustat=0 ifirst=0 endif c ierr=0 5 if(ierr>0) sp(11)='command error' if(sp(11)/=' ') call filutl(sp(11),0_iknd) if(iustat==1.and.ulist==list) iustat=0 if(iustat==0) then if(jnlsw==0) then call xgtcmd(list) else if(jnlsw/=-2) then call getcmd(list) endif endif c c mpi communication c if(mode==-2.and.jnlsw==-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/=0) go to 5 if(length==0) then if(mode==-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==-2.and.jnlsw>=1.and.mpisw==-1) then if(cmdtyp/='mpicmd'.and.cmdtyp/='quit ') then ii=ichar(list(1:1)) if(ii>=lowera.and.ii<=lowerz) list(1:1)=char(ii-32) if(length<=1) go to 5 endif endif if(list(1:1)==ctable(jcmd)(8:8)) go to 30 c c reset parameters with display c iustat=1 ulist=list if(nequal==0.and.st(jcmd)>0.and.length>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)=='mpicmd') ip(48)=mpisw sp(11)=' ' go to 5 c 30 sp(12)(1:6)=ctable(jcmd)(1:6) if(length==1) go to 40 c c short form of command c if(nequal==0.and.st(jcmd)>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/=0) go to 5 c c quit command c 40 if(sp(12)(1:6)=='quit '.or.cmdtyp=='quit ') then call mpiutl(-1_iknd) jcmd=-1 if(mode==0) call xwinit(jcmd,ctable,sp(13)) if(jnlsw>=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=='journl') then ierr=0 if(jnlsw<=0) then call mkjnl(sp,kflag) if(kflag/=0) go to 5 call stfile(filnam,sp(10)) call ascutl(jnlr,filnam,'r',kflag) if(kflag/=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=='usrcmd') then iustat=1 ulist=list sp(11)='usrcmd: ok' c c mpi command c else if(cmdtyp=='mpicmd') then if(length==1) then mpisw=-mpisw ip(48)=mpisw else if(ip(48)/=1) ip(48)=-1 mpisw=ip(48) endif if(mpisw==1) then sp(11)='mpi is on' else sp(11)='mpi is off' endif ierr=0 if(mode==0) call xmpi(mpisw,mpibtn) go to 5 endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine parcmd(ncmd,ctable,list,length,nequal, + jcmd,cmdtyp,ierr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(24) :: lequal,lcomma character(len=1) :: lcmd,ucmd character(len=6) :: cmdtyp character(len=15), dimension(*) :: ctable character(len=80) :: list cy call fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) c c obvious errors c call filutl(list,1_iknd) if(length==0) then ierr=0 return endif ierr=1 jcmd=0 cmdtyp=' ' if(icomnt==1) then ierr=-1 return endif if(nequal>0) then if(ncomma/=nequal-1) return else if(ncomma>0) return endif if((ndbleq/2)*2/=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==list(1:1).or.ucmd==list(1:1)) go to 20 enddo return 20 if(lcmd==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine shrtfm(ip,rp,sp,length,sty,st,ierr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: st,ip real(kind=rknd), dimension(*) :: rp character(len=1), dimension(*) :: sty character(len=6) :: cmdtyp character(len=80), dimension(100) :: sp character(len=80) :: list common /atest4/jcmd,cmdtyp,list cy c short form of command c ierr=0 ll=length-1 if(sty(jcmd)=='i') then call cint(list(2:2),ll,ival,ierr) if(ierr==0) ip(st(jcmd))=ival else if(sty(jcmd)=='r') then call creal(list(2:2),ll,rval,ierr) if(ierr==0) rp(st(jcmd))=rval else if(sty(jcmd)=='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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine prtfl(file,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(24) :: lcomma,lequal character(len=80), dimension(*) :: file character(len=80) :: lstr,line character(len=10), save :: mark='+123456789' character(len=1), save, dimension(4) :: cc cy 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==1.or.length==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 i=1,len if(file(i)(1:1)/=cc(m)) cycle call fstr(lstr,length,file(i),0_iknd) line=' ' line(6:6)=mark(ii: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/=10.and.k10) ii=1 enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine prtfl0(file,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(24) :: lcomma,lequal character(len=80), dimension(*) :: file character(len=80) :: lstr character(len=1), save, dimension(4) :: cc cy 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==1.or.length==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 i=1,len if(file(i)(1:1)/=cc(m)) cycle call fstr(lstr,length,file(i),0_iknd) write(unit=11,fmt='(a80)') lstr enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine getnam(name,nlen) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(24) :: lcomma,lequal integer(kind=iknd), dimension(2) :: ig real(kind=rknd), dimension(2) :: rg character(len=15), dimension(*) :: name character(len=15), save, dimension(20) :: name0 character(len=80) :: lstr character(len=80), dimension(500) :: file character(len=80), dimension(5) :: sg cy 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 i=1,len lstr=file(i) call fxcase(lstr,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(icomnt==1.or.length==0) cycle if(lstr(1:1)/='n') cycle c nlen=nlen+1 name(nlen)=' ' do j=1,5 sg(j)=' ' enddo call lookup(name0,5_iknd,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) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkcmd(file,len,name,nlen,nptr,labels,values, + ncmd,ctable,st,sty,iptr,ip,rp,sp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: iptr,st,nptr integer(kind=iknd), dimension(24) :: lcomma,lequal,inum,snum integer(kind=iknd), dimension(300) :: num integer(kind=iknd), dimension(2) :: ig integer(kind=iknd), dimension(500) :: jv integer(kind=iknd), dimension(200) :: iv,ic integer(kind=iknd), dimension(100) :: ip integer(kind=iknd), save :: mxnam=300,mxcmd=24, + mxvar=500,mxlst=500 real(kind=rknd), dimension(2) :: rg real(kind=rknd), dimension(100) :: rp character(len=1) :: typ,jtyp,uppera,upperz,cc character(len=1), dimension(*) :: sty character(len=15), dimension(*) :: name,ctable character(len=15), save, dimension(20) :: name0 character(len=15) :: ntemp character(len=80) :: lstr character(len=80), dimension(*) :: labels,values,file character(len=80), dimension(5) :: sg character(len=80), dimension(100) :: sp character(len=80), dimension(500) :: l0,v0 cy 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'/ 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==1.or.length==0) then ishift=ishift+1 else cc=lstr(1:1) if(cc>=uppera.and.cc<=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)=='n') then nlen=nlen+1 if(nlen>mxnam) stop 3001 name(nlen)=' ' do j=1,5 sg(j)=' ' enddo call lookup(name0(1),5_iknd,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=='i'.or.typ=='r'.or.typ=='s') ilen=ilen+1 if(sg(5)/=' ') then call cint(sg(1),3_iknd,indx,ierr) call fstr(lstr,length,sg(5),0_iknd) if(typ=='i') then call cint(lstr,length,ip(indx),ierr) else if(typ=='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)=='c') then ncmd=ncmd+1 if(ncmd>mxcmd) stop 3002 ctable(ncmd)=' ' do j=1,3 sg(j)=' ' enddo call lookup(name0(6),3_iknd,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 5 i=1,ilen typ=name(i)(15:15) if(typ=='i'.or.typ=='r'.or.typ=='s') cycle do j=nn,nlen jtyp=name(j)(15:15) if(jtyp=='i'.or.jtyp=='r'.or.jtyp=='s') then ntemp=name(i) name(i)=name(j) name(j)=ntemp nn=j+1 go to 5 endif enddo stop 9413 5 continue 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)=='r') then ilen=ilen+1 if(ilen>mxvar) stop 3003 do j=1,3 sg(j)=' ' enddo call lookup(name0(9),3_iknd,ig,rg,sg,file(i), + ierr,length) do j=1,ncmd if(sg(1)(1:6)==ctable(j)(1:6)) go to 10 enddo stop 1001 10 ic(ilen)=j do j=1,nlen if(sg(2)(1:6)==name(j)(5:10)) go to 20 enddo stop 1002 20 iv(ilen)=j if(sg(3)(1:1)=='1') iv(ilen)=-j typ=name(j)(15:15) if(typ=='i'.or.typ=='r'.or.typ=='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)=='s') then jlen=jlen+1 if(jlen>mxlst) stop 3004 do j=1,3 sg(j)=' ' enddo call lookup(name0(12),3_iknd,ig,rg,sg,file(i), + ierr,length) do j=1,nlen if(sg(1)(1:6)==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=abs(iv(i)) typ=name(ivar)(15:15) if(typ=='i'.or.typ=='r'.or.typ=='s') then k=inum(icmd) inum(icmd)=k+1 else k=snum(icmd) snum(icmd)=k+1 endif iptr(k)=ivar if(iv(i)<0) then call cint(name(ivar),3_iknd,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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine usrset(file,len,ip,rp,sp) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(5) :: iptr,st integer(kind=iknd), dimension(301) :: nptr integer(kind=iknd), dimension(100) :: ip real(kind=rknd), dimension(100) :: rp character(len=1), dimension(5) :: sty character(len=15), dimension(300) :: name character(len=15), dimension(5) :: ctable character(len=80), dimension(500) :: labels,values character(len=80), dimension(*) :: file character(len=80), dimension(100) :: sp cy c mkcmd interface for usrcmd c if(len>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine gtfile(file,len) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=80), save, dimension(500) :: file0 character(len=80), dimension(*) :: file cy data (file0(i),i= 1, 10)/ + 'ni=1,n=ntf,t=i', 1 'ni=2,n=nvf,t=i', 2 'ni=3,n=nbf,t=i', 3 'ni=4,n=ndf,t=i', 4 'ni=5,n=ifirst,t=i,a=f,d="1"', 5 'ni=6,n=iprob,t=i,a=p,d="1"', 6 'ni=7,n=itask,t=i,a=t,d="0"', 7 'ni=8,n=ispd,t=i,a=i,d="0"', 8 'ni=9,n=method,t=i,a=mt,d="1"', 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=18,n=irtype,t=i,a=i,d="0"', 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=ndtrgt,t=i,a=n', 8 'ni=24,n=mflag,t=i,a=m,d="0"', 9 'ni=25,n=iflag,t=i'/ data (file0(i),i= 21, 30)/ + 'ni=27,n=newntf,t=i', 1 'ni=28,n=newnvf,t=i', 2 'ni=29,n=newnbf,t=i', 3 'ni=30,n=newndf,t=i', 4 'ni=31,n=nvv,t=i', 5 'ni=32,n=nbb,t=i', 6 'ni=33,n=ndd,t=i', 7 'ni=34,n=nvi,t=i', 8 'ni=35,n=nbi,t=i', 9 'ni=36,n=ndi,t=i'/ data (file0(i),i= 31, 40)/ + 'ni=37,n=ntg,t=i', 1 'ni=38,n=nvg,t=i', 2 'ni=39,n=nbg,t=i', 3 'ni=40,n=ndg,t=i', 4 'ni=41,n=iusrsw,t=i,d="1"', 5 'ni=42,n=mode,t=i,d="0"', 6 'ni=43,n=ngraph,t=i,d="0"', 7 'ni=44,n=fdevce,t=i,a=d,d="0"', 8 'ni=45,n=gdevce,t=i,a=d,d="1"', 9 'ni=46,n=jdevce,t=i,a=d,d="2"'/ data (file0(i),i= 41, 50)/ + 'ni=47,n=mpirgn,t=i,a=mr,d="0"', 1 'ni=48,n=mpisw,t=i,a=i,d="-1"', 2 'ni=49,n=nproc,t=i,d="1"', 3 'ni=50,n=irgn,t=i,d="1"', 4 'ni=51,n=mxcolr,t=i,a=mc,d="256"', 5 'ni=52,n=ifun,t=i,a=f,d="0"', 6 'ni=53,n=inplsw,t=i,a=i,d="0"', 7 'ni=54,n=igrsw,t=i,a=i,d="0"', 8 'ni=56,n=ncon,t=i,a=c,d="11"', 9 'ni=57,n=icont,t=i,a=ic,d="0"'/ data (file0(i),i= 51, 60)/ + 'ni=58,n=iscale,t=i,a=s,d="0"', 1 'ni=59,n=lines,t=i,a=l,d="0"', 2 'ni=60,n=numbrs,t=i,a=n,d="0"', 3 'ni=61,n=nx,t=i,a=nx,d="0"', 4 'ni=62,n=ny,t=i,a=ny,d="0"', 5 'ni=63,n=nz,t=i,a=nz,d="1"', 6 'ni=64,n=mx,t=i,a=mx,d="1"', 7 'ni=65,n=my,t=i,a=my,d="-1"', 8 'ni=66,n=mz,t=i,a=mz,d="1"', 9 'ni=68,n=icrsn,t=i,a=cr,d="0"'/ data (file0(i),i= 61, 70)/ + 'ni=69,n=itrgt,t=i,a=it,d="10000"', 1 'ni=71,n=nvdd,t=i', 2 'ni=72,n=lipath,t=i', 3 'ni=76,n=nef,t=i', 4 'ni=77,n=ngf,t=i', 5 'ni=78,n=ndl,t=i', 6 'ni=79,n=ievals,t=i', 7 'ni=80,n=itnum,t=i', 8 'ni=82,n=maxpth,t=i', 9 'ni=83,n=maxt,t=i'/ data (file0(i),i= 71, 80)/ + 'ni=84,n=maxv,t=i', 1 'ni=85,n=maxd,t=i', 2 'ni=86,n=maxb,t=i', 3 'ni=90,n=ndf,t=i', 4 'ni=91,n=nb,t=i', 5 'ni=92,n=lenja,t=i', 6 'ni=93,n=lenad,t=i', 7 'ni=94,n=lenaod,t=i', 8 'ni=95,n=lenju,t=i', 9 'ni=96,n=lenuod,t=i'/ data (file0(i),i= 81, 90)/ + 'ni=97,n=lenju0,t=i', 1 'ni=98,n=lenu0,t=i', 2 'ni=99,n=lenja0,t=i,d="0"', 3 'ni=100,n=lenjuc,t=i,d="0"', 4 'ni=1,n=rltrgt,t=r,a=l,d="0.0e0"', 5 'ni=2,n=rtrgt,t=r,a=r,d="0.0e0"', 6 'ni=3,n=rmtrgt,t=r,a=m,d="0.1e0"', 7 'ni=4,n=rllwr,t=r,a=lw,d="0.0e0"', 8 'ni=5,n=rlupr,t=r,a=up,d="1.0e0"', 9 'ni=6,n=dtol,t=r,a=d,d="1.0e-3"'/ data (file0(i),i= 91,100)/ + 'ni=7,n=hbtol,t=r,a=h,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=101,110)/ + '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=111,120)/ + '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=121,130)/ + '#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=52,n=step,t=r,d="1.0e0"', 5 'ni=53,n=reler0,t=r,d="1.0e0"', 6 'ni=54,n=relerr,t=r,d="1.0e0"', 7 'ni=55,n=anorm,t=r,d="1.0d0"', 8 'ni=56,n=relres,t=r,d="1.0e0"', 9 'ni=57,n=bratio,t=r,d="1.0e0"'/ data (file0(i),i=131,140)/ + 'ni=58,n=dnew,t=r', 1 'ni=59,n=bnorm0,t=r', 2 'ni=60,n=bmnrm0,t=r', 3 'ni=63,n=rmu,t=r,d="1.0e0"', 4 'ni=64,n=reg,t=r,d="1.0e0"', 5 'ni=67,n=scleqn,t=r', 6 'ni=68,n=scale,t=r', 7 'ni=69,n=thetal,t=r', 8 'ni=70,n=thetar,t=r', 9 'ni=71,n=sigma,t=r'/ data (file0(i),i=141,150)/ + 'ni=72,n=delta,t=r', 1 'ni=73,n=drdrl,t=r', 2 'ni=74,n=seqdot,t=r', 3 'ni=76,n=qual,t=r', 4 'ni=77,n=angmn,t=r,d="0.25e0"', 5 'ni=78,n=diam,t=r', 6 'ni=79,n=best,t=r', 7 'ni=80,n=area,t=r', 8 'ni=82,n=sfave,t=r', 9 'ni=83,n=sfvar,t=r'/ data (file0(i),i=151,160)/ + 'ni=84,n=sfmin,t=r', 1 'ni=85,n=sfmax,t=r', 2 'ni=86,n=relerp,t=r', 3 'ni=87,n=eave2,t=r', 4 'ni=89,n=xmin,t=r', 5 'ni=90,n=ymin,t=r', 6 'ni=91,n=xmax,t=r', 7 'ni=92,n=ymax,t=r', 8 'ni=95,n=n0,t=r', 9 'ni=96,n=e0,t=r'/ data (file0(i),i=161,170)/ + 'ni=97,n=nf,t=r', 1 'ni=98,n=ef,t=r', 2 'ni=1,n=ftitle,t=l,a=t,d="triplt"', 3 'ni=2,n=ititle,t=l,a=t,d="inplt"', 4 'ni=3,n=gtitle,t=l,a=t,d="gphplt"', 5 'ni=5,n=shcmd,t=l,a=c', 6 'ni=6,n=rwfile,t=f,a=f,d="pltmg_mpixxx.rw"', 7 'ni=7,n=jrfile,t=f,a=f,d="pltmg.jnl"', 8 'ni=8,n=jwfile,t=f,d="journl_mpixxx.jnl"', 9 'ni=9,n=bfile,t=f,d="output_mpixxx.out"'/ data (file0(i),i=171,180)/ + 'ni=10,n=jtfile,t=f,d="jnltmp_mpixxx.jnl"', 1 'ni=11,n=iomsg,t=l', 2 'ni=12,n=cmd,t=s', 3 'ni=13,n=logo,t=l,d="pltmg 11.0"', 4 'ni=14,n=bgclr,t=l,d="gray85"', 5 'ni=15,n=btnbg,t=l,d="gray30"', 6 'ni=18,n=psfile,t=f,d="figxxx.ps"', 7 'ni=19,n=xpfile,t=f,d="figxxx.xpm"', 8 'ni=20,n=bhfile,t=f,d="figxxx.bh"', 9 'ni=21,n=sghost,t=f,d="localhost"'/ data (file0(i),i=181,190)/ + 'cc=pltmg,k=s,t=popup', 1 'cc=trigen,k=t,t=popup', 2 'cc=triplt,k=f,t=popup', 3 'cc=gphplt,k=g,t=popup', 4 'cc=inplt,k=i,t=popup', 5 'cc=read,k=r,t=file', 6 'cc=write,k=w,t=file', 7 'cc=usrcmd,k=u,t=usrcmd', 8 'cc=journl,k=j,t=journl', 9 'cc=shell,k=k,t=popup'/ data (file0(i),i=191,200)/ + 'cc=mpi,k=p,t=mpicmd', 1 'cc=quit,k=q,t=quit', 2 'rc=pltmg,n=iprob', 3 'rc=pltmg,n=ifirst', 4 'rc=pltmg,n=itask', 5 'rc=pltmg,n=ispd', 6 'rc=pltmg,n=mxcg', 7 'rc=pltmg,n=mxnwtt', 8 'rc=pltmg,n=rltrgt', 9 'rc=pltmg,n=rtrgt'/ data (file0(i),i=201,210)/ + 'rc=pltmg,n=dtol', 1 'rc=pltmg,n=hbtol', 2 'rc=pltmg,n=rllwr', 3 'rc=pltmg,n=rlupr', 4 'rc=pltmg,n=method', 5 'rc=pltmg,n=rmtrgt', 6 '#rc=pltmg,n=mxstep', 7 '#rc=pltmg,n=tmtol', 8 '#rc=pltmg,n=tstart', 9 '#rc=pltmg,n=tend'/ data (file0(i),i=211,220)/ + 'rc=trigen,n=iadapt', 1 'rc=trigen,n=ifirst', 2 'rc=trigen,n=ndtrgt', 3 'rc=trigen,n=irtype', 4 'rc=trigen,n=ierrsw', 5 'rc=trigen,n=irefn', 6 'rc=trigen,n=hmax', 7 'rc=trigen,n=hmin', 8 'rc=trigen,n=grade', 9 'rc=triplt,n=ifun,s=1'/ data (file0(i),i=221,230)/ + 'rc=triplt,n=iscale', 1 'rc=triplt,n=lines', 2 'rc=triplt,n=numbrs', 3 'rc=triplt,n=fdevce', 4 'rc=triplt,n=nx', 5 'rc=triplt,n=ny', 6 'rc=triplt,n=nz', 7 'rc=triplt,n=ncon', 8 'rc=triplt,n=icont', 9 'rc=triplt,n=icrsn'/ data (file0(i),i=231,240)/ + 'rc=triplt,n=itrgt', 1 'rc=triplt,n=mxcolr', 2 'rc=triplt,n=smin', 3 'rc=triplt,n=smax', 4 'rc=triplt,n=rmag', 5 'rc=triplt,n=cenx', 6 'rc=triplt,n=ceny', 7 'rc=triplt,n=mpirgn', 8 'rc=triplt,n=ftitle', 9 'rc=gphplt,n=igrsw,s=1'/ data (file0(i),i=241,250)/ + 'rc=gphplt,n=mx', 1 'rc=gphplt,n=my', 2 'rc=gphplt,n=mz', 3 'rc=gphplt,n=gdevce', 4 'rc=gphplt,n=mxcolr', 5 'rc=gphplt,n=mpirgn', 6 'rc=gphplt,n=gtitle', 7 'rc=inplt,n=inplsw,s=1', 8 'rc=inplt,n=iscale', 9 'rc=inplt,n=lines'/ data (file0(i),i=251,260)/ + 'rc=inplt,n=numbrs', 1 'rc=inplt,n=jdevce', 2 'rc=inplt,n=rmag', 3 'rc=inplt,n=cenx', 4 'rc=inplt,n=ceny', 5 'rc=inplt,n=ncon', 6 'rc=inplt,n=mxcolr', 7 'rc=inplt,n=icrsn', 8 'rc=inplt,n=itrgt', 9 'rc=inplt,n=ititle'/ data (file0(i),i=261,270)/ + 'rc=inplt,n=smin', 1 'rc=inplt,n=smax', 2 'rc=inplt,n=mpirgn', 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=mpirgn', 9 'rc=mpi,n=mflag'/ data (file0(i),i=271,280)/ + 'sn=ifirst,v=0,l="default"', 1 'sn=ifirst,v=1,l="initialize linear elements"', 2 'sn=ifirst,v=2,l="initialize quadratic elements"', 3 'sn=ifirst,v=3,l="initialize cubic elements"', 4 'sn=ifirst,v=4,l="initialize quartic elements"', 5 'sn=ifirst,v=5,l="initialize quintic elements"', 6 'sn=ifirst,v=6,l="initialize degree 6 elements"', 7 'sn=ifirst,v=7,l="initialize degree 7 elements"', 8 'sn=ifirst,v=8,l="initialize degree 8 elements"', 9 'sn=ifirst,v=9,l="initialize degree 9 elements"'/ data (file0(i),i=281,290)/ + 'sn=iprob,v=1,l="simple pde"', 1 'sn=iprob,v=2,l="obstacle problem"', 2 'sn=iprob,v=3,l="continuation problem"', 3 'sn=iprob,v=4,l="parameter identification"', 4 'sn=iprob,v=5,l="optimal control"', 5 '#sn=iprob,v=6,l="shape optimization"', 6 '#sn=iprob,v=7,l="parabolic problem"', 7 'sn=iprob,v=-1,l="dd solve - simple pde (mpi) "', 8 'sn=iprob,v=-2,l="dd solve - obstacle (mpi)"', 9 'sn=iprob,v=-3,l="dd solve - continuation (mpi)"'/ data (file0(i),i=291,300)/ + 'sn=iprob,v=-4,l="dd solve - parameter identification (mpi)"', 1 'sn=iprob,v=-5,l="dd solve - optimal control (mpi)"', 2 '#sn=iprob,v=-6,l="dd solve - shape optimization (mpi)"', 3 'sn=ispd,v=0,l="nonsymmetric"', 4 'sn=ispd,v=1,l="symmetric"', 5 'sn=itask,v=0,l="target point / default"', 6 'sn=itask,v=1,l="compute singular point"', 7 'sn=itask,v=2,l="switch branches"', 8 'sn=itask,v=3,l="initialize, lambda fixed"', 9 'sn=itask,v=4,l="initialize, rho fixed"'/ data (file0(i),i=301,310)/ + 'sn=itask,v=5,l="sigma = 0, lambda fixed"', 1 'sn=itask,v=6,l="sigma = 0, rho fixed"', 2 'sn=itask,v=7,l="sigma = 0, theta = 1"', 3 'sn=itask,v=8,l="new lambda"', 4 'sn=itask,v=9,l="use functional"', 5 'sn=itask,v=10,l="time steps"', 6 'sn=itask,v=11,l="fixed time"', 7 'sn=method,v=0,l="hb"', 8 'sn=method,v=1,l="ilu + hb"', 9 'sn=method,v=-1,l="ilu"'/ data (file0(i),i=311,320)/ + 'sn=method,v=2,l="sgs + hb"', 1 'sn=method,v=-2,l="sgs"', 2 'sn=irtype,v=1,l="h-adaptive only"', 3 'sn=irtype,v=-1,l="p-adaptive only"', 4 'sn=irtype,v=0,l="hp-adaptive"', 5 'sn=ierrsw,v=0,l="global continuous recovery"', 6 'sn=ierrsw,v=1,l="patchwise continuous recovery"', 7 'sn=iadapt,v=0,l="error estimates"', 8 'sn=iadapt,v=1,l="refine or unrefine"', 9 'sn=iadapt,v=-1,l="refine or unrefine (qxy)"'/ data (file0(i),i=321,330)/ + 'sn=iadapt,v=2,l="unrefine and refine"', 1 'sn=iadapt,v=-2,l="unrefine and refine (qxy)"', 2 'sn=iadapt,v=3,l="mesh smoothing"', 3 'sn=iadapt,v=-3,l="mesh smoothing (qxy)"', 4 'sn=iadapt,v=4,l="uniform mesh refinement"', 5 'sn=iadapt,v=-4,l="uniform degree refinement"', 6 'sn=iadapt,v=5,l="skeleton --> triangulation"', 7 'sn=iadapt,v=6,l="load balance (mpi)"', 8 'sn=iadapt,v=7,l="reconcile mesh (mpi)"', 9 'sn=fdevce,v=0,l="socket 0"'/ data (file0(i),i=331,340)/ + 'sn=fdevce,v=1,l="socket 1"', 1 'sn=fdevce,v=2,l="socket 2"', 2 'sn=fdevce,v=3,l="socket 3"', 3 'sn=fdevce,v=4,l="bh file"', 4 'sn=fdevce,v=5,l="ps file"', 5 'sn=fdevce,v=6,l="xpm file"', 6 'sn=fdevce,v=7,l="popup 0"', 7 'sn=fdevce,v=8,l="popup 1"', 8 'sn=fdevce,v=9,l="popup 2"', 9 'sn=fdevce,v=10,l="popup 3"'/ data (file0(i),i=341,350)/ + 'sn=gdevce,v=0,l="socket 0"', 1 'sn=gdevce,v=1,l="socket 1"', 2 'sn=gdevce,v=2,l="socket 2"', 3 'sn=gdevce,v=3,l="socket 3"', 4 'sn=gdevce,v=4,l="bh file"', 5 'sn=gdevce,v=5,l="ps file"', 6 'sn=gdevce,v=6,l="xpm file"', 7 'sn=gdevce,v=7,l="popup 0"', 8 'sn=gdevce,v=8,l="popup 1"', 9 'sn=gdevce,v=9,l="popup 2"'/ data (file0(i),i=351,360)/ + 'sn=gdevce,v=10,l="popup 3"', 1 'sn=jdevce,v=0,l="socket 0"', 2 'sn=jdevce,v=1,l="socket 1"', 3 'sn=jdevce,v=2,l="socket 2"', 4 'sn=jdevce,v=3,l="socket 3"', 5 'sn=jdevce,v=4,l="bh file"', 6 'sn=jdevce,v=5,l="ps file"', 7 'sn=jdevce,v=6,l="xpm file"', 8 'sn=jdevce,v=7,l="popup 0"', 9 'sn=jdevce,v=8,l="popup 1"'/ data (file0(i),i=361,370)/ + 'sn=jdevce,v=9,l="popup 2"', 1 'sn=ifun,v=0,l="u"', 2 'sn=ifun,v=1,l="|grad u|"', 3 'sn=ifun,v=2,l="grad u"', 4 'sn=ifun,v=3,l="qxy"', 5 'sn=ifun,v=4,l="vector qxy"', 6 'sn=ifun,v=5,l="error"', 7 'sn=ifun,v=6,l="udot"', 8 'sn=ifun,v=7,l="evr"', 9 'sn=ifun,v=8,l="evl"'/ data (file0(i),i=371,380)/ + 'sn=ifun,v=9,l="um"', 1 'sn=ifun,v=10,l="uc"', 2 'sn=ifun,v=11,l="dual"', 3 'sn=ifun,v=12,l="scaling factor"', 4 'sn=inplsw,v=0,l="region tag"', 5 'sn=inplsw,v=1,l="load balance"', 6 'sn=inplsw,v=2,l="element quality"', 7 'sn=inplsw,v=3,l="max angle"', 8 'sn=inplsw,v=4,l="min angle"', 9 'sn=inplsw,v=5,l="element diameter"'/ data (file0(i),i=381,390)/ + 'sn=inplsw,v=6,l="error"', 1 'sn=inplsw,v=7,l="scaling factor"', 2 'sn=inplsw,v=8,l="polynomial degree"', 3 'sn=igrsw,v=0,l="newton conv"', 4 'sn=igrsw,v=1,l="linear eqns conv"', 5 'sn=igrsw,v=-1,l="matrix stats"', 6 'sn=igrsw,v=2,l="subroutine times"', 7 'sn=igrsw,v=-2,l="time pie chart"', 8 'sn=igrsw,v=3,l="continuation path"', 9 'sn=igrsw,v=-3,l="load balance"'/ data (file0(i),i=391,400)/ + 'sn=igrsw,v=4,l="h1 error"', 1 'sn=igrsw,v=-4,l="l2 error"', 2 'sn=igrsw,v=5,l="ip array"', 3 'sn=igrsw,v=-5,l="sp array"', 4 'sn=igrsw,v=6,l="rp array"', 5 'sn=icont,v=0,l="do not smooth function"', 6 'sn=icont,v=1,l="smooth function"', 7 'sn=iscale,v=0,l="linear"', 8 'sn=iscale,v=1,l="log"', 9 'sn=iscale,v=2,l="arcsinh"'/ data (file0(i),i=401,410)/ + 'sn=lines,v=0,l="triangulation"', 1 'sn=lines,v=1,l="regions"', 2 'sn=lines,v=2,l="load balance"', 3 'sn=lines,v=3,l="contours"', 4 'sn=lines,v=-1,l="graphics triangulation"', 5 'sn=numbrs,v=0,l="none"', 6 'sn=numbrs,v=1,l="triangles/regions"', 7 'sn=numbrs,v=2,l="vertices"', 8 'sn=numbrs,v=3,l="edges"', 9 'sn=numbrs,v=4,l="arcs"'/ data (file0(i),i=411,419)/ + 'sn=numbrs,v=5,l="bdy cond"', 1 'sn=numbrs,v=6,l="bdy tag"', 2 'sn=numbrs,v=7,l="processor"', 3 'sn=numbrs,v=8,l="vertex type"', 4 'sn=numbrs,v=9,l="degrees of freedom"', 5 'sn=icrsn,v=0,l="no coarsening"', 6 'sn=icrsn,v=1,l="coarsening"', 7 'sn=mpisw,v=1,l="turn on mpi"', 8 'sn=mpisw,v=-1,l="turn off mpi"'/ c data len0/419/ 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mktabl(icmd,name,iptr,sname, + nptr,labels,values,sptr,slabel,svalue) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: iptr,nptr,sptr character(len=15), dimension(*) :: name,sname character(len=80), dimension(*) :: labels,values,slabel character(len=80), dimension(*) :: svalue cy 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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine getcmd(list) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=80) :: list common /atest3/mode,jnlsw,jnlr,jnlw,ibatch cy 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<0) then call crtutl(list,'r','command:') else if(jnlsw>0) then call ascstr(jnlr,list,80_iknd,kflag) if(kflag/=0) then call ascutl(jnlr,list,'c',kflag) if(mode==1.or.jnlsw==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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine lookup(name,num,ip,rp,sp,list,ierr,length) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(24) :: ival,lequal,lcomma,iptr integer(kind=iknd), dimension(*) :: ip real(kind=rknd), dimension(*) :: rp real(kind=rknd), dimension(24) :: rval character(len=80), dimension(*) :: sp character(len=80), dimension(24) :: sval character(len=15), dimension(*) :: name character(len=6) :: lname character(len=2) :: sname character(len=*) :: list character(len=1), save :: dbleq='"' cy c determine number of entries c ierr=0 call fxcase(list,length,ncomma,nequal,ndbleq, + lcomma,lequal,icomnt) if(num<=0.or.length==1) return ierr=1 if(icomnt==1.or.(ndbleq/2)*2/=ndbleq) return if(nequal==0.or.ncomma/=nequal-1) return if(ncomma>0) then do i=1,ncomma if(lcomma(i)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>1) istart=lcomma(ii-1)+1 if(ii=imid) return if(istart+6=uppera.and.cc<=upperz) then ii=ichar(cc)+32 if(length>1.and.nequal==ncomma) + cc=char(ii) endif list(length:length)=cc endif else length=length+1 list(length:length)=cc if(cc==dbleq) ndbleq=ndbleq+1 endif enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sreal(list,length,val,ndig,just) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd) :: elen,mlen,just character(len=*) :: list character(len=1), save :: zero='0',minus='-', + e='e',dot='.' character(len=100) :: ex,mant cy c compute character string for floating point number c if(val==0.0e0_rknd) then length=3 list(1:1)=zero list(2:2)=dot list(3:3)=zero else zc=abs(val) zz=log10(zc) iex=int(zz) ratio=10.0e0_rknd**(zz-real(iex,rknd)) c** ratio=zc*(10.0e0_rknd**(-iex)) if(iex==-1) then h=0.5e0_rknd*10.0e0_rknd**(2-ndig) else h=0.5e0_rknd*10.0e0_rknd**(1-ndig) endif if(ratio+h<1.0e0_rknd) then ratio=ratio*10.0e0_rknd iex=iex-1 else if(ratio+h>=10.0e0_rknd) then ratio=ratio/10.0e0_rknd iex=iex+1 endif c c exponent field c call sint(ex,elen,iex) c c mantissa field c if(iex==-1) then n=int(ratio*10.0e0_rknd**(ndig-2)+0.5e0_rknd) else n=int(ratio*10.0e0_rknd**(ndig-1)+0.5e0_rknd) endif c if(just/=1) then 90 k=n/10 j=n-10*k if(j==0) then n=k go to 90 endif endif call sint(mant,mlen,n) if(val>0) then is=0 else is=1 list(1:1)=minus endif if(iex==-1) then list(is+1:is+1)=zero list(is+2:is+2)=dot do i=1,mlen list(is+i+2:is+i+2)=mant(i:i) enddo mlen=mlen+1 iex=0 else if(iex==1) then list(is+1:is+1)=mant(1:1) list(is+2:is+2)=zero list(is+3:is+3)=dot list(is+4:is+4)=zero if(mlen<=2) then if(mlen==2) list(is+2:is+2)=mant(2:2) mlen=3 else list(is+2:is+2)=mant(2:2) do i=3,mlen list(is+i+1:is+i+1)=mant(i:i) enddo endif iex=0 else list(is+1:is+1)=mant(1:1) list(is+2:is+2)=dot if(mlen==1) then list(is+3:is+3)=zero mlen=mlen+1 else do i=2,mlen list(is+i+1:is+i+1)=mant(i:i) enddo endif endif if(iex/=0) then length=elen+mlen+2+is list(is+mlen+2:is+mlen+2)=e do i=1,elen list(is+mlen+2+i:is+mlen+2+i)=ex(i:i) enddo else length=mlen+1+is endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sint(list,length,ival) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(100) :: temp character(len=*) :: list character(len=10), save :: num='0123456789' character(len=1), save :: minus='-' cy c compute character string for integer c if(ival==0) then length=1 list(1:1)=num(1:1) else length=0 n=abs(ival) 10 j=n/10 i=n-j*10 length=length+1 temp(length)=i+1 n=j if(n>0) go to 10 if(ival<0) then list(1:1)=minus do i=1,length j=temp(length+1-i) list(i+1:i+1)=num(j:j) enddo length=length+1 else do i=1,length j=temp(length+1-i) list(i:i)=num(j:j) enddo endif endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine fstr(ss,length,sval,iquote) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: mxchar=80 character(len=1), save :: blank=' ',dbleq='"' character(len=80) :: ss,sval cy istart=mxchar+1 istop=0 ss=' ' do i=1,mxchar if(sval(i:i)==blank) cycle istart=min(istart,i) istop=max(istop,i) enddo if(iquote==1) then ss(1:1)=dbleq if(istart>istop) then length=3 else length=istop-istart+3 if(length>mxchar) then istop=istop-(length-mxchar) length=mxchar endif ss(2:length-1)=sval(istart:istop) endif ss(length:length)=dbleq else if(istart>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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkname(outnam,innam) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: num=0 character(len=80) :: innam,outnam,temp common /atest6/nproc,myid,mpisw,mpiint,mpiflt cy c look for key string and insert number c num=num+1 cccc if(mpisw==1) call exnum(num) call fstr(outnam,length,innam,0_iknd) do i=6,length if(outnam(i-5:i)=='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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine creal(list,length,val,ierr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd) :: zero character(len=*) :: list character(len=1), save :: dot='.',lce='e',blank=' ', + plus='+',minus='-',lcd='d' character(len=1) :: uce,cc,ucd character(len=1), dimension(80) :: temp cy 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_rknd ierr=1 newlen=0 idot=length+1 iee=length+1 do i=1,length cc=list(i:i) list(i:i)=blank if(cc==blank) cycle newlen=newlen+1 temp(newlen)=cc list(newlen:newlen)=cc if(temp(newlen)==lce) iee=newlen if(temp(newlen)==uce) iee=newlen if(temp(newlen)==lcd) iee=newlen if(temp(newlen)==ucd) iee=newlen if(temp(newlen)==dot) idot=newlen enddo if(newlen==0) return c c exponent c if(iee<=newlen) then if(iee==1.or.iee==newlen) return ll=newlen-iee call cint(temp(iee+1),ll,ix,jerr) if(jerr/=0) return newlen=iee-1 else ix=0 endif c c mantissa c if(idot<=newlen) then if(newlen==1) return ix=ix+idot-newlen newlen=newlen-1 if(idot<=newlen) then do i=idot,newlen temp(i)=temp(i+1) enddo endif endif c c sign c if(temp(1)==minus.or.temp(1)==plus) then if(newlen==1) return ii=2 else ii=1 endif c zero=ichar('0') value=0.0e0_rknd do i=ii,newlen kx=ichar(temp(i))-zero if(kx<0.or.kx>9) return value=10.0e0_rknd*value+real(kx,rknd) enddo if(temp(1)==minus) then val=-value*(10.0e0_rknd**ix) else val=value*(10.0e0_rknd**ix) endif ierr=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cint(list,length,ival,ierr) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd) :: zero character(len=*) :: list character(len=1), save :: blank=' ',plus='+',minus='-' character(len=1), dimension(80) :: temp character(len=1) :: cc cy c compute an integer from a-format input c ierr=1 ival=0 newlen=0 do i=1,length cc=list(i:i) list(i:i)=blank if(cc==blank) cycle newlen=newlen+1 temp(newlen)=cc list(newlen:newlen)=cc enddo if(newlen==0) return c c sign c if(temp(1)==minus.or.temp(1)==plus) then if(newlen==1) return ii=2 else ii=1 endif c c zero=ichar('0') do i=ii,newlen ix=ichar(temp(i))-zero if(ix<0.or.ix>9) return ival=10*ival+ix enddo if(temp(1)==minus) ival=-ival ierr=0 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine cpause() cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=80) :: cc common /atest3/mode,jnlsw,jnlr,jnlw,ibatch cy c wait for user to view picture c if(mode==0.and.jnlsw==1) then call xpause() else if(mode==-1.and.jnlsw==1) then call crtutl(cc,'r','pause: ') endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine crtutl(list,mode,prompt) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: icrtr=5,icrtw=6 character(len=1) :: mode character(len=8) :: prompt character(len=80) :: list cy c print a prompt symbol c if(mode=='r') then write(icrtw,fmt='(/ a8 $)') prompt flush(icrtw) read(icrtr,fmt='(a80)') list flush(icrtr) else if(mode=='w') then write(icrtw,fmt='(a80)') list flush(icrtw) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine filutl(list,isw) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=1), save :: lowerj='j' character(len=80) :: list character(len=80), save :: blank=' ' character(len=100) :: msg common /atest3/mode,jnlsw,jnlr,jnlw,ibatch cy if(isw==1) then if(list(1:1)==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)/=' ') len=i enddo call ascstr(jnlw,msg,len,iflag) write(unit=msg,fmt='(a8,a80)') 'command:',list c call ascstr(ibatch,blank,1_iknd,iflag) call ascstr(ibatch,msg,80_iknd,iflag) c if(mode==0) then call xtext(blank) call xtext(msg) endif c if(mode==-1.and.jnlsw==1) then call crtutl(blank,'w','prompt: ') call crtutl(msg,'w','prompt: ') endif else call ascstr(ibatch,list,80_iknd,iflag) if(mode==0) call xtext(list) if(mode==-1) call crtutl(list,'w','prompt: ') endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine mkjnl(sp,iflag) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(11) :: jnlr integer(kind=iknd), dimension(24) :: lequal,lcomma integer(kind=iknd), save :: maxd=10 character(len=1) :: lowerj,upperj character(len=80), dimension(100) :: sp character(len=80), dimension(11) :: name character(len=80) :: list,filnam cy c make journal file c lowerj=char(106) upperj=char(74) do i=1,maxd name(i)=' ' jnlr(i)=-1 enddo if(sp(10)==' ') 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/=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)==' ') then sp(11)='journl: bad filename' go to 50 endif if(level>=maxd) then sp(11)='journl: too many levels' go to 50 endif do i=1,level-1 if(name(level)==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/=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_iknd,kflag) if(kflag>0) then sp(11)='journl: read error' go to 50 endif if(kflag==-1) then c c close current file, reduce level c call ascutl(jnlr(level),filnam,'c',jflag) if(jflag/=0) then sp(11)='journl: cannot close file' return endif jnlr(level)=-1 level=level-1 if(level>=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<=0) then go to 20 c c check for journal commands c else if(list(1:1)==lowerj.or.list(1:1)==upperj) then if(ncomma>0.or.ndbleq>0.or.nequal>=2) then sp(11)='journl: command error' go to 50 endif if(nequal==1) then ll=length-lequal(1) name(level+1)=' ' name(level+1)(1:ll)=list(lequal(1)+1:length) endif if(list(1:1)==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>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)==-1) cycle call ascutl(jnlr(i),filnam,'c',kflag) enddo iflag=-7 return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine stfile(outnam,innam) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=80) :: innam,outnam,temp common /atest6/nproc,myid,mpisw,mpiint,mpiflt cy c look for key strng and replace with proc number c call fstr(outnam,length,innam,0_iknd) do i=6,length if(outnam(i-5:i)=='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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pltutl(ncolor,red,green,blue) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: red,green,blue character(len=80) :: fname,fname0,sp common /atest1/ip(100),rp(100),sp(100) common /atest5/idevce cy c ncolor > 0 -- initialize graphics using ncolor colors c ncolor <= 0 -- exit graphics c c socket graphics c if(idevce>=0.and.idevce<=3) then isock=idevce call fstr(fname,length,sp(21),0_iknd) call vutl(ncolor,red,green,blue,isock,fname) if(ncolor<0) call cpause() c c bh file c else if(idevce==4) then if(ncolor>0) then call mkname(fname0,sp(20)) call stfile(fname,fname0) endif call vutl(ncolor,red,green,blue,-1_iknd,fname) c c postscript file c else if(idevce==5) then if(ncolor>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==6) then if(ncolor>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>=7.and.idevce<=10) then isock=idevce-7 call xutl(ncolor,red,green,blue,isock) if(ncolor<0) call cpause() endif return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pframe(iframe) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) common /atest5/idevce cy 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>=0.and.idevce<=4) then call vframe(iframe) else if(idevce==5) then call sframe(iframe) else if(idevce>=6.and.idevce<=10) then call xframe(iframe) endif return end c*********************** machine dependent routine ********************* c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pline(x,y,z,n,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z common /atest5/idevce cy 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>=0.and.idevce<=4) then call vline(x,y,z,n,icolor) else if(idevce==5) then call pspath(x,y,z,n,icolor,0_iknd) else if(idevce>=6.and.idevce<=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pfill(x,y,z,n,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z common /atest5/idevce cy c subroutine pfill fills the n-sided polygon with c vertices (x(i),y(i)) with the indicated color c if(idevce>=0.and.idevce<=4) then call vfill(x,y,z,n,icolor) else if(idevce==5) then call pspath(x,y,z,n,icolor,1_iknd) else if(idevce>=6.and.idevce<=10) then call xfill(x,y,z,n,icolor) endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine psutl(ncolor,red,green,blue,fname) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: length real(kind=rknd), dimension(*) :: red,green,blue character(len=16), save :: hex='0123456789abcdef' character(len=80) :: msg,fname character(len=80), save :: sname common /ps0/id,scale,fscale,xshift,yshift cy 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 postscript limited to 256 colors c c print picture c if(ncolor<=0) then msg='showpage' call ascstr(id,msg,8_iknd,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_rknd fscale=1.0e0_rknd xshift=0.0e0_rknd yshift=0.0e0_rknd c call fstr(sname,length,fname,0_iknd) call ascutl(id,sname,'w',iflag) c c set main definitions c msg='%!' call ascstr(id,msg,2_iknd,iflag) c if(ipl==1) then c*** msg='%%BoundingBox: 18 204 402 588' msg='%%BoundingBox: 18 204 594 588' call ascstr(id,msg,29_iknd,iflag) msg='[384 0 0 384 18 204] concat' call ascstr(id,msg,27_iknd,iflag) else msg='%%BoundingBox: 54 18 558 774' call ascstr(id,msg,28_iknd,iflag) msg='[0 504 -504 0 558 18] concat' call ascstr(id,msg,28_iknd,iflag) endif c si=1.0e0_rknd/scale write(unit=msg,fmt='(2(f8.6,1x),a5)') si,si,'scale' call ascstr(id,msg,23_iknd,iflag) c msg='1 setlinewidth' call ascstr(id,msg,14_iknd,iflag) msg='2 setlinejoin' call ascstr(id,msg,13_iknd,iflag) msg='/s {setrgbcolor newpath moveto} def' call ascstr(id,msg,35_iknd,iflag) msg='/r {count 2 idiv {rlineto} repeat} def' call ascstr(id,msg,38_iknd,iflag) msg='/f {s r closepath fill} def' call ascstr(id,msg,27_iknd,iflag) msg='/g {s r stroke} def' call ascstr(id,msg,19_iknd,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:i1+1),hex(i0+1:i0+1),' {', 1 red(i),green(i),blue(i),'g} def' call ascstr(id,msg,27_iknd,iflag) c write(unit=msg,fmt='(a2,a1,a1,a2,3(f4.2,1x),a6)') + '/c',hex(i1+1:i1+1),hex(i0+1:i0+1),' {', 1 red(i),green(i),blue(i),'f} def' call ascstr(id,msg,27_iknd,iflag) c enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine sframe(iframe) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) character(len=80) :: msg common /ps0/id,scale,fscale,xshift,yshift cy write(unit=msg,fmt='(a3,i3)') '%%l',iframe call ascstr(id,msg,6_iknd,iflag) c if(iframe==2) then fscale=scale/2.0e0_rknd xshift=scale yshift=scale/2.0e0_rknd else if(iframe==3) then fscale=scale/2.0e0_rknd xshift=scale yshift=0.0e0_rknd else fscale=scale xshift=0.0e0_rknd yshift=0.0e0_rknd endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine pspath(x,y,z,n,icolor,itype) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z character(len=100) :: list character(len=16), save :: hex='0123456789abcdef' common /ps0/id,scale,fscale,xshift,yshift cy c print a path in compact integer form c c look for first nontrivial entry c c*** if(scale/=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==0.and.iy==0) cycle npts=npts+1 call sint(list(length+1:length+1),lenx,ix) length=length+lenx+1 list(length:length)=' ' call sint(list(length+1:length+1),leny,iy) length=length+leny+1 list(length:length)=' ' c if(length<=60) cycle call ascstr(id,list,length-1_iknd,iflag) length=0 enddo c c first point c if(npts==0) return ix=nint(x(1)*fscale+xshift) iy=nint(y(1)*fscale+yshift) call sint(list(length+1:length+1),lenx,ix) length=length+lenx+1 list(length:length)=' ' call sint(list(length+1:length+1),leny,iy) length=length+leny+1 list(length:length)=' ' c c set color, and line/fill c if(itype==1) then list(length+1:length+1)='c' else list(length+1:length+1)='b' endif i1=(icolor-1)/16 i0=icolor-1-i1*16 list(length+2:length+2)=hex(i1+1:i1+1) list(length+3:length+3)=hex(i0+1: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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xutl(ncolor,red,green,blue,id) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=isngl) image integer(kind=iknd), save :: nx,ny real(kind=rknd), dimension(*) :: red,green,blue common /xpm0/iscale,jscale,ishift,image(540000) common /xpm1/scale,fscale,xshift,yshift common /atest3/mode,jnlsw,jnlr,jnlw,ibatch cy c xwindows graphics implementation for pltutl c if(mode/=0) return if(ncolor<=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_rknd) image(3*i-1)=int(green(i)*65535.0e0_rknd) image(3*i)=int(blue(i)*65535.0e0_rknd) enddo call xginit(ncolor,image,id,ix,iy) ny=min(600,iy) nx=ny*3/2 scale=real(ny,rknd) iscale=nx jscale=ny ishift=4096 do k=1,nx*ny image(k)=0 enddo c return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xpmutl(ncolor,red,green,blue,fname) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), save :: length,nc,nx,ny,lenc,id=0 integer(kind=isngl) image real(kind=rknd), dimension(*) :: red,green,blue character(len=1), save, dimension(92) :: cdef character(len=2), save, dimension(4096) :: cmap character(len=2) :: cs character(len=80) :: fname character(len=80), save :: sname character(len=4000) :: msg common /xpm0/iscale,jscale,ishift,image(540000) common /xpm1/scale,fscale,xshift,yshift cy 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 c xpm limited to 4096 colors c if(ncolor<=0) go to 10 c ny=600 c*** ny=260 nx=ny*3/2 c*** nx=ny scale=real(ny,rknd) iscale=nx jscale=ny ishift=4096 nc=1 lenc=91 if(ncolor>lenc) nc=2 c c initialize bitmap c do k=1,nx*ny image(k)=0 enddo c call fstr(sname,length,fname,0_iknd) call ascutl(id,sname,'w',iflag) c c set main definitions c msg='/* XPM */' call ascstr(id,msg,9_iknd,iflag) msg(1:14)='static char * ' if(sname(length-3:length)=='.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_iknd,iflag) c write(unit=msg,fmt='(a1,i4,1x,i4,1x,i4,1x,i1,a2)') + '"',nx,ny,ncolor,nc,'",' call ascstr(id,msg,19_iknd,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:23)) call ascstr(id,msg,25_iknd,iflag) enddo return c c print bitmap c 10 do j=ny,1,-1 msg(1:1)='"' if(nc==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/=1) then msg(nc*nx+2:nc*nx+3)='",' call ascstr(id,msg,nc*nx+3_iknd,iflag) else msg(nc*nx+2:nc*nx+2)='"' call ascstr(id,msg,nc*nx+2_iknd,iflag) endif enddo msg(1:2)='};' call ascstr(id,msg,2_iknd,iflag) call ascutl(id,sname,'c',iflag) return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine hexclr(r,g,b,color) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(3) :: ic character(len=12) :: color character(len=16), save :: hex='0123456789abcdef' cy c translate (r,g,b) colors to hexidecimal c ic(1)=int(r*65535.0e0_rknd) ic(2)=int(g*65535.0e0_rknd) ic(3)=int(b*65535.0e0_rknd) do i=1,3 jj=max(0,ic(i)) jj=min(65535,jj) do j=1,4 kk=jj/16 ii=jj-kk*16 color(4*i+1-j:4*i+1-j)=hex(ii+1:ii+1) jj=kk enddo enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xframe(iframe) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) common /xpm1/scale,fscale,xshift,yshift cy c if(iframe==2) then fscale=scale/2.0e0_rknd xshift=scale yshift=scale/2.0e0_rknd else if(iframe==3) then fscale=scale/2.0e0_rknd xshift=scale yshift=0.0e0_rknd else fscale=scale xshift=0.0e0_rknd yshift=0.0e0_rknd endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xline(x,y,z,n,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z common /xpm1/scale,fscale,xshift,yshift cy c pline for xpm graphics c c*** if(scale/=fscale) return zshift=fscale*0.01e0_rknd ix=int(x(1)*fscale+xshift+0.5e0_rknd) iy=int(y(1)*fscale+yshift+0.5e0_rknd) iz=int(z(1)*fscale+zshift+0.5e0_rknd) do i=2,n jx=ix jy=iy jz=iz ix=int(x(i)*fscale+xshift+0.5e0_rknd) iy=int(y(i)*fscale+yshift+0.5e0_rknd) iz=int(z(i)*fscale+zshift+0.5e0_rknd) call iline(ix,iy,iz,jx,jy,jz,icolor) enddo return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine iline(nix,niy,niz,njx,njy,njz,ic) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=isngl) image common /xpm0/iscale,jscale,ishift,image(540000) cy c update bitmap for a line segment c ix=max(nix,1) ix=min(ix,iscale) jx=max(njx,1) jx=min(jx,iscale) iy=max(niy,1) iy=min(iy,jscale) jy=max(njy,1) jy=min(jy,jscale) iz=niz jz=njz c if(ix/=jx) then kmin=min(ix,jx) kmax=max(ix,jx) do k=kmin,kmax x=real((k-ix)*jx+(jx-k)*ix,rknd)/real(jx-ix,rknd) y=real((k-ix)*jy+(jx-k)*iy,rknd)/real(jx-ix,rknd) z=real((k-ix)*jz+(jx-k)*iz,rknd)/real(jx-ix,rknd) kx=max(int(x+0.5e0_rknd),1_iknd) kx=min(kx,iscale) ky=max(int(y+0.5e0_rknd),1_iknd) ky=min(ky,jscale) kz=int(z+0.5e0_rknd) idx=kx+(ky-1)*iscale if(kz>=image(idx)/ishift) image(idx)=kz*ishift+ic-1 enddo endif if(iy/=jy) then kmin=min(iy,jy) kmax=max(iy,jy) do k=kmin,kmax x=real((k-iy)*jx+(jy-k)*ix,rknd)/real(jy-iy,rknd) y=real((k-iy)*jy+(jy-k)*iy,rknd)/real(jy-iy,rknd) z=real((k-iy)*jz+(jy-k)*iz,rknd)/real(jy-iy,rknd) kx=max(int(x+0.5e0_rknd),1_iknd) kx=min(kx,iscale) ky=max(int(y+0.5e0_rknd),1_iknd) ky=min(ky,jscale) kz=int(z+0.5e0_rknd) idx=kx+(ky-1)*iscale if(kz>=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 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine xfill(x,y,z,n,icolor) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) real(kind=rknd), dimension(*) :: x,y,z real(kind=rknd), dimension(200) :: rm,rz common /xpm1/scale,fscale,xshift,yshift cy c pfill for xpm graphics c c*** if(scale/=fscale) return ixmin=int(x(1)*fscale+xshift+0.5e0_rknd) ixmax=ixmin iymin=int(y(1)*fscale+yshift+0.5e0_rknd) iymax=iymin do i=2,n ix=int(x(i)*fscale+xshift+0.5e0_rknd) iy=int(y(i)*fscale+yshift+0.5e0_rknd) ixmin=min(ixmin,ix) ixmax=max(ixmax,ix) iymin=min(iymin,iy) iymax=max(iymax,iy) enddo if(ixmax-ixminxx.and.x(j)<=xx) then np=np+1 else if(x(i)<=xx.and.x(j)>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)yy.and.y(j)<=yy) then np=np+1 else if(y(i)<=yy.and.y(j)>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)0) then dt=max(tx-ty,1.0e-10_rknd) time(1,isw)=time(1,isw)+dt time(2,isw)=time(2,isw)+dt else if(isw==-1) then do i=1,len time(1,i)=0.0e0_rknd enddo else if(isw==-2) then do i=1,len time(1,i)=0.0e0_rknd time(2,i)=0.0e0_rknd time(3,i)=0.0e0_rknd enddo endif return end c----------------------------------------------------------------------- c c piecewise lagrange triangle multi grid package c c edition 11.0 - - - june, 2012 c c----------------------------------------------------------------------- subroutine dpatch(i2,len2,vlist2,blist2, + i3,len3,vlist3,blist3,vtype,vx,vy) cx use mthdef implicit real(kind=rknd) (a-h,o-z) implicit integer(kind=iknd) (i-n) integer(kind=iknd), dimension(*) :: vlist2,blist2, + vlist3,blist3,vtype real(kind=rknd), dimension(*) :: vx,vy real(kind=rknd), save, dimension(6) :: red,green,blue real(kind=rknd), dimension(6) :: x,y,z cy common /atest5/idevce data red/1.0e0_rknd,0.0e0_rknd,1.0e0_rknd, + 0.0e0_rknd,0.0e0_rknd,1.0e0_rknd/ data green/1.0e0_rknd,0.0e0_rknd,0.0e0_rknd, + 0.0e0_rknd,1.0e0_rknd,1.0e0_rknd/ data blue/1.0e0_rknd,0.0e0_rknd,0.0e0_rknd, + 1.0e0_rknd,0.0e0_rknd,0.0e0_rknd/ c idevce=1 call pltutl(6_iknd,red,green,blue) call pframe(5_iknd) c ax=min(vx(i2),vx(i3)) bx=ax ay=min(vy(i2),vy(i3)) by=ay do i=2,len2+1 ax=min(ax,vx(vlist2(i))) bx=max(bx,vx(vlist2(i))) ay=min(ay,vy(vlist2(i))) by=max(by,vy(vlist2(i))) enddo do i=2,len3+1 ax=min(ax,vx(vlist3(i))) bx=max(bx,vx(vlist3(i))) ay=min(ay,vy(vlist3(i))) by=max(by,vy(vlist3(i))) enddo c dx=bx-ax dy=by-ay dd=max(dx,dy) scale=0.9e0_rknd/dd xshift=0.5e0_rknd-scale*(ax+bx)/2.0e0_rknd yshift=0.5e0_rknd-scale*(ay+by)/2.0e0_rknd do i=1,6 z(i)=0.0e0_rknd enddo do i=2,len2+1 x(1)=vx(i2)*scale+xshift y(1)=vy(i2)*scale+yshift x(2)=vx(vlist2(i))*scale+xshift y(2)=vy(vlist2(i))*scale+yshift if(vlist2(i)==i3) then call pline(x,y,z,2_iknd,3_iknd) elseif(vtype(i2)>=7.and.i==2) then call pline(x,y,z,2_iknd,5_iknd) elseif(blist2(i)/=0) then call pline(x,y,z,2_iknd,5_iknd) else call pline(x,y,z,2_iknd,2_iknd) endif enddo do i=2,len3+1 x(1)=vx(i3)*scale+xshift y(1)=vy(i3)*scale+yshift x(2)=vx(vlist3(i))*scale+xshift y(2)=vy(vlist3(i))*scale+yshift if(vlist3(i)==i2) then call pline(x,y,z,2_iknd,3_iknd) elseif(vtype(i3)>=7.and.i==2) then call pline(x,y,z,2_iknd,5_iknd) elseif(blist3(i)/=0) then call pline(x,y,z,2_iknd,5_iknd) else call pline(x,y,z,2_iknd,2_iknd) endif enddo is=1 if(vtype(i2)>=7) is=2 do i=is,len2 j1=vlist2(i) j2=vlist2(i+1) x(1)=vx(j1)*scale+xshift y(1)=vy(j1)*scale+yshift x(2)=vx(j2)*scale+xshift y(2)=vy(j2)*scale+yshift if(vtype(j1)>=7.and.vtype(j2)>=7) then call pline(x,y,z,2_iknd,5_iknd) else call pline(x,y,z,2_iknd,2_iknd) endif enddo is=1 if(vtype(i3)>=7) is=2 do i=is,len3 j1=vlist3(i) j2=vlist3(i+1) x(1)=vx(j1)*scale+xshift y(1)=vy(j1)*scale+yshift x(2)=vx(j2)*scale+xshift y(2)=vy(j2)*scale+yshift if(vtype(j1)>=7.and.vtype(j2)>=7) then call pline(x,y,z,2_iknd,5_iknd) else call pline(x,y,z,2_iknd,2_iknd) endif enddo c call pframe(-5_iknd) call pltutl(-1_iknd,red,green,blue) return end .