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 -